Common Lisp Programming

簡単なプログラム

●遅延ストリーム (2)

拙作のページ 遅延ストリーム の改良版です。基本的には、Common Lisp 入門: 遅延ストリーム (3) のプログラムを ISLisp に移植したものです。関数名は stream- ではなく l を付けるように変更しています。学習が目的のプログラムなので実用性はありませんが、興味のある方はいろいろ試してみてください。

●遅延評価の仕様

delay と force は拙作のページ 遅延評価 で作成したものと同じです。

• 操作関数とマクロ
  • delay expr : 式 EXPR の評価を遅延するためのマクロ, 返り値はプロミス
  • force p : プロミス P を評価する
    • 評価結果はキャッシュされる
    • 再度評価するとキャッシュした値を返す

> (load "lazy.lsp")
T
> (defglobal a (delay (progn (print "oops!") (+ 10 20))))
A
> a
<function>
> (force a)
"oops!"
30
> (force a)
30

●遅延ストリームの仕様

• 基本関数とマクロ
  • lcons x s : 遅延ストリーム S の先頭に X を追加した新しい遅延ストリームを返す
  • lcar s : 遅延ストリーム S の先頭要素を返す
  • lcdr s : 遅延ストリーム S の先頭要素を取り除いた遅延ストリームを返す
  • 遅延ストリームの終端は NIL で表す

> (setq a (lcons 1 (lcons 2 (lcons 3 nil))))
(1 . <function>)
> (lcar a)
1
> (lcar (lcdr a) )
2
> (lcar (lcdr (lcdr a)))
3
> (lcdr (lcdr (lcdr a)))
NIL

• 遅延ストリームの生成
  • llist &rest args : 引数を格納した遅延ストリームを生成する
  • fromlist xs : リスト XS を遅延ストリームに変換する
  • tolist s : 遅延ストリーム S をリストに変換する
  • liota n m : 整数 n 以上 m 以下を格納した遅延ストリームを生成する
  • ltabulate f n m : liota に関数 F を適用した遅延ストリームを生成する
    • liota と ltabulate の引数 m に nil を渡すと無限ストリームになる
  • lunfold p f g seed : 逆畳み込み
    • p: 終了条件を表す関数, (funcall p seed) が真になるとき lunfold は NIL を返す
    • g: seed に適用する関数, (funcall g seed) で次の seed を生成する
    • f: seed に適用する関数, (funcall f seed) が遅延ストリームの要素になる
    • seed: 値, 遅延ストリームの要素の種
    • p が常に NIL を返す場合は無限ストリームになる

> (setq a (llist 1 2 3 4 5))
(1 . <function>)
> (tolist a)
(1 2 3 4 5)
> (setq a (fromlist '(1 2 3 4 5)))
(1 . <function>)
> (tolist a)
(1 2 3 4 5)
> (setq a (liota 1 10))
(1 . <function>)
> (tolist a)
(1 2 3 4 5 6 7 8 9 10)
> (setq a (ltabulate (lambda (x) (* x x)) 1 10))
(1 . <function>)
> (tolist a)
(1 4 9 16 25 36 49 64 81 100)
> (setq a (lunfold (lambda (x) (> x 10)) #'identity (lambda (x) (+ x 1)) 1))
(1 . <function>)
> (tolist a)
(1 2 3 4 5 6 7 8 9 10)
> (setq  a (lunfold (lambda (xs) (> (car xs) 3000000)) 
                    #'car
                    (lambda (xs) (cons (cdr xs) (+ (car xs) (cdr xs))))
                    '(0 . 1)))
(0 . <function>)
> (tolist a)
(0 1 1 2 3 5 8 13 21 34 55 89 144 233 377 610 987 1597 2584 4181 6765 10946 17711 28657 
46368 75025 121393 196418 317811 514229 832040 1346269 2178309)

• 遅延ストリームの基本的な操作関数
  • lnth n s : 遅延ストリーム S の N 番目の要素を返す
  • llength s : 遅延ストリーム S の長さを求める
    • 引数 S が無限ストリームの場合、llength は終了しない
  • lappend s1 s2 : 引数の遅延ストリーム S1 と S2 を連結した遅延ストリームを返す
  • lappend-delay s1 s2 : lappend の遅延評価版 (引数 S2 にはプロミスを渡す)
    • S1 が無限ストリームの場合、S1 の要素だけが出力されることに注意
  • lzip &rest ss : 遅延ストリームから要素を取り出し、それらをリストに格納したものを要素とする遅延ストリームを返す
  • ltake s n : 遅延ストリーム S の先頭から N 個の要素を取り出す遅延ストリームを返す
  • ldrop s n : 遅延ストリーム S の先頭から N 個の要素を取り除いた遅延ストリームを返す

> (setq a (liota 1 nil))
(1 . <function>)
> (dotimes (x 10) (print (lnth x a)))
1
2
3
4
5
6
7
8
9
10
NIL
> (setq a (llist 1 2 3 4 5))
(1 . <function>)
> (llength a)
5
> (setq a (lappend (llist 1 2 3 4) (llist 5 6 7 8)))
(1 . <function>)
> (tolist a)
(1 2 3 4 5 6 7 8)
> (setq a (lappend-delay (llist 1 2 3 4) (delay (llist 5 6 7 8))))
(1 . <function>)
> (tolist a)
(1 2 3 4 5 6 7 8)
> (setq a (lzip (llist 1 2 3 4) (llist 5 6 7 8)))
((1 5) . <function>)
> (tolist a)
((1 5) (2 6) (3 7) (4 8))
> (setq a (liota 0 nil))
(0 . <function>)
> (defglobal b (ltake a 10))
B
> b
(0 . <function>)
> (tolist b)
(0 1 2 3 4 5 6 7 8 9)
> (tolist (ltake (ldrop a 10) 10))
(10 11 12 13 14 15 16 17 18 19)

• 高階関数
  • lmap f &rest ss : 遅延ストリームの要素に関数 F を適用した遅延ストリームを返す
  • flatlmap f s : マッピングのあと平坦化した遅延ストリームを返す
  • lfilter pred s : 述語 PRED が真を返す要素を格納した遅延ストリームを返す
  • lfold-left f init s : 遅延ストリーム S の先頭から畳み込む
  • lfold-right f init s : 遅延ストリーム S の末尾から畳み込む
  • lscan-left f init s : 畳み込みの途中経過 (累積値) を要素とする遅延ストリームを返す
  • lforeach f s : 遅延ストリーム S の要素に関数 F を適用する
    • lfold-left, lfold-right, lforeach は有限ストリームのみ対応
  • ltake-while pred s : 述語 PRED が真を返す間、それらの要素を取り出す遅延ストリームを返す
  • ldrop-while pred s : 述語 PRED が真を返す間、それらの要素を取り除いた遅延ストリームを返す
  • levery pred &rest ss : 述語 PRED が偽であれば、ただちに NIL を返す
    • 無限ストリームで偽を返す要素がない場合、levery は終了しない
  • lsome pred &rest ss : 述語 PRED が真であれば、ただちに T を返す
    • 無限ストリームで真を返す要素がない場合、lsome は終了しない

> (setq a (liota 0 nil))
(0 . <function>)
> (setq b (lmap (lambda (x) (* x x)) a))
(0 . <function>)
> (tolist (ltake b 10))
(0 1 4 9 16 25 36 49 64 81)
> (setq b (flatlmap (lambda (x) (list x x)) a))
(0 . <function>)
> (tolist (ltake b 10))
(0 0 1 1 2 2 3 3 4 4)
> (tolist (ltake b 20))
(0 0 1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8 9 9)
> (setq b (lfilter (lambda (x) (= (mod x 2) 0)) a))
(0 . <function>)
> (tolist (ltake b 20))
(0 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30 32 34 36 38)
> (lfold-left #'+ 0 (llist 1 2 3 4 5))
15
> (lfold-right #'+ 0 (llist 1 2 3 4 5))
15
> (lfold-left #'cons nil (llist 1 2 3 4 5))
(((((NIL . 1) . 2) . 3) . 4) . 5)
> (lfold-right #'cons nil (llist 1 2 3 4 5))
(1 2 3 4 5)

> (setq a (liota 1 nil))
(1 . <function>)
> (tolist (ltake a 20))
(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20)
> (setq b (lscan-left #'* 1 a))
(1 . <function>)
> (tolist (ltake b 20))
(1 1 2 6 24 120 720 5040 40320 362880 3628800 39916800 479001600 6227020800 87178291200 
1307674368000 20922789888000 355687428096000 6402373705728000 121645100408832000)
> (setq a (liota 2 nil))
(2 . <function>)
> (tolist (ltake a 20))
(2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21)
> (setq b (lscan-left #'+ 1 a))
(1 . <function>)
> (tolist (ltake b 20))
(1 3 6 10 15 21 28 36 45 55 66 78 91 105 120 136 153 171 190 210)
> (lforeach #'print (llist 1 2 3 4 5))
1
2
3
4
5
NIL

> (setq a (liota 0 nil))
(0 . <function>)
> (setq b (ltake-while (lambda (x) (< x 10)) a))
(0 . <function>)
> (tolist b)
(0 1 2 3 4 5 6 7 8 9)
> (setq b (ltake (ldrop-while (lambda (x) (< x 10)) a) 20))
(10 . <function>)
> (tolist b)
(10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29)
> (levery (lambda (x) (= (mod x 2) 0)) (llist 2 4 6 8 10))
T
> (levery (lambda (x) (= (mod x 2) 0)) (llist 2 4 5 8 10))
NIL
> (lsome (lambda (x) (= (mod x 2) 1)) (llist 2 4 6 8 10))
NIL
> (lsome (lambda (x) (= (mod x 2) 1)) (llist 2 4 5 8 10))
T

• 集合演算
  • 以下の関数はストリームの要素が昇順に並んでいることを前提として動作する
  • lunion s1 s2 : 和集合
  • lintersect s1 s2 : 積集合
  • ldifferent s1 s2 : 差集合

> (tolist (lunion (llist 1 2 3 4) (llist 3 4 5 6)))
(1 2 3 4 5 6)
> (tolist (lintersect (llist 1 2 3 4) (llist 3 4 5 6)))
(3 4)
> (tolist (ldifferent (llist 1 2 3 4) (llist 3 4 5 6)))
(1 2)
> (tolist (ldifferent (llist 3 4 5 6) (llist 1 2 3 4)))
(5 6)
> (tolist (ldifferent (llist 1 2 3 4) (llist 1 2 3 4)))
NIL

●簡単なサンプルプログラム

リスト : フィボナッチ数

(import "list")
(load "lazy.lsp")

;;; 偶数の判定
(defun evenp (n) (= (mod n 2) 0))

;;; フィボナッチ数列
(defglobal *fibo* (lcons 0 (lcons 1 (lmap #'+ (lcdr *fibo*) *fibo*))))

;;; n 未満で最大のフィボナッチ数
(defun fibo-max (n)
  (last (tolist (ltake-while (lambda (x) (< x n)) *fibo*))))

;;; n 未満のフィボナッチ数の総和
(defun fibo-sum (n)
  (lfold-left #'+ 0 (ltake-while (lambda (x) (< x n)) *fibo*)))

;;; n 未満の偶数のフィボナッチ数の総和
(defun fibo-sum-even (n)
  (lfold-left #'+ 0 (lfilter #'evenp (ltake-while (lambda (x) (< x n)) *fibo*))))

> (tolist (ltake *fibo* 40))
(0 1 1 2 3 5 8 13 21 34 55 89 144 233 377 610 987 1597 2584 4181 6765 10946 17711 28657 
46368 75025 121393 196418 317811 514229 832040 1346269 2178309 3524578 5702887 9227465 
14930352 24157817 39088169 63245986)
> (fibo-max 300000000)
267914296
> (fibo-sum 300000000)
701408732
> (fibo-sum-even 300000000)
350704366

リスト : トリボナッチ数

(defglobal *tri* (lcons 0 (lcons 0 (lcons 1 (lmap #'+ (lcdr (lcdr *tri*)) (lcdr *tri*) *tri*)))))

> (tolist (ltake *tri* 30))
(0 0 1 1 2 4 7 13 24 44 81 149 274 504 927 1705 3136 5768 10609 19513 35890 66012 121415 223317 
410744 755476 1389537 2555757 4700770 8646064)

リスト : リュカ数

(defglobal *lucas* (lcons 2 (lcons 1 (lmap #'+ (lcdr *lucas*) *lucas*))))

> (tolist (ltake *lucas* 30))
(2 1 3 4 7 11 18 29 47 76 123 199 322 521 843 1364 2207 3571 5778 9349 15127 24476 
39603 64079 103682 167761 271443 439204 710647 1149851)

リスト : 多角数

;;; 三角数
(defglobal *triangular* (lscan-left #'+ 1 (liota 2 nil)))

;;; 四角数
(defglobal *square* (lmap (lambda (x) (* x x)) (liota 1 nil)))

;;; 五角数
(defglobal *pentagonal* (lscan-left #'+ 1 (lunfold (lambda (x) nil) #'identity (lambda (x) (+ x 3)) 4)))

;;; 三角錐数
(defglobal *triangular-pyramidal*
  (lcdr (lscan-left #'+ 0 *triangular*)))

;;; 四角錐数
(defglobal *square-pyramidal*
  (lcdr (lscan-left #'+ 0 *square*)))

;;; 五角錐数
(defglobal *pentagonal-pyramidal*
  (lcdr (lscan-left #'+ 0 *pentagonal*)))

;;; 平方三角数
(defglobal *square-triangular* (lintersect *square* *triangular*))

;;; 三角数で五角数
(defglobal *triangular-pentagonal* (lintersect *triangular* *pentagonal*))

> (tolist (ltake *triangular* 20))
(1 3 6 10 15 21 28 36 45 55 66 78 91 105 120 136 153 171 190 210)
> (tolist (ltake *square* 20))
(1 4 9 16 25 36 49 64 81 100 121 144 169 196 225 256 289 324 361 400)
> (tolist (ltake *pentagonal* 20))
(1 5 12 22 35 51 70 92 117 145 176 210 247 287 330 376 425 477 532 590)
> (tolist (ltake *triangular-pyramidal* 20))
(1 4 10 20 35 56 84 120 165 220 286 364 455 560 680 816 969 1140 1330 1540)
> (tolist (ltake *square-pyramidal* 20))
(1 5 14 30 55 91 140 204 285 385 506 650 819 1015 1240 1496 1785 2109 2470 2870)
> (tolist (ltake *pentagonal-pyramidal* 20))
(1 6 18 40 75 126 196 288 405 550 726 936 1183 1470 1800 2176 2601 3078 3610 4200)
> (tolist (ltake *square-triangular* 5))
(1 36 1225 41616 1413721)
> (tolist (ltake *triangular-pentagonal* 3))
(1 210 40755)

• これらの数列には公式があるので、そちらを使ったほうが高速
• 拙作のページ Puzzle DE Programming 多角数 を参照

リスト : 素数の生成

(defglobal *primes* (lcons 2 (lcons 3 (lcons 5 (primes-from 7)))))

(defun primep (n ps)
  (let ((p (lcar ps)))
    (cond
     ((> (* p p) n) t)
     ((= (mod n p) 0) nil)
     (t (primep n (lcdr ps))))))

(defun primes-from (n)
  (if (primep n (lcdr *primes*))
      (lcons n (primes-from (+ n 2)))
    (primes-from (+ n 2))))

;;; 双子素数
(defglobal *twin-primes*
  (lfilter (lambda (xs) (= (apply #'- xs) -2)) (lzip *primes* (lcdr *primes*))))

;;; フィボナッチ素数 (遅い)
(defglobal *fibo-primes* (lintersect *fibo* *primes*))

> (tolist (ltake *primes* 100))
(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71 73 79 83 89 97 101 103 107 109 113 127 
131 137 139 149 151 157 163 167 173 179 181 191 193 197 199 211 223 227 229 233 239 241 251 257 
263 269 271 277 281 283 293 307 311 313 317 331 337 347 349 353 359 367 373 379 383 389 397 401 
409 419 421 431 433 439 443 449 457 461 463 467 479 487 491 499 503 509 521 523 541)

> (tolist (ltake *twin-primes* 100))
((3 5) (5 7) (11 13) (17 19) (29 31) (41 43) (59 61) (71 73) (101 103) (107 109) (137 139) 
(149 151) (179 181) (191 193) (197 199) (227 229) (239 241) (269 271) (281 283) (311 313) 
(347 349) (419 421) (431 433) (461 463) (521 523) (569 571) (599 601) (617 619) (641 643) 
(659 661) (809 811) (821 823) (827 829) (857 859) (881 883) (1019 1021) (1031 1033) (1049 1051) 
(1061 1063) (1091 1093) (1151 1153) (1229 1231) (1277 1279) (1289 1291) (1301 1303) (1319 1321) 
(1427 1429) (1451 1453) (1481 1483) (1487 1489) (1607 1609) (1619 1621) (1667 1669) (1697 1699) 
(1721 1723) (1787 1789) (1871 1873) (1877 1879) (1931 1933) (1949 1951) (1997 1999) (2027 2029) 
(2081 2083) (2087 2089) (2111 2113) (2129 2131) (2141 2143) (2237 2239) (2267 2269) (2309 2311) 
(2339 2341) (2381 2383) (2549 2551) (2591 2593) (2657 2659) (2687 2689) (2711 2713) (2729 2731) 
(2789 2791) (2801 2803) (2969 2971) (2999 3001) (3119 3121) (3167 3169) (3251 3253) (3257 3259) 
(3299 3301) (3329 3331) (3359 3361) (3371 3373) (3389 3391) (3461 3463) (3467 3469) (3527 3529) 
(3539 3541) (3557 3559) (3581 3583) (3671 3673) (3767 3769) (3821 3823))

> (tolist (ltake *fibo-primes* 7))
(2 3 5 13 89 233 1597)

リスト : ハミングの問題

(defglobal
  *hs*
  (lcons
   1
   (lunion
    (lmap (lambda (x) (* x 2)) *hs*)
    (lunion (lmap (lambda (x) (* x 3)) *hs*)
            (lmap (lambda (x) (* x 5)) *hs*)))))

> (tolist (ltake *hs* 100))
(1 2 3 4 5 6 8 9 10 12 15 16 18 20 24 25 27 30 32 36 40 45 48 50 54 60 64 72 75 80 81 90 96 100 
108 120 125 128 135 144 150 160 162 180 192 200 216 225 240 243 250 256 270 288 300 320 324 360 
375 384 400 405 432 450 480 486 500 512 540 576 600 625 640 648 675 720 729 750 768 800 810 864 
900 960 972 1000 1024 1080 1125 1152 1200 1215 1250 1280 1296 1350 1440 1458 1500 1536)

リスト : 順列の生成

(defun make-perm (n s)
  (if (= n 0)
      '(())
    (flatlmap
     (lambda (x)
       (lmap (lambda (y) (cons x y))
             (make-perm (- n 1)
                        (lfilter (lambda (z) (not (eql x z))) s))))
     s)))

> (tolist (ltake (make-perm 8 (liota 1 8)) 10))
((1 2 3 4 5 6 7 8) (1 2 3 4 5 6 8 7) (1 2 3 4 5 7 6 8) (1 2 3 4 5 7 8 6) (1 2 3 4 5 8 6 7)
 (1 2 3 4 5 8 7 6) (1 2 3 4 6 5 7 8) (1 2 3 4 6 5 8 7) (1 2 3 4 6 7 5 8) (1 2 3 4 6 7 8 5))

リスト : 8 Queen の解法

(defun attack (q xs n)
  (cond
   ((null xs) nil)
   ((or (= (+ q n) (car xs)) (= (- q n) (car xs))) t)
   (t (attack q (cdr xs) (+ n 1)))))

(defun queen (s)
  (if (null s)
      '(())
    (lfilter
     (lambda (ls)
       (if (null ls)
           t
         (not (attack (car ls) (cdr ls) 1))))
     (flatlmap
      (lambda (x)
        (lmap (lambda (y) (cons x y))
              (queen (lfilter (lambda (z) (not (eql x z))) s))))
      s))))

> (tolist (ltake (queen (liota 0 7)) 10))
((0 4 7 5 2 6 1 3) (0 5 7 2 6 3 1 4) (0 6 3 5 7 1 4 2) (0 6 4 7 1 3 5 2) (1 3 5 7 2 0 6 4)
 (1 4 6 0 2 7 5 3) (1 4 6 3 0 7 5 2) (1 5 0 6 3 7 2 4) (1 5 7 2 0 3 6 4) (1 6 2 5 7 4 0 3))

> (llength (queen (liota 0 7)))
92

●プログラムリスト

;;;
;;; lazy.lsp : 遅延評価と遅延ストリーム (Easy-ISLisp 用)
;;;
;;;            Copyright (C) 2023 Makoto Hiroi
;;;

;;;
;;; 遅延評価
;;;
(defmacro delay (expr)
  `(make-promise (lambda () ,expr)))

(defun make-promise (f)
  (let ((flag nil) (result nil))
    (lambda ()
      (if (not flag)
        (let ((x (funcall f)))
          (cond ((not flag)
                 (setq flag t)
                 (setq result x)))))
      result)))

(defun force (promise)
  (funcall promise))

;;;
;;; 遅延ストリーム
;;;

;;; 遅延ストリームの生成
(defmacro lcons (a b)
  `(cons ,a (lambda () ,b)))

;;; アクセス関数
(defun lcar (s) (car s))
(defun lcdr (s)
  (if (functionp (cdr s))
    (setf (cdr s) (funcall (cdr s))))
  (cdr s))

;;; 数列の生成
(defun ltabulate (f n m)
  (if (and m (< m n))
      nil
    (lcons (funcall f n) (ltabulate f (+ n 1) m))))

(defun liota (n m) (ltabulate #'identity n m))

(defun lunfold (p f g seed)
  (if (funcall p seed)
      nil
    (lcons (funcall f seed) (lunfold p f g (funcall g seed)))))

;;; 引数を遅延ストリームに変換
(defun llist (&rest args)
  (if (null args)
      nil
    (lcons (car args) (apply #'llist (cdr args)))))

;;; リストを遅延ストリームに変換
(defun fromlist (xs) (apply #'llist xs))

;;; 遅延ストリームをリストに変換
(defun tolist (s)
  (if (null s)
      nil
    (cons (lcar s) (tolist (lcdr s)))))

;;; n 番目の要素を求める
(defun lnth (n s)
  (if (= n 0)
      (lcar s)
    (lnth (- n 1) (lcdr s))))

;;; 先頭から n 個の要素を取り出す
(defun ltake (s n)
  (if (or (null s) (= n 0))
      nil
    (lcons (lcar s) (ltake (lcdr s) (- n 1)))))

;;; 先頭から n 個の要素を取り除く
(defun ldrop (s n)
  (if (or (null s) (= n 0))
      s
    (ldrop (lcdr s) (- n 1))))

;;; ストリームの結合
(defun lappend (s1 s2)
  (if (null s1)
      s2
    (lcons (lcar s1) (lappend (lcdr s1) s2))))

;;; 遅延評価版 (s2 は遅延評価)
(defun lappend-delay (s1 s2)
  (if (null s1)
      (force s2)
    (lcons (lcar s1) (lappend-delay (lcdr s1) s2))))

;;; 遅延ストリームの要素をまとめる
(defun lzip (&rest s)
  (if (member nil s)
      nil
    (lcons (mapcar #'lcar s) (apply #'lzip (mapcar #'lcdr s)))))

;;; 長さ
(defun llength-sub (s n)
  (if (null s)
      n
    (llength-sub (lcdr s) (+ n 1))))

(defun llength (s) (llength-sub s 0))

;;;
;;; 高階関数
;;;

;;; マッピング
(defun lmap (proc &rest s)
  (if (member nil s)
      nil
    (lcons (apply proc (mapcar #'lcar s))
           (apply #'lmap proc (mapcar #'lcdr s)))))

;;; マッピングの結果を平坦化する
(defun flatlmap (proc s)
  (if (null s)
      nil
    (lappend-delay (funcall proc (lcar s))
                   (delay (flatlmap proc (lcdr s))))))

;;; フィルター
(defun lfilter (pred s)
  (cond
   ((null s) nil)
   ((funcall pred (lcar s))
    (lcons (lcar s)
           (lfilter pred (lcdr s))))
   (t (lfilter pred (lcdr s)))))

;;; 畳み込み
(defun lfold-left (proc a s)
  (if (null s)
      a
    (lfold-left proc (funcall proc a (lcar s)) (lcdr s))))

(defun lfold-right (proc a s)
  (if (null s)
      a
    (funcall proc (lcar s) (lfold-right proc a (lcdr s)))))

(defun lscan-left (proc a s)
  (lcons a (if (null s)
               nil
             (lscan-left proc (funcall proc a (lcar s)) (lcdr s)))))

;;; 巡回
(defun lforeach (proc s)
  (cond
   ((null s)
    (funcall proc (lcar s))
    (lforeach proc (lcdr s)))))

;;; 述語 pred が真を返す要素を取り出す
(defun ltake-while (pred s)
  (if (or (null s)
          (not (funcall pred (lcar s))))
      nil
    (lcons (lcar s)
           (ltake-while pred (lcdr s)))))

;;; 述語 pred が真を返す要素を取り除く
(defun ldrop-while (pred s)
  (if (not (funcall pred (lcar s)))
      s
    (ldrop-while pred (lcdr s))))

;;; pred が真を返す要素があれば T を返す
(defun lsome (pred &rest s)
  (cond
   ((member nil s) nil)
   ((apply pred (mapcar #'lcar s)) t)
   (t (apply #'lsome pred (mapcar #'lcdr s)))))

;;; pred が NIL を返す要素があれば NIL を返す
(defun levery (pred &rest s)
  (cond
   ((member nil s) t)
   ((not (apply pred (mapcar #'lcar s))) nil)
   (t (apply #'levery pred (mapcar #'lcdr s)))))

;;;
;;; 集合演算
;;;

;;; 和集合
(defun lunion (s1 s2)
  (cond
   ((null s1) s2)
   ((null s2) s1)
   ((= (lcar s1) (lcar s2))
    (lcons (lcar s1)
           (lunion (lcdr s1) (lcdr s2))))
   ((< (lcar s1) (lcar s2))
    (lcons (lcar s1)
           (lunion (lcdr s1) s2)))
   (t
    (lcons (lcar s2)
           (lunion s1 (lcdr s2))))))

;;; 積集合
(defun lintersect (s1 s2)
  (cond
   ((or (null s1) (null s2)) nil)
   ((= (lcar s1) (lcar s2))
    (lcons (lcar s1)
           (lintersect (lcdr s1) (lcdr s2))))
   ((< (lcar s1) (lcar s2))
    (lintersect (lcdr s1) s2))
   (t
    (lintersect s1 (lcdr s2)))))

;;; 差集合
(defun ldifferent (s1 s2)
  (cond
   ((null s1) nil)
   ((null s2) s1)
   ((= (lcar s1) (lcar s2))
    (ldifferent (lcdr s1) (lcdr s2)))
   ((< (lcar s1) (lcar s2))
    (lcons (lcar s1)
           (ldifferent (lcdr s1) s2)))
   (t
    (ldifferent s1 (lcdr s2)))))