拙作のページ Common Lisp 入門: 遅延ストリーム のプログラムを Hy に移植したものです。関数名は stream- ではなく l を付けるように変更しています。学習が目的のプログラムなので実用性はありませんが、興味のある方はいろいろ試してみてください。遅延ストリームの詳しい説明は、以下の拙作のページをお読みください。
delay と force は拙作のページ 遅延評価 で作成したものと同じです。
=> (import lazy *) => (require lazy *) => (setv a (delay (do (print "oops") (+ 1 2)))) => a <lazy.Promise object at 0x7f496dcec250> => (.force a) oops 3 => (.force a) 3
=> (import lazy *) => (require lazy *) => (setv a (lcons 1 (lcons 2 (lcons 3 None)))) => (lcar a) 1 => (lcar (lcdr a)) 2 => (lcar (lcdr (lcdr a))) 3 => (lcdr (lcdr (lcdr a))) => => (print (lcdr (lcdr (lcdr a)))) None
=> (setv a (llist 1 2 3 4 5)) => (list (lgen a)) [1 2 3 4 5] => (setv a (fromlist [1 2 3 4 5])) => (list (lgen a)) [1 2 3 4 5] => (setv a (liota 1 10)) => (list (lgen a)) [1 2 3 4 5 6 7 8 9 10] => (setv a (ltabulate (fn [x] (* x x)) 1 10)) => (list (lgen a)) [1 4 9 16 25 36 49 64 81 100] => (setv a (lunfold (fn [x] (> x 10)) (fn [x] x) (fn [x] (+ x 1)) 1)) => (list (lgen a)) [1 2 3 4 5 6 7 8 9 10] => (setv a (lunfold (fn [xs] (> (get xs 0) 3000000)) (fn [xs] (get xs 0)) (fn [xs] #((get xs 1) (+ (get xs 0) (get xs 1)))) #(0 1))) => (list (lgen 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]
=> (setv a (liota 1 None)) => (for [x (range 10)] (print (lnth x a))) 1 2 3 4 5 6 7 8 9 10 => (llength (llist 1 2 3 4 5)) 5 => (setv b (lappend (llist 1 2 3 4) (llist 5 6 7 8))) => (list (lgen b)) [1 2 3 4 5 6 7 8] => (setv b (lzip (llist 1 2 3 4) (llist 5 6 7 8))) => (list (lgen b)) [[1 5] [2 6] [3 7] [4 8]] => (setv a (liota 1 None)) => (list (lgen (ltake a 10))) [1 2 3 4 5 6 7 8 9 10] => (list (lgen (ltake (ldrop a 20) 10))) [21 22 23 24 25 26 27 28 29 30]
=> (setv a (liota 1 None)) => (setv b (lmap (fn [x] (* x x)) a)) => (list (lgen (ltake b 10))) [1 4 9 16 25 36 49 64 81 100] => (setv c (flatlmap (fn [x] (llist x x)) a)) => (list (lgen (ltake c 10))) [1 1 2 2 3 3 4 4 5 5] => (list (lgen (ltake c 20))) [1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8 9 9 10 10] => (setv d (lfilter (fn [x] (= (% x 2) 0)) a)) => (list (lgen (ltake d 10))) [2 4 6 8 10 12 14 16 18 20] => (list (lgen (ltake d 20))) [2 4 6 8 10 12 14 16 18 20 22 24 26 28 30 32 34 36 38 40] => (lfold-left (fn [a b] (+ a b)) 0 (llist 1 2 3 4 5)) 15 => (lfold-right (fn [a b] (+ a b)) 0 (llist 1 2 3 4 5)) 15 => (setv a (liota 1 None)) => (list (lgen (ltake a 20))) [1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20] => (setv e (lscan-left (fn [a b] (* a b)) 1 a)) => (list (lgen (ltake e 20))) [1 1 2 6 24 120 720 5040 40320 362880 3628800 39916800 479001600 6227020800 87178291200 1307674368000 20922789888000 355687428096000 6402373705728000 121645100408832000] => (setv a (liota 2 None)) => (list (lgen (ltake a 20))) [2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21] => (setv b (lscan-left (fn [a b] (+ a b)) 1 a)) => (list (lgen (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 => (setv a (liota 0 None)) => (list (lgen (ltake-while (fn [x] (< x 10)) a))) [0 1 2 3 4 5 6 7 8 9] => (list (lgen (ltake-while (fn [x] (< x 20)) (ldrop-while (fn [x] (< x 10)) a)))) [10 11 12 13 14 15 16 17 18 19] => (levery (fn [x] (= (% x 2) 0)) (llist 2 4 6 8 10)) True => (levery (fn [x] (= (% x 2) 0)) (llist 2 4 5 8 10)) False => (lsome (fn [x] (= (% x 2) 1)) (llist 2 4 6 8 10)) False => (lsome (fn [x] (= (% x 2) 1)) (llist 2 4 5 8 10)) True
=> (list (lgen (lunion (llist 1 2 3 4) (llist 3 4 5 6)))) [1 2 3 4 5 6] => (list (lgen (lintersect (llist 1 2 3 4) (llist 3 4 5 6)))) [3 4] => (list (lgen (ldifferent (llist 1 2 3 4) (llist 3 4 5 6)))) [1 2] => (list (lgen (ldifferent (llist 3 4 5 6) (llist 1 2 3 4)))) [5 6] => (list (lgen (ldifferent (llist 3 4 5 6) (llist 3 4 5 6)))) []
;;;
;;; sample4.hy : 遅延ストリームのサンプル
;;;
;;; Copyright (C) 2024-2025 Makoto Hiroi
;;;
(import lazy *)
(require lazy *)
(import operator [add])
;;; リストに変換
(defn tolist [s] (list (lgen s)))
;;; 偶数の判定
(defn evenp [n] (= (% n 2) 0))
;;; フィボナッチ数列
(setv *fibo* (lcons 0 (lcons 1 (lmap add (lcdr *fibo*) *fibo*))))
;;; n 未満で最大のフィボナッチ数
(defn fibo-max [n]
(get (list (lgen (ltake-while (fn [x] (< x n)) *fibo*))) -1))
;;; n 未満のフィボナッチ数の総和
(defn fibo-sum [n]
(lfold-left add 0 (ltake-while (fn [x] (< x n)) *fibo*)))
;;; n 未満の偶数のフィボナッチ数の総和
(defn fibo-sum-even [n]
(lfold-left add 0 (lfilter evenp (ltake-while (fn [x] (< x n)) *fibo*))))
;;; トリボナッチ数
(setv *tri* (lcons 0 (lcons 0 (lcons 1 (lmap (fn [a b c] (+ a b c)) (lcdr (lcdr *tri*)) (lcdr *tri*) *tri*)))))
;;; リュカ数
(setv *lucas* (lcons 2 (lcons 1 (lmap add (lcdr *lucas*) *lucas*))))
;;; 三角数
(setv *triangular* (lscan-left add 1 (liota 2 None)))
;;; 四角数
(setv *square* (lmap (fn [x] (* x x)) (liota 1 None)))
;;; 五角数
(setv *pentagonal* (lscan-left add 1 (lunfold (fn [x] False) (fn [x] x) (fn [x] (+ x 3)) 4)))
;;; 三角錐数
(setv *triangular-pyramidal* (lcdr (lscan-left add 0 *triangular*)))
;;; 四角錐数
(setv *square-pyramidal* (lcdr (lscan-left add 0 *square*)))
;;; 五角錐数
(setv *pentagonal-pyramidal* (lcdr (lscan-left add 0 *pentagonal*)))
;;; 平方三角数
(setv *square-triangular* (lintersect *square* *triangular*))
;;; 三角数で五角数
(setv *triangular-pentagonal* (lintersect *triangular* *pentagonal*))
;;; 素数の生成
(setv *primes* (lcons 2 (lcons 3 (lcons 5 (primes-from 7)))))
(defn primep [n ps]
(let [p (lcar ps)]
(cond
(> (* p p) n) True
(= (% n p) 0) False
True (primep n (lcdr ps)))))
(defn primes-from [n]
(if (primep n (lcdr *primes*))
(lcons n (primes-from (+ n 2)))
(primes-from (+ n 2))))
;;; 双子素数
(setv *twin-primes*
(lfilter (fn [xs] (= (- (get xs 0) (get xs 1)) -2)) (lzip *primes* (lcdr *primes*))))
;;; フィボナッチ素数 (遅い)
(setv *fibo-primes* (lintersect *fibo* *primes*))
;;; ハミングの問題
(setv *hs*
(lcons 1 (lunion (lmap (fn [x] (* x 2)) *hs*)
(lunion (lmap (fn [x] (* x 3)) *hs*)
(lmap (fn [x] (* x 5)) *hs*)))))
=> (import sample4 *) => (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 => (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] => (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] => (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] => (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]
;;;
;;; lazy.hy : 遅延評価と遅延ストリーム
;;;
;;; Copyright (C) 2024-2025 Makoto Hiroi
;;;
;;; プロミスの定義
(defclass Promise []
(defn __init__ [self expr]
(setv self.thunk expr self.result None))
;; プロミスの評価
(defn force [self]
(when self.thunk
(setv self.result (self.thunk)
self.thunk None))
self.result))
;;; プロミスの生成
(defmacro delay [expr] `(Promise (fn [] ~expr)))
;;; たらいまわし関数
(defn tarai [x y z]
(if (<= x y)
y
(tarai (tarai (- x 1) y z)
(tarai (- y 1) z x)
(tarai (- z 1) x y))))
;;; 遅延評価による高速化
(defn tarai-l [x y z]
(if (<= x y)
y
(tarai-l (tarai-l (- x 1) y z)
(tarai-l (- y 1) (.force z) (delay x))
(delay (tarai-l (- (.force z) 1) x (delay y))))))
;;;
;;; 遅延ストリーム
;;;
(defclass Cons []
(defn __init__ [self a d]
(setv self.car a self.cdr d)))
;;; 基本操作
(defmacro lcons [a b] `(Cons ~a (delay ~b)))
(defn lcar [s] s.car)
(defn lcdr [s] (.force s.cdr))
;;; 数列の生成
(defn ltabulate [f n m]
(if (and (is-not m None) (< m n))
None
(lcons (f n) (ltabulate f (+ n 1) m))))
(defn liota [n m] (ltabulate (fn [x] x) n m))
(defn lunfold [p f g seed]
(if (p seed)
None
(lcons (f seed) (lunfold p f g (g seed)))))
;;; リストを遅延ストリームに変換
(defn fromlist [xs [i 0]]
(if (= (len xs) i)
None
(lcons (get xs i) (fromlist xs (+ i 1)))))
;;; 引数を遅延ストリームに変換
(defn llist [#* args] (fromlist args))
;;; 遅延ストリームをジェネレータに変換
(defn lgen [s]
(while s
(yield (lcar s))
(setv s (lcdr s))))
;;; n 番目の要素を求める
(defn lnth [n s]
(for [_ (range n)] (setv s (lcdr s)))
(lcar s))
;;; 先頭からn 個の要素を取り出す
(defn ltake [s n]
(if (or (not s) (= n 0))
None
(lcons (lcar s) (ltake (lcdr s) (- n 1)))))
;;; 先頭からn 個の要素を取り除く
(defn ldrop [s n]
(while (and s (> n 0))
(setv s (lcdr s) n (- n 1)))
s)
;;; ストリームの結合
(defn lappend [s1 s2]
(if (not s1)
s2
(lcons (lcar s1) (lappend (lcdr s1) s2))))
;;; 遅延評価版 (s2 は遅延評価)
(defn lappend-delay [s1 s2]
(if (not s1)
(.force s2)
(lcons (lcar s1) (lappend-delay (lcdr s1) s2))))
;;; 遅延ストリームの要素をまとめる
(defn lzip [#* args]
(if (in None args)
None
(lcons (list (map lcar args)) (lzip #* (map lcdr args)))))
;;; 長さ
(defn llength [s [n 0]]
(while s
(setv s (lcdr s) n (+ n 1)))
n)
;;;
;;; 高階関数
;;;
;;; マッピング
(defn lmap [proc #* args]
(if (in None args)
None
(lcons (proc #* (map lcar args))
(lmap proc #* (map lcdr args)))))
;;; マッピングの結果を平坦化する
(defn flatlmap [proc s]
(if (is None s)
None
(lappend-delay (proc (lcar s))
(delay (flatlmap proc (lcdr s))))))
;;; フィルター
(defn lfilter [pred s]
(cond
(is None s) None
(pred (lcar s)) (lcons (lcar s) (lfilter pred (lcdr s)))
True (lfilter pred (lcdr s))))
;;; 畳み込み
(defn lfold-left [proc a s]
(if (is None s)
a
(lfold-left proc (proc a (lcar s)) (lcdr s))))
(defn lfold-right [proc a s]
(if (is None s)
a
(proc (lcar s) (lfold-right proc a (lcdr s)))))
(defn lscan-left [proc a s]
(lcons a (if (is None s)
None
(lscan-left proc (proc a (lcar s)) (lcdr s)))))
;;; 巡回
(defn lforeach [proc s]
(for [x (lgen s)] (proc x)))
;;; 述語 pred が真を返す要素を取り出す
(defn ltake-while [pred s]
(if (or (is None s)
(not (pred (lcar s))))
None
(lcons (lcar s)
(ltake-while pred (lcdr s)))))
;;; 述語 pred が真を返す要素を取り除く
(defn ldrop-while [pred s]
(while (and s (pred (lcar s)))
(setv s (lcdr s)))
s)
;;; pred が真を返す要素があれば T を返す
(defn lsome [pred #* args]
(cond
(in None args) False
(pred #* (list (map lcar args))) True
True (lsome pred #* (map lcdr args))))
;;; pred が NIL を返す要素があれば NIL を返す
(defn levery [pred #* args]
(cond
(in None args) True
(not (pred #* (list (map lcar args)))) False
True (levery pred #* (map lcdr args))))
;;;
;;; 集合演算
;;;
;;; 和集合
(defn lunion [s1 s2]
(cond
(is None s1) s2
(is None 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))
True (lcons (lcar s2) (lunion s1 (lcdr s2)))))
;;; 積集合
(defn lintersect [s1 s2]
(while (and s1 s2)
(cond
(= (lcar s1) (lcar s2)) (return (lcons (lcar s1) (lintersect (lcdr s1) (lcdr s2))))
(< (lcar s1) (lcar s2)) (setv s1 (lcdr s1))
True (setv s2 (lcdr s2))))
(return None))
;;; 差集合
(defn ldifferent [s1 s2]
(cond
(is None s1) None
(is None s2) s1
(= (lcar s1) (lcar s2)) (ldifferent (lcdr s1) (lcdr s2))
(< (lcar s1) (lcar s2)) (lcons (lcar s1) (ldifferent (lcdr s1) s2))
True (ldifferent s1 (lcdr s2))))