お気楽 Common Lisp プログラミング入門

lazy

遅延評価 (delay, force) と遅延ストリームを扱うライブラリです。詳しい説明は以下に示す拙作のページをお読みくださいませ。

Common Lisp 入門

●インストール

アーカイブファイル minlib.tar.gz をインストールする、またはプログラムリストにある以下の 4 つのファイルを、~/common-lisp/ 以下の適当なサブディレクトリ (たとえば lazy など) に配置してください。

lazy.lisp
lazy_tst.lisp
lazy.asd
lazy_tst.asd

●遅延評価の仕様

パッケージ名 :lazy
データ型
- promise : プロミス
操作関数とマクロ
- delay expr : 式 expr の評価を遅延するためのマクロ, 返り値はプロミス
- force p : プロミス p を評価する
  - 評価結果はキャッシュされる
  - 再度評価するとキャッシュした値を返す

* (require :lazy)
; compiling file ... 略 ...
("LAZY")

* (use-package :lazy)
T

* (defvar a (delay (progn (print "oops!") (+ 10 20))))
A

* (force a)

"oops!"
30

* (force a)
30

●遅延ストリームの仕様

パッケージ名 :lazy
基本関数とマクロ
- lcons x s : 遅延ストリーム s の先頭に x を追加した新しい遅延ストリームを返す
- lcar s : 遅延ストリーム s の先頭要素を返す
- lcdr s : 遅延ストリーム s の先頭要素を取り除いた遅延ストリームを返す
- 遅延ストリームの終端は nil で表す

遅延ストリームの生成
- llist &rest args : 引数を格納した遅延ストリームを生成する
- fromlist xs : リスト xs を遅延ストリームに変換する
- tolist s : 遅延ストリーム s をリストに変換する
- liota n &key (start 0) (step 1) : start から step 刻みで n 個の要素を格納した遅延ストリームを生成する
- ltabulate n f &key (start 0) (step 1) : liota に関数 f を適用した遅延ストリームを生成する
  - 引数 n に 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 を返す場合は無限ストリームになる

遅延ストリームの基本的な操作関数
- 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 個の要素を取り除いた遅延ストリームを返す

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

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

順列と組み合わせ

lpermutation n xs : 有限ストリーム xs の中から n 個を選ぶ順列を求める
lcombination n xs : 有限ストリーム xs の中から n 個を選ぶ組み合わせを求める
引数 xs はリストでも動作する

●簡単なテスト

* (asdf:test-system :lazy)
; compiling file ... 略 ...

----- test start -----

(TOLIST (LCONS 1 NIL))
=> (1) OK

(LCAR (LCONS 1 NIL))
=> 1 OK

(LCDR (LCONS 1 NIL))
=> NIL OK

(TOLIST (LLIST 1 2 3 4))
=> (1 2 3 4) OK

(TOLIST (FROMLIST '(1 2 3 4)))
=> (1 2 3 4) OK

(LIOTA 0)
=> NIL OK

(TOLIST (LIOTA 3))
=> (0 1 2) OK

(TOLIST (LIOTA 4 START 1))
=> (1 2 3 4) OK

(TOLIST (LIOTA 5 START 3 STEP 2))
=> (3 5 7 9 11) OK

(LTABULATE 0 #'IDENTITY)
=> NIL OK

(TOLIST (LTABULATE 3 #'IDENTITY))
=> (0 1 2) OK

(TOLIST (LTABULATE 4 #'IDENTITY START 1))
=> (1 2 3 4) OK

(TOLIST (LTABULATE 5 #'SQUARE START 2 STEP 2))
=> (4 16 36 64 100) OK

(TOLIST (LUNFOLD (LAMBDA (X) (> X 4)) #'IDENTITY #'1+ 0))
=> (0 1 2 3 4) OK

(TOLIST (LUNFOLD (LAMBDA (X) (> X 5)) #'SQUARE #'1+ 1))
=> (1 4 9 16 25) OK

(TOLIST
 (LUNFOLD (LAMBDA (XS) (> (CAR XS) 3000000)) #'CAR
          (LAMBDA (XS) (LIST (SECOND XS) (APPLY #'+ XS))) '(0 1)))
=> (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) OK

(LNTH 0 (LLIST 10 20 30 40 50))
=> 10 OK

(LNTH 2 (LLIST 10 20 30 40 50))
=> 30 OK

(LNTH 4 (LLIST 10 20 30 40 50))
=> 50 OK

(LLENGTH NIL)
=> 0 OK

(LLENGTH (LIOTA 5))
=> 5 OK

(LLENGTH (LIOTA 10))
=> 10 OK

(TOLIST (LAPPEND (LLIST 1 2 3) (LLIST 4 5 6)))
=> (1 2 3 4 5 6) OK

(TOLIST (LAPPEND-DELAY (LLIST 1 2 3) (DELAY (LLIST 4 5 6))))
=> (1 2 3 4 5 6) OK

(TOLIST (LZIP (LLIST 1 2 3) (LLIST 4 5 6)))
=> ((1 4) (2 5) (3 6)) OK

(TOLIST (LTAKE (LIOTA NIL) 5))
=> (0 1 2 3 4) OK

(TOLIST (LTAKE (LDROP (LIOTA NIL) 5) 5))
=> (5 6 7 8 9) OK

(TOLIST (LTAKE (LMAP #'SQUARE (LIOTA NIL)) 5))
=> (0 1 4 9 16) OK

(TOLIST (LTAKE (LFLATMAP (LAMBDA (X) (LIST X X)) (LIOTA NIL)) 6))
=> (0 0 1 1 2 2) OK

(TOLIST (LTAKE (LFILTER #'EVENP (LIOTA NIL)) 4))
=> (0 2 4 6) OK

(LFOLD-LEFT #'+ 0 (LLIST 1 2 3 4 5))
=> 15 OK

(LFOLD-LEFT #'CONS NIL (LLIST 1 2 3 4 5))
=> (((((NIL . 1) . 2) . 3) . 4) . 5) OK

(LFOLD-RIGHT #'+ 0 (LLIST 1 2 3 4 5))
=> 15 OK

(LFOLD-RIGHT #'CONS NIL (LLIST 1 2 3 4 5))
=> (1 2 3 4 5) OK

(TOLIST (LTAKE (LSCAN-LEFT #'* 1 (LIOTA NIL START 1)) 5))
=> (1 1 2 6 24) OK

(LET ((A NIL))
  (LMAPC (LAMBDA (X) (PUSH X A)) (LLIST 1 2 3 4 5))
  (REVERSE A))
=> (1 2 3 4 5) OK

(TOLIST (LTAKE-WHILE (LAMBDA (X) (< X 5)) (LIOTA NIL)))
=> (0 1 2 3 4) OK

(TOLIST (LTAKE (LDROP-WHILE (LAMBDA (X) (< X 5)) (LIOTA NIL)) 5))
=> (5 6 7 8 9) OK

(LEVERY #'EVENP (LLIST 2 4 6 8 10))
=> T OK

(LEVERY #'EVENP (LLIST 2 4 5 8 10))
=> NIL OK

(LSOME #'ODDP (LLIST 2 4 5 8 10))
=> T OK

(LSOME #'ODDP (LLIST 2 4 6 8 10))
=> NIL OK

(TOLIST (LUNION (LLIST 1 2 3 4) (LLIST 3 4 5 6)))
=> (1 2 3 4 5 6) OK

(TOLIST (LINTERSECT (LLIST 1 2 3 4) (LLIST 3 4 5 6)))
=> (3 4) OK

(TOLIST (LDIFFERENT (LLIST 1 2 3 4) (LLIST 3 4 5 6)))
=> (1 2) OK

(TOLIST (LDIFFERENT (LLIST 3 4 5 6) (LLIST 1 2 3 4)))
=> (5 6) OK

(TOLIST (LDIFFERENT (LLIST 1 2 3 4) (LLIST 1 2 3 4)))
=> NIL OK

(TOLIST (LPERMUTATION 4 (LLIST 'A 'B 'C 'D)))
=> ((A B C D) (A B D C) (A C B D) (A C D B) (A D B C) (A D C B) (B A C D)
    (B A D C) (B C A D) (B C D A) (B D A C) (B D C A) (C A B D) (C A D B)
    (C B A D) (C B D A) (C D A B) (C D B A) (D A B C) (D A C B) (D B A C)
    (D B C A) (D C A B) (D C B A)) OK

(TOLIST (LCOMBINATION 3 (LLIST 'A 'B 'C 'D 'E)))
=> ((A B C) (A B D) (A B E) (A C D) (A C E) (A D E) (B C D) (B C E) (B D E)
    (C D E)) OK

----- test end -----
TEST: 49
OK: 49
NG: 0
ERR: 0
T

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

;;;
;;; lazyfibo.lisp : フィボナッチ数 (遅延ストリーム版)
;;;
;;; Copyright (C) 2023 Makoto Hiroi
;;;
;;; Released under the MIT license
;;; https://opensource.org/license/mit/
;;;
(require :lazy)
(use-package :lazy)

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

;;; n 未満で最大のフィボナッチ数
(defun fibo-max (n)
  (car (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*))))

;;; トリボナッチ数
(defvar *tri*)
(setq *tri*
      (lcons 0 (lcons 0 (lcons 1 (lmap #'+ (lcdr (lcdr *tri*)) (lcdr *tri*) *tri*)))))

;;; リュカ数
(defvar *lucas*)
(setq *lucas* (lcons 2 (lcons 1 (lmap #'+ (lcdr *lucas*) *lucas*))))

* (load "lazyfibo.lisp")
T

* (tolist (ltake *fibo* 20))
(0 1 1 2 3 5 8 13 21 34 55 89 144 233 377 610 987 1597 2584 4181)

* (fibo-max 300000000)
267914296

* (fibo-sum 300000000)
701408732

* (fibo-sum-even 300000000)
350704366

* (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)

* (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)

;;;
;;; lazypoly.lisp : 多角数 (遅延ストリーム版)
;;;
;;; Copyright (C) 2023 Makoto Hiroi
;;;
;;; Released under the MIT license
;;; https://opensource.org/license/mit/
;;;
(require :lazy)
(use-package :lazy)

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

;;; 四角数
(defvar *square* (lmap (lambda (x) (* x x)) (liota nil :start 1)))

;;; 五角数
(defvar *pentagonal* (lscan-left #'+ 1 (liota nil :start 4 :step 3)))

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

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

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

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

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

* (load "lazypoly.lisp")
T

* (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* 7))
(1 36 1225 41616 1413721 48024900 1631432881)

* (tolist (ltake *triangular-pentagonal* 5))
(1 210 40755 7906276 1533776805)

これらの数列には公式があるので、そちらを使ったほうが高速です。
詳細は拙作のページ Puzzle DE Programming 多角数をお読みください。

;;;
;;; lazyprime.lisp : 素数 (遅延ストリーム版)
;;;
;;; Copyright (C) 2023 Makoto Hiroi
;;;
;;; Released under the MIT license
;;; https://opensource.org/license/mit/
;;;
(load "lazyfibo.lisp")

(declaim (ftype (function (integer) t) primes-from))
(defvar *primes* (lcons 2 (lcons 3 (lcons 5 (primes-from 7)))))

(defun primep (n &optional (ps (lcdr *primes*)))
  (let ((p (lcar ps)))
    (cond
     ((> (* p p) n) t)
     ((zerop (mod n p)) nil)
     (t (primep n (lcdr ps))))))

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

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

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

;;; 少し速くなる
(defvar *fibo-primes1* (lfilter (lambda (x) (primep x *primes*)) (ldrop *fibo* 3)))

* (load "lazyprime.lisp")
T

* (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* 50))
((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))

* (tolist (ltake *fibo-primes* 8))
(2 3 5 13 89 233 1597 28657)

* (tolist (ltake *fibo-primes1* 10))
(2 3 5 13 89 233 1597 28657 514229 433494437)

;;;
;;; lazypuz.lisp : 簡単なパズル (遅延ストリーム版)
;;;
;;; Copyright (C) 2023 Makoto Hiroi
;;;
;;; Released under the MIT license
;;; https://opensource.org/license/mit/
;;;
(require :lazy)
(use-package :lazy)

;;;
;;; ハミングの問題
;;;
(defvar *hs*)
(setq *hs*
      (lcons
       1
       (lunion
        (lmap (lambda (x) (* x 2)) *hs*)
        (lunion (lmap (lambda (x) (* x 3)) *hs*)
                (lmap (lambda (x) (* x 5)) *hs*)))))

;;;
;;; 8 Queen の解法
;;;
(defun attack (q xs &optional (n 1))
  (cond
   ((null xs) nil)
   ((or (= (+ q n) (car xs)) (= (- q n) (car xs))) t)
   (t (attack q (cdr xs) (1+ n)))))

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

;;;
;;; マスターマインドの解法
;;;

;;; bulls をカウント
(defun count-bulls (xs ys)
  (count t (mapcar #'= xs ys)))

;;; 同じ数字をカウント
(defun count-same-number (xs ys &aux (c 0))
  (dolist (x xs c)
    (if (member x ys) (incf c))))

;;; コードのチェック
;;; qs = (code bulls cows)
(defun check-code (code qs)
  (let* ((bulls (count-bulls (first qs) code))
         (cows (- (count-same-number (first qs) code) bulls)))
    (and (= (second qs) bulls) (= (third qs) cows))))

;;; ソルバー
(defun mastermind-solver (answer cs)
  (let (query)
    (lmapc
     (lambda (code)
      (when (every (lambda (qs) (check-code code qs)) query)
        (let* ((bulls (count-bulls answer code))
               (cows (- (count-same-number answer code) bulls)))
          (push (list code bulls cows) query)
          (when (= bulls (length answer))
            (return-from mastermind-solver (nreverse query))))))
     cs)))

;;; マスターマインドを解く
(defun mastermind (answer)
  (loop for i from 1
        for q in (mastermind-solver answer (lpermutation (length answer) (liota 10)))
        do (format t "~2d: ~a, bulls = ~d, cows = ~d~%" i (first q) (second q) (third q))
        finally (format t "Good Job!!~%")))

;;; 平均質問回数と最大質問回数を求める
(defun mastermind-max (n)
  (let ((cs (lpermutation n (liota 10)))
        (sum 0) (max 0) code)
    (lmapc
     (lambda (c)
       (let* ((q (mastermind-solver c cs))
              (l (length q)))
         (cond
          ((< max l)
           (setq max l code (list c)))
          ((= max l)
           (push c code)))
         (incf sum l)))
     cs)
    (format t "avg = ~f, max = ~d, code = ~s~%" (float (/ sum (llength cs))) max code)))

* (load "lazypuz.lisp")
T
(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)

* (defvar a (queen (liota 8)))
A

* a
((0 4 7 5 2 6 1 3) . #<CLOSURE (LAMBDA () :IN LFILTER) {1004939C0B}>)

* (tolist (ltake a 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 a)
92

* (mastermind-max 3)
avg = 5.266667, max = 9, code = ((9 0 2) (2 9 0))
NIL

* (mastermind '(2 9 0))
 1: (0 1 2), bulls = 0, cows = 2
 2: (1 0 3), bulls = 0, cows = 1
 3: (2 4 0), bulls = 2, cows = 0
 4: (2 4 1), bulls = 1, cows = 0
 5: (2 5 0), bulls = 2, cows = 0
 6: (2 6 0), bulls = 2, cows = 0
 7: (2 7 0), bulls = 2, cows = 0
 8: (2 8 0), bulls = 2, cows = 0
 9: (2 9 0), bulls = 3, cows = 0
Good Job!!
NIL

* (mastermind-max 4)
avg = 5.5603175, max = 9, code = ((9 4 3 1) (9 2 4 1) (9 2 1 4) (9 2 0 4)
                                  (5 2 9 3))

* (mastermind '(5 2 9 3))
 1: (0 1 2 3), bulls = 1, cows = 1
 2: (0 2 4 5), bulls = 1, cows = 1
 3: (0 3 5 6), bulls = 0, cows = 2
 4: (1 5 4 3), bulls = 1, cows = 1
 5: (1 6 2 5), bulls = 0, cows = 2
 6: (4 2 6 3), bulls = 2, cows = 0
 7: (5 2 7 3), bulls = 3, cows = 0
 8: (5 2 8 3), bulls = 3, cows = 0
 9: (5 2 9 3), bulls = 4, cows = 0
Good Job!!
NIL

* (mastermind-max 5)
avg = 5.994676, max = 9, code = ((9 8 7 2 5) (9 8 6 2 1) (9 8 6 2 0)

                                   ・・・省略・・・

                                 (3 9 8 0 1) (1 8 3 9 0))
NIL
* (mastermind '(1 8 3 9 0))
 1: (0 1 2 3 4), bulls = 0, cows = 3
 2: (1 0 3 5 6), bulls = 2, cows = 1
 3: (1 0 4 6 7), bulls = 1, cows = 1
 4: (1 2 0 5 8), bulls = 1, cows = 2
 5: (1 3 8 2 6), bulls = 1, cows = 2
 6: (1 4 3 8 5), bulls = 2, cows = 1
 7: (1 5 3 7 2), bulls = 2, cows = 0
 8: (1 8 3 0 9), bulls = 3, cows = 2
 9: (1 8 3 9 0), bulls = 5, cows = 0
Good Job!!
NIL

●プログラムリスト

;;;
;;; lazy.lisp : 遅延評価と遅延ストリーム
;;;
;;; Copyright (C) 2023 Makoto Hiroi
;;;
;;; Released under the MIT license
;;; https://opensource.org/license/mit/
;;; https://licenses.opensource.jp/MIT/MIT.html
;;;
(provide :lazy)
(defpackage :lazy (:use :cl))
(in-package :lazy)
(export '(promise delay force
          lcons lcar lcdr
          lunfold ltabulate liota llist
          fromlist tolist
          llength lnth ltake ldrop
          lappend lappend-delay lzip
          lmap lflatmap lfilter lmapc
          lfold-left lfold-right lscan-left
          ltake-while ldrop-while lsome levery
          lunion lintersect ldifferent
          lpermutation lcombination
          ))

;;;
;;; 遅延評価
;;;

;;; プロミスの定義
(defstruct promise (result nil) thunk)

(defmacro delay (expr)
  `(make-promise :thunk (lambda () ,expr)))

(defun force (ps)
  (when (promise-thunk ps)
    (setf (promise-result ps) (funcall (promise-thunk ps))
          (promise-thunk  ps) nil))
  (promise-result ps))

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

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

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

;;; 数列の生成
(defun ltabulate (n f &key (start 0) (step 1))
  (if (and n (zerop n))
      nil
    (lcons (funcall f start)
           (ltabulate (if n (1- n) nil) f :start (+ start step) :step step))))

(defun liota (n &key (start 0) (step 1))
  (ltabulate n #'identity :start start :step step))

(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)
  (loop until (null s) collect (lcar s)
        do (setq s (lcdr s))))

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

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

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

;;; ストリームの結合
(defun lappend (s1 s2)
  (if (null s1)
      s2
    (lcons (lcar s1)
           (lappend (lcdr s1) 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 (s &optional (n 0))
  (if (null s)
      n
    (llength (lcdr s) (1+ n))))

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

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

;;; マッピングの結果を平坦化する
(defun lflatmap (proc s)
  (if (null s)
      nil
    (lappend-delay (funcall proc (lcar s))
                   (delay (lflatmap 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 lmapc (proc s)
  (unless (null s)
    (funcall proc (lcar s))
    (lmapc 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)))))

;;;
;;; 順列と組み合わせ
;;;
(defun lpermutation (n xs)
  (if (zerop n)
      '(())
    (lflatmap
     (lambda (x)
       (lmap (lambda (y) (cons x y))
             (lpermutation (1- n)
                           (lfilter (lambda (z) (not (eql x z))) xs))))
     xs)))

(defun lcombination (n xs)
  (cond
   ((zerop n) '(()))
   ((null xs) nil)
   (t
    (lappend-delay
     (lmap (lambda (ys) (cons (lcar xs) ys))
           (lcombination (1- n) (lcdr xs)))
     (delay (lcombination n (lcdr xs)))))))

リスト : lazy.asd

(defsystem :lazy
  :description "delay, force, lazy stream"
  :version "0.1.0"
  :author "Makoto Hiroi"
  :license "MIT"
  :depends-on ()
  :components ((:file "lazy")))

;;;
;;; lazy_tst.lisp : lazy のテスト
;;;
;;; Copyright (C) 2023 Makoto Hiroi
;;;
;;; Released under the MIT license
;;; https://opensource.org/license/mit/
;;;
(provide :lazy_tst)
(defpackage :lazy_tst (:use :cl :lazy :mintst))
(in-package :lazy_tst)
(export '(test))

(defun square (x) (* x x))

(defun test ()
  (initial)
  (run (tolist (lcons 1 nil)) '(1))
  (run (lcar (lcons 1 nil)) 1)
  (run (lcdr (lcons 1 nil)) nil)
  (run (tolist (llist 1 2 3 4)) '(1 2 3 4))
  (run (tolist (fromlist '(1 2 3 4))) '(1 2 3 4))
  (run (liota 0) nil)
  (run (tolist (liota 3)) '(0 1 2))
  (run (tolist (liota 4 :start 1)) '(1 2 3 4))
  (run (tolist (liota 5 :start 3 :step 2)) '(3 5 7 9 11))
  (run (ltabulate 0 #'identity) nil)
  (run (tolist (ltabulate 3 #'identity)) '(0 1 2))
  (run (tolist (ltabulate 4 #'identity :start 1)) '(1 2 3 4))
  (run (tolist (ltabulate 5 #'square :start 2 :step 2)) '(4 16 36 64 100))
  (run (tolist (lunfold (lambda (x) (> x 4)) #'identity #'1+ 0))
       '(0 1 2 3 4))
  (run (tolist (lunfold (lambda (x) (> x 5)) #'square #'1+ 1))
       '(1 4 9 16 25))
  (run (tolist (lunfold (lambda (xs) (> (car xs) 3000000))
                        #'car
                        (lambda (xs) (list (second xs) (apply #'+ xs)))
                        '(0 1)))
       '(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))
  (run (lnth 0 (llist 10 20 30 40 50)) 10)
  (run (lnth 2 (llist 10 20 30 40 50)) 30)
  (run (lnth 4 (llist 10 20 30 40 50)) 50)
  (run (llength nil) 0)
  (run (llength (liota 5)) 5)
  (run (llength (liota 10)) 10)
  (run (tolist (lappend (llist 1 2 3) (llist 4 5 6))) '(1 2 3 4 5 6))
  (run (tolist (lappend-delay (llist 1 2 3) (delay (llist 4 5 6)))) '(1 2 3 4 5 6))
  (run (tolist (lzip (llist 1 2 3) (llist 4 5 6))) '((1 4) (2 5) (3 6)))
  (run (tolist (ltake (liota nil) 5)) '(0 1 2 3 4))
  (run (tolist (ltake (ldrop (liota nil) 5) 5)) '(5 6 7 8 9))
  ;; 高階関数
  (run (tolist (ltake (lmap #'square (liota nil)) 5)) '(0 1 4 9 16))
  (run (tolist (ltake (lflatmap (lambda (x) (list x x)) (liota nil)) 6)) '(0 0 1 1 2 2))
  (run (tolist (ltake (lfilter #'evenp (liota nil)) 4)) '(0 2 4 6))
  (run (lfold-left #'+ 0 (llist 1 2 3 4 5)) 15)
  (run (lfold-left #'cons nil (llist 1 2 3 4 5))
       '(((((NIL . 1) . 2) . 3) . 4) . 5))
  (run (lfold-right #'+ 0 (llist 1 2 3 4 5)) 15)
  (run (lfold-right #'cons nil (llist 1 2 3 4 5))
       '(1 2 3 4 5))
  (run (tolist (ltake (lscan-left #'* 1 (liota nil :start 1)) 5)) '(1 1 2 6 24))
  (run (let ((a nil))
         (lmapc (lambda (x) (push x a)) (llist 1 2 3 4 5))
         (reverse a))
       '(1 2 3 4 5))
  (run (tolist (ltake-while (lambda (x) (< x 5)) (liota nil))) '(0 1 2 3 4))
  (run (tolist (ltake (ldrop-while (lambda (x) (< x 5)) (liota nil)) 5)) '(5 6 7 8 9))
  (run (levery #'evenp (llist 2 4 6 8 10)) t)
  (run (levery #'evenp (llist 2 4 5 8 10)) nil)
  (run (lsome #'oddp (llist 2 4 5 8 10)) t)
  (run (lsome #'oddp (llist 2 4 6 8 10)) nil)
  ;; 集合演算
  (run (tolist (lunion (llist 1 2 3 4) (llist 3 4 5 6))) '(1 2 3 4 5 6))
  (run (tolist (lintersect (llist 1 2 3 4) (llist 3 4 5 6))) '(3 4))
  (run (tolist (ldifferent (llist 1 2 3 4) (llist 3 4 5 6))) '(1 2))
  (run (tolist (ldifferent (llist 3 4 5 6) (llist 1 2 3 4))) '(5 6))
  (run (tolist (ldifferent (llist 1 2 3 4) (llist 1 2 3 4))) nil)
  ;; 順列と組み合わせ
  (run (tolist (lpermutation 4 (llist 'a 'b 'c 'd)))
       '((A B C D) (A B D C) (A C B D) (A C D B) (A D B C) (A D C B) (B A C D)
         (B A D C) (B C A D) (B C D A) (B D A C) (B D C A) (C A B D) (C A D B)
         (C B A D) (C B D A) (C D A B) (C D B A) (D A B C) (D A C B) (D B A C)
         (D B C A) (D C A B) (D C B A)))
  (run (tolist (lcombination 3 (llist 'a 'b 'c 'd 'e)))
       '((A B C) (A B D) (A B E) (A C D) (A C E) (A D E) (B C D) (B C E) (B D E) (C D E)))
  (final))

リスト : lazy_tst.asd

(defsystem :lazy_tst
  :description "test for lazy"
  :version "0.1.0"
  :author "Makoto Hiroi"
  :license "MIT"
  :depends-on (:mintst :lazy)
  :components ((:file "lazy_tst"))
  :perform (test-op (o s) (symbol-call :lazy_tst :test)))

Common Lisp Programming

お気楽 Common Lisp プログラミング入門 : 自作ライブラリ編

lazy

●インストール

●遅延評価の仕様

●遅延ストリームの仕様

●簡単なテスト

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

●プログラムリスト