拙作のページ「遅延ストリーム (2)」で作成したプログラム (プロミスを使わずに遅延ストリームを実装する) をパッケージ化したものです。関数名は stream- ではなく l を付けるように変更しています。学習が目的のプログラムなので実用性はありませんが、興味のある方はいろいろ試してみてください。
* (require :lazy "lazy.lisp")
("LAZY")
* (use-package :lazy)
T
* (defvar a (delay (progn (print "oops!") (+ 10 20))))
A
* (force a)
"oops!"
30
* (force a)
30
* (setq a (lcons 1 (lcons 2 (lcons 3 nil))))
(1 . #<FUNCTION (LAMBDA ()) {100386B6CB}>)
* (lcar a)
1
* (lcar (lcdr a))
2
* (lcar (lcdr (lcdr a)))
3
* (lcar (lcdr (lcdr (lcdr a))))
NIL
* (setq a (llist 1 2 3 4 5))
(1 . #<CLOSURE (LAMBDA () :IN LLIST) {1003F35E8B}>)
* (tolist a)
(1 2 3 4 5)
* (setq a (fromlist '(1 2 3 4 5)))
(1 . #<CLOSURE (LAMBDA () :IN LLIST) {1003F3935B}>)
* (tolist a)
(1 2 3 4 5)
* (setq a (liota 10))
(0 . #<CLOSURE (LAMBDA () :IN LTABULATE) {1003F3B9FB}>)
* (tolist a)
(0 1 2 3 4 5 6 7 8 9)
* (setq a (ltabulate 10 (lambda (x) (* x x))))
(0 . #<CLOSURE (LAMBDA () :IN LTABULATE) {1003F8817B}>)
* (tolist a)
(0 1 4 9 16 25 36 49 64 81)
* (setq a (lunfold (lambda (xs) (> (car xs) 3000000))
#'car
(lambda (xs) (list (second xs) (apply #'+ xs)))
'(0 1)))
(0 . #<CLOSURE (LAMBDA () :IN LUNFOLD) {100405377B}>)
* (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)
* (setq a (liota nil))
(0 . #<CLOSURE (LAMBDA () :IN LTABULATE) {10040571FB}>)
* (dotimes (x 10) (print (lnth x a)))
0
1
2
3
4
5
6
7
8
9
NIL
* (setq a (llist 1 2 3 4 5))
(1 . #<CLOSURE (LAMBDA () :IN LLIST) {1004086AEB}>)
* (llength a)
5
* (setq a (lappend (llist 1 2 3 4) (llist 5 6 7 8)))
(1 . #<CLOSURE (LAMBDA () :IN LAPPEND) {1004089D4B}>)
* (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 . #<CLOSURE (LAMBDA () :IN LAPPEND-DELAY) {10040AE05B}>)
* (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) . #<CLOSURE (LAMBDA () :IN LZIP) {10040B1EEB}>)
* (tolist a)
((1 5) (2 6) (3 7) (4 8))
* (setq a (liota nil))
(0 . #<CLOSURE (LAMBDA () :IN LTABULATE) {10040B4BBB}>)
* (take a 10)
(0 1 2 3 4 5 6 7 8 9)
* (tolist (ltake a 10))
(0 1 2 3 4 5 6 7 8 9)
* (take (drop a 20) 10)
(20 21 22 23 24 25 26 27 28 29)
* (setq a (lmap (lambda (x) (* x x)) (liota nil)))
(0 . #<CLOSURE (LAMBDA () :IN LMAP) {10040CFEFB}>)
* (take a 10)
(0 1 4 9 16 25 36 49 64 81)
* (setq a (flatlmap (lambda (x) (llist x x)) (liota nil)))
(0 . #<CLOSURE (LAMBDA () :IN LAPPEND-DELAY) {10040E6E5B}>)
* (take a 10)
(0 0 1 1 2 2 3 3 4 4)
* (setq a (lfilter #'evenp (liota nil)))
(0 . #<CLOSURE (LAMBDA () :IN LFILTER) {10040EA39B}>)
* (take a 10)
(0 2 4 6 8 10 12 14 16 18)
* (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 (lscan-left #'* 1 (liota nil 1)))
(1 . #<CLOSURE (LAMBDA () :IN LSCAN-LEFT) {10040F961B}>)
* (take a 20)
(1 1 2 6 24 120 720 5040 40320 362880 3628800 39916800 479001600 6227020800
87178291200 1307674368000 20922789888000 355687428096000 6402373705728000
121645100408832000)
* (setq a (lscan-left #'+ 1 (liota nil 2)))
(1 . #<CLOSURE (LAMBDA () :IN LSCAN-LEFT) {10040FD61B}>)
* (take a 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 (ltake-while (lambda (x) (< x 10)) (liota nil)))
(0 . #<CLOSURE (LAMBDA () :IN LTAKE-WHILE) {100411AE0B}>)
* (tolist a)
(0 1 2 3 4 5 6 7 8 9)
* (take-while (lambda (x) (< x 10)) (liota nil))
(0 1 2 3 4 5 6 7 8 9)
* (take (drop-while (lambda (x) (< x 10)) (liota nil)) 10)
(10 11 12 13 14 15 16 17 18 19)
* (levery #'evenp (llist 2 4 6 8 10))
T
* (levery #'evenp (llist 2 4 5 8 10))
NIL
* (lsome #'oddp (llist 2 4 5 8 10))
T
* (lsome #'oddp (llist 2 4 6 8 10))
NIL
* (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
リスト : フィボナッチ数 (defvar *fibo*) (setq *fibo* (lcons 0 (lcons 1 (lmap #'+ (lcdr *fibo*) *fibo*)))) ;;; n 未満で最大のフィボナッチ数 (defun fibo-max (n) (car (last (take-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*))))
* (take *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
リスト : トリボナッチ数
(defvar *tri*)
(setq *tri*
(lcons 0 (lcons 0 (lcons 1 (lmap #'+ (lcdr (lcdr *tri*)) (lcdr *tri*) *tri*)))))
* (take *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)
リスト : リュカ数 (defvar *lucas*) (setq *lucas* (lcons 2 (lcons 1 (lmap #'+ (lcdr *lucas*) *lucas*))))
* (take *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)
リスト : 多角数 ;;; 三角数 (defvar *triangular* (lscan-left #'+ 1 (liota nil 2))) ;;; 四角数 (defvar *square* (lmap (lambda (x) (* x x)) (liota nil 1))) ;;; 五角数 (defvar *pentagonal* (lscan-left #'+ 1 (liota nil 4 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*))
* (take *triangular* 20) (1 3 6 10 15 21 28 36 45 55 66 78 91 105 120 136 153 171 190 210) * (take *square* 20) (1 4 9 16 25 36 49 64 81 100 121 144 169 196 225 256 289 324 361 400) * (take *pentagonal* 20) (1 5 12 22 35 51 70 92 117 145 176 210 247 287 330 376 425 477 532 590) * (take *triangular-pyramidal* 20) (1 4 10 20 35 56 84 120 165 220 286 364 455 560 680 816 969 1140 1330 1540) * (take *square-pyramidal* 20) (1 5 14 30 55 91 140 204 285 385 506 650 819 1015 1240 1496 1785 2109 2470 2870) * (take *pentagonal-pyramidal* 20) (1 6 18 40 75 126 196 288 405 550 726 936 1183 1470 1800 2176 2601 3078 3610 4200) * (take *square-triangular* 7) (1 36 1225 41616 1413721 48024900 1631432881) * (take *triangular-pentagonal* 5) (1 210 40755 7906276 1533776805)
リスト : 素数の生成
(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*)) (drop *fibo* 3)))
* (take *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) * (take *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)) * (take *fibo-primes* 8) (2 3 5 13 89 233 1597 28657) * (take *fibo-primes1* 10) (2 3 5 13 89 233 1597 28657 514229 433494437)
リスト : ハミングの問題
(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*)))))
* (take *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 (zerop n)
'(())
(flatlmap
(lambda (x)
(lmap (lambda (y) (cons x y))
(make-perm (1- n)
(lfilter (lambda (z) (not (eql x z))) s))))
s)))
* (setq a (make-perm 8 (liota 8)))
((0 1 2 3 4 5 6 7) . #<CLOSURE (LAMBDA () :IN LAPPEND-DELAY) {10045D31FB}>)
* (take a 10)
((0 1 2 3 4 5 6 7) (0 1 2 3 4 5 7 6) (0 1 2 3 4 6 5 7) (0 1 2 3 4 6 7 5)
(0 1 2 3 4 7 5 6) (0 1 2 3 4 7 6 5) (0 1 2 3 5 4 6 7) (0 1 2 3 5 4 7 6)
(0 1 2 3 5 6 4 7) (0 1 2 3 5 6 7 4))
リスト : 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)))))
(flatlmap
(lambda (x)
(lmap (lambda (y) (cons x y))
(queen (lfilter (lambda (z) (not (eql x z))) s))))
s))))
* (setq a (queen (liota 8)))
((0 4 7 5 2 6 1 3) . #<CLOSURE (LAMBDA () :IN LFILTER) {1004939C0B}>)
* (take 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
リスト : マスターマインドの解法
;;; 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)
(lforeach
(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 (make-perm (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 (make-perm n (liota 10)))
(sum 0) (max 0) code)
(lforeach
(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)))
* (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) 2020 Makoto Hiroi
;;;
(provide :lazy)
(defpackage :lazy (:use :cl))
(in-package :lazy)
(export '(promise delay force lcons lcar lcdr lunfold ltabulate liota
llist fromlist tolist lnth ltake take drop lappend lappend-delay
llength lzip lmap flatlmap lfilter lfold-left lfold-right lscan-left
lforeach ltake-while take-while drop-while lsome levery lunion
lintersect ldifferent))
;;;
;;; 遅延評価
;;;
;;; プロミスの定義
(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 &optional (seed 0) (step 1))
(if (and n (zerop n))
nil
(lcons (funcall f seed)
(ltabulate (if n (1- n) nil) f (+ seed step) step))))
(defun liota (n &optional (seed 0) (step 1))
(ltabulate n #'identity seed 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 take (s n)
(loop until (or (null s) (zerop n)) collect (lcar s)
do (setq s (lcdr s))
(decf n)))
;;; 先頭から n 個の要素を取り除く
(defun drop (s n)
(if (or (null s) (zerop n))
s
(drop (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 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)
(unless (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)))))
;;; 要素をリストに格納して返す
(defun take-while (pred s)
(loop until (or (null s)
(not (funcall pred (lcar s))))
collect (lcar s)
do (setq s (lcdr s))))
;;; 述語 pred が真を返す要素を取り除く
(defun drop-while (pred s)
(if (not (funcall pred (lcar s)))
s
(drop-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)))))
今回は Gauche (Scheme) の「遅延シーケンス (Lazy Sequences)」を参考にして、今までとはちょっと異なる遅延ストリームを実装してみましょう。なお、遅延シーケンスは SRFI 127: Lazy Sequences で標準化されていて、Scheme の仕様 (R7RS large) にも取り込まれるそうです。
今までは遅延ストリームをコンスセルで表しました。CAR 部に要素を、CDR 部が遅延ストリームを生成する関数を格納します。遅延シーケンスも同じようにコンスセルを使いますが、CDR 部には要素を生成する関数 (ジェネレータ) を格納するところが異なります。
(item . generator) ; generator は引数のない関数
遅延シーケンスの CDR 部にアクセスするとき、generator を評価して次の要素を求めます。そして、コンスセルの CDR 部を破壊的に書き換えて、新しい要素とジェネレータを追加します。
(item1 . generator) == lcdr => (item1 item2 . generator)
このとき、ジェネレータは generator をそのまま使うことに注意してください。今までの方法では CDR 部にアクセスするとき新しい遅延ストリームを生成するので、新たなクロージャを消費することになります。遅延シーケンスはクロージャを消費しないので、メモリの消費量は遅延ストリームよりも少なくなると思われます。これが遅延シーケンスの長所です。
ただし、lcons (stream-cons) のような関数 (マクロ) は、遅延シーケンスには向いていません。Gauche には lcons に相当する関数も用意されていますが、クロージャを消費することになるので、遅延シーケンスの良さを生かすことは難しいと思われます。ちなみに、SRFI-127 には lcons に相当する関数はありません。
それではプログラムを作りましょう。最初に遅延シーケンスを生成する関数を作ります。SRFI-127 では generator->lseq という関数が用意されていますが、本稿では名前を make-lseq としました。
リスト : 遅延シーケンスの生成
(defun make-lseq (g)
(multiple-value-bind
(v e)
(funcall g)
(if (not e)
nil
(cons v g))))
引数 G にジェネレータを渡します。SRFI-127 では、ジェネレータの終了を表すために eof-object を使っていますが、本稿では多値を使うことにします。ジェネレータは values で生成した値と T を返します。ジェネレータが終了したときは NIL と NIL を返すことにします。これで遅延シーケンスの要素が NIL のときにも対応することができます。
make-lseq は簡単です。ジェネレータ G を呼び出して返り値 (多値) を変数 V と E に受け取りします。E が NIL ならば空の遅延シーケンスなので NIL を返します。そうでなければ、V と G をコンスセルに格納して返します。
次は遅延シーケンスの基本的な操作関数 lcar と lcdr を作ります。
リスト : アクセス関数
(defun lcar (s) (car s))
(defun lcdr (s)
(when (functionp (cdr s))
(multiple-value-bind
(v e)
(funcall (cdr s))
(setf (cdr s)
(if (not e) nil (cons v (cdr s))))))
(cdr s))
lcar は簡単ですね。先頭要素 (car s) を返すだけです。lcdr は最初に引数 S が遅延シーケンスかチェックします。そうであれば、ジェネレータ (cdr s) を評価して、返り値を引数 V と E に受け取ります。E が NIL ならば S の CDR 部を NIL に書き換えます。そうでなければ、(cons v (cdr s)) に書き換えます。最後に (cdr s) を返します。これで新しい要素が生成され、遅延シーケンスの長さが 1 つ増えることになります。
あとは遅延ストリーム lazy.lisp に合わせて遅延シーケンスの操作関数を定義していくだけです。詳細は プログラムリスト２ をお読みくださいませ。
それでは簡単な例題として、フィボナッチ数を生成するプログラムを作ってみましょう
リスト : フィボナッチ数列の生成
(defun fibonacci (&optional (a 0) (b 1))
(make-lseq
(lambda ()
(multiple-value-prog1
(values a t)
(psetq a b b (+ a b))))))
関数 fibonacci はフィボナッチ数列を生成する遅延シーケンスを作ります。引数 A が初項、B が次項になります。make-lseq に渡すジェネレータ (ラムダ式) は values で A と T を返したあと、psetq で A と B の値を更新します。多値を返すので、prog1 ではなく multiple-value-prog1 を使うことに注意してください。
それでは実行してみましょう。
* (defvar *fibo* (fibonacci))
*FIBO*
* (take *fibo* 20)
(0 1 1 2 3 5 8 13 21 34 55 89 144 233 377 610 987 1597 2584 4181)
* (lnth 40 *fibo*)
102334155
* *fibo*
(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 102334155
. #<CLOSURE (LAMBDA () :IN FIBONACCI) {100410D86B}>)
もう一つ簡単な例題として、素数列を生成するプログラムを作ってみましょう。
リスト : 素数列の生成
;;; 素数列
(defvar *primes*)
;;; 素数のチェック
(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))))))
;;; n 以上の素数を生成する
(defun prime-generator (n)
(lambda ()
(loop
(incf n 2)
(if (primep n) (return (values n t))))))
(setq *primes* (list* 2 3 5 7 (prime-generator 7)))
関数 prime-generator は引数 N より大きい素数を生成するジェネレータです。述語 primp で N が素数かチェックして、そうであれば values で N と T を返します。primep は簡単ですね。あとは list* で素数列 *PRIMES* を初期化します。このとき、末尾セルの CDR 部にジェネレータがセットされます。
それでは実行してみましょう。遅延シーケンス (lseq.lisp) と遅延ストリーム (lazy.lisp) で実行時間を比べてみました。最初に遅延シーケンスの結果を示します。
* (time (lnth 100000 *primes*)) Evaluation took: 0.896 seconds of real time 0.890625 seconds of total run time (0.890625 user, 0.000000 system) 99.44% CPU 2,148,796,256 processor cycles 1,605,632 bytes consed 1299721
遅延ストリームの結果は次のようになりました。
* (time (lnth 100000 *primes*)) Evaluation took: 1.151 seconds of real time 1.140625 seconds of total run time (1.140625 user, 0.000000 system) 99.13% CPU 2,761,438,486 processor cycles 4,782,960 bytes consed 1299721
遅延シーケンスのほうが少し速くなりました。コンスセルの消費も遅延シーケンスの方が少なくなるようです。なお、lcons を使っていなければ、lazy.lisp のサンプルプログラムもそのまま動作します。興味のある方は実際に試してみてください。
;;;
;;; lseq.lisp : 遅延シーケンス (Gauche の lseq, SRFI-127 のマネ)
;;;
;;; Copyright (C) 2020 Makoto Hiroi
;;;
(provide :lseq)
(defpackage :lseq (:use :cl))
(in-package :lseq)
(export '(promise delay force nils make-lseq lcar lcdr lunfold ltabulate liota
llist fromlist tolist lnth ltake take drop lappend lappend-delay
llength lzip lmap flatlmap lfilter lfold-left lfold-right lscan-left
lforeach ltake-while take-while drop-while lsome levery lunion
lintersect ldifferent))
;;;
;;; 遅延評価
;;;
;;; プロミスの定義
(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 lpop (place)
`(prog1
(lcar ,place)
(setq ,place (lcdr ,place))))
;;; 遅延シーケンスの生成
(defun make-lseq (g)
(multiple-value-bind
(v e)
(funcall g)
(if (not e)
nil
(cons v g))))
;;; アクセス関数
(defun lcar (s) (car s))
(defun lcdr (s)
(when (functionp (cdr s))
(multiple-value-bind
(v e)
(funcall (cdr s))
(setf (cdr s)
(if (not e) nil (cons v (cdr s))))))
(cdr s))
;;; 逆畳み込み
(defun lunfold (p f g seed)
(make-lseq
(lambda ()
(if (funcall p seed)
(values nil nil)
(multiple-value-prog1
(values (funcall f seed) t)
(setq seed (funcall g seed)))))))
;;; 数列の生成
(defun ltabulate (c f &optional (seed 0) (step 1))
(make-lseq
(lambda ()
(if (and c (zerop c))
(values nil nil)
(multiple-value-prog1
(values (funcall f seed) t)
(when c (decf c))
(incf seed step))))))
(defun liota (c &optional (seed 0) (step 1))
(ltabulate c #'identity seed step))
;;; 引数を格納した遅延シーケンスを生成
(defun llist (&rest args)
(make-lseq
(lambda ()
(if (null args)
(values nil nil)
(values (pop args) t)))))
;;; リストを遅延シーケンスに変換
(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)
(make-lseq
(lambda ()
(cond
((or (null s) (zerop n)) (values nil nil))
(t
(decf n)
(values (lpop s) t))))))
;;; リストを返す
(defun take (s n)
(loop until (or (null s) (zerop n)) collect (lcar s)
do (setq s (lcdr s))
(decf n)))
;;; 述語 pred が真を返す要素を取り出す
;;; 新しいストリームを返す
(defun ltake-while (pred s)
(make-lseq
(lambda ()
(if (or (null s)
(not (funcall pred (lcar s))))
(values nil nil)
(values (lpop s) t)))))
;;; リストを返す
(defun take-while (pred s)
(loop until (or (null s)
(not (funcall pred (lcar s))))
collect (lcar s)
do (setq s (lcdr s))))
;;; 先頭から n 個の要素を取り除く
(defun drop (s n)
(if (or (null s) (zerop n))
s
(drop (lcdr s) (1- n))))
;;; 述語 pred が真を返す要素を取り除く
(defun drop-while (pred s)
(if (or (null s)
(not (funcall pred (lcar s))))
s
(drop-while pred (lcdr s))))
;;; ストリームの結合
(defun lappend (s1 s2)
(make-lseq
(lambda ()
(if (null s1)
(if (null s2)
(values nil nil)
(values (lpop s2) t))
(values (lpop s1) t)))))
;;; 遅延評価版
(defun lappend-delay (s1 s2)
(make-lseq
(lambda ()
(if (null s1)
(progn
(when (promise-p s2)
(setq s2 (force s2)))
(if (null s2)
(values nil nil)
(values (lpop s2) t)))
(values (lpop s1) t)))))
;;; 長さ
(defun llength (s &optional (c 0))
(if (null s)
c
(llength (lcdr s) (1+ c))))
;;;
(defun lzip (&rest ss)
(make-lseq
(lambda ()
(if (member nil ss)
(values nil nil)
(multiple-value-prog1
(values (mapcar #'lcar ss) t)
(setq ss (mapcar #'lcdr ss)))))))
;;;
;;; 高階関数
;;;
;;; マップ関数
(defun lmap (proc &rest ss)
(make-lseq
(lambda ()
(if (member nil ss)
(values nil nil)
(multiple-value-prog1
(values (apply proc (mapcar #'lcar ss)) t)
(setq ss (mapcar #'lcdr ss)))))))
;;; マッピングの結果を平坦化する
(defun flatlmap (proc s)
(if (null s)
nil
(lappend-delay (funcall proc (lcar s))
(delay (flatlmap proc (lcdr s))))))
;;; フィルター
(defun lfilter (pred s)
(make-lseq
(lambda ()
(loop
(cond
((null s) (return (values nil nil)))
((funcall pred (lcar s))
(return (values (lpop s) t)))
(t (lpop 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)
(make-lseq
(lambda ()
(if (null s)
(multiple-value-prog1
(values a (if a t nil))
(setq a nil))
(multiple-value-prog1
(values a t)
(setq a (funcall proc a (lcar s))
s (lcdr s)))))))
;;; 巡回
(defun lforeach (proc s)
(unless (null s)
(funcall proc (lcar s))
(lforeach proc (lcdr s))))
;;;
(defun lsome (pred &rest ss)
(cond
((member nil ss) nil)
((apply pred (mapcar #'lcar ss)) t)
(t (apply #'lsome pred (mapcar #'lcdr ss)))))
;;;
(defun levery (pred &rest ss)
(cond
((member nil ss) t)
((not (apply pred (mapcar #'lcar ss))) nil)
(t (apply #'levery pred (mapcar #'lcdr ss)))))
;;;
;;; 集合演算
;;;
;;; 和集合
(defun lunion (s1 s2)
(make-lseq
(lambda ()
(cond
((and (null s1) (null s2)) (values nil nil))
((null s1) (values (lpop s2) t))
((null s2) (values (lpop s1) t))
((= (lcar s1) (lcar s2))
(lpop s1)
(values (lpop s2) t))
((< (lcar s1) (lcar s2))
(values (lpop s1) t))
(t
(values (lpop s2) t))))))
;;; 積集合
(defun lintersect (s1 s2)
(make-lseq
(lambda ()
(loop
(cond
((or (null s1) (null s2))
(return (values nil nil)))
((= (lcar s1) (lcar s2))
(lpop s2)
(return (values (lpop s1) t)))
((< (lcar s1) (lcar s2))
(lpop s1))
(t (lpop s2)))))))
;;; 差集合
(defun ldifferent (s1 s2)
(make-lseq
(lambda ()
(loop
(cond
((null s1) (return (values nil nil)))
((null s2) (return (values (lpop s1) t)))
((= (lcar s1) (lcar s2))
(lpop s1)
(lpop s2))
((< (lcar s1) (lcar s2))
(return (values (lpop s1) t)))
(t (lpop s2)))))))