diff options
author | Masaya Tojo <masaya@tojo.tokyo> | 2024-06-16 12:15:11 +0900 |
---|---|---|
committer | Masaya Tojo <masaya@tojo.tokyo> | 2024-06-16 12:15:11 +0900 |
commit | e51a5f32bb8f23eb0fd27213cb36ce09a42a6386 (patch) | |
tree | 3c4d043a91d56fff6e7d59e3ed829dbeee0dbe26 | |
parent | a0ed10aa2a780894c8f63bd4bde218d56eba411e (diff) |
Add stream implementations
-rw-r--r-- | algebraic-structures.egg | 20 | ||||
-rw-r--r-- | algebraic-structures.private.stream.alternative.scm | 10 | ||||
-rw-r--r-- | algebraic-structures.private.stream.applicative.scm | 17 | ||||
-rw-r--r-- | algebraic-structures.private.stream.monad.scm | 14 | ||||
-rw-r--r-- | algebraic-structures.private.stream.scm | 20 | ||||
-rw-r--r-- | algebraic-structures.private.stream.zip.applicative.scm | 11 | ||||
-rw-r--r-- | algebraic-structures.stream.alternative.scm | 4 | ||||
-rw-r--r-- | algebraic-structures.stream.applicative.scm | 4 | ||||
-rw-r--r-- | algebraic-structures.stream.foldable.scm | 3 | ||||
-rw-r--r-- | algebraic-structures.stream.functor.scm | 3 | ||||
-rw-r--r-- | algebraic-structures.stream.monad.scm | 4 | ||||
-rw-r--r-- | algebraic-structures.stream.monoid.scm | 3 | ||||
-rw-r--r-- | algebraic-structures.stream.reducible.scm | 3 | ||||
-rw-r--r-- | algebraic-structures.stream.semigroup.scm | 3 | ||||
-rw-r--r-- | algebraic-structures.stream.zip.applicative.scm | 4 | ||||
-rw-r--r-- | tests/run.scm | 140 |
16 files changed, 260 insertions, 3 deletions
diff --git a/algebraic-structures.egg b/algebraic-structures.egg index 5e7eba3..43a8c2d 100644 --- a/algebraic-structures.egg +++ b/algebraic-structures.egg @@ -5,7 +5,7 @@ (license "BSD") (category data) (version "0.1.0") - (dependencies matchable) + (dependencies matchable srfi-41) (test-dependencies test) (components (extension algebraic-structures.semigroup) @@ -34,4 +34,20 @@ (extension algebraic-structures.private.list.monad) (extension algebraic-structures.list.monad) (extension algebraic-structures.private.list.alternative) - (extension algebraic-structures.list.alternative))) + (extension algebraic-structures.list.alternative) + + ;; Stream + (extension algebraic-structures.private.stream) + (extension algebraic-structures.stream.semigroup) + (extension algebraic-structures.stream.monoid) + (extension algebraic-structures.stream.foldable) + (extension algebraic-structures.stream.reducible) + (extension algebraic-structures.stream.functor) + (extension algebraic-structures.private.stream.zip.applicative) + (extension algebraic-structures.stream.zip.applicative) + (extension algebraic-structures.private.stream.applicative) + (extension algebraic-structures.stream.applicative) + (extension algebraic-structures.private.stream.monad) + (extension algebraic-structures.stream.monad) + (extension algebraic-structures.private.stream.alternative) + (extension algebraic-structures.stream.alternative))) diff --git a/algebraic-structures.private.stream.alternative.scm b/algebraic-structures.private.stream.alternative.scm new file mode 100644 index 0000000..0d90baa --- /dev/null +++ b/algebraic-structures.private.stream.alternative.scm @@ -0,0 +1,10 @@ +(module (algebraic-structures private stream alternative) (alt empty) + (import (except scheme map apply) + (srfi 41) + (chicken module)) + (reexport (algebraic-structures stream applicative)) + + (define empty stream-null) + + (define (alt xs ys) + (stream-append xs ys))) diff --git a/algebraic-structures.private.stream.applicative.scm b/algebraic-structures.private.stream.applicative.scm new file mode 100644 index 0000000..0389ad9 --- /dev/null +++ b/algebraic-structures.private.stream.applicative.scm @@ -0,0 +1,17 @@ +(module (algebraic-structures private stream applicative) () + (import scheme + (srfi 41) + (only (chicken base) cute) + (chicken module)) + (export pure map2) + (reexport (algebraic-structures stream functor)) + + (define (pure x) (stream x)) + + (define-stream (product op s1 s2) + (if (stream-null? s1) + stream-null + (stream-append (stream-map (cute op (stream-car s1) <>) s2) + (product op (stream-cdr s1) s2)))) + + (define map2 product)) diff --git a/algebraic-structures.private.stream.monad.scm b/algebraic-structures.private.stream.monad.scm new file mode 100644 index 0000000..e22a396 --- /dev/null +++ b/algebraic-structures.private.stream.monad.scm @@ -0,0 +1,14 @@ +(module (algebraic-structures private stream monad) (>>=) + (import (except scheme map apply) + (chicken module) + (srfi 41)) + (reexport (algebraic-structures stream applicative)) + + (define-stream (stream-append-map f strm) + (if (stream-null? strm) + stream-null + (stream-append (f (stream-car strm)) + (stream-append-map f (stream-cdr strm))))) + + (define (>>= xs f) + (stream-append-map f xs))) diff --git a/algebraic-structures.private.stream.scm b/algebraic-structures.private.stream.scm new file mode 100644 index 0000000..a268841 --- /dev/null +++ b/algebraic-structures.private.stream.scm @@ -0,0 +1,20 @@ +(module (algebraic-structures private stream) (<> unit fold reduce map1) + (import scheme + (srfi 41) + (streams utils) + (only (chicken base) assert)) + + (define (<> xs ys) (stream-append xs ys)) + + (define unit stream-null) + + (define (fold f init xs) + (stream-fold (lambda (x acc) (f acc x)) + init + xs)) + + (define (reduce f xs) + (stream-fold-one f xs)) + + (define (map1 f xs) + (stream-map f xs))) diff --git a/algebraic-structures.private.stream.zip.applicative.scm b/algebraic-structures.private.stream.zip.applicative.scm new file mode 100644 index 0000000..8d56006 --- /dev/null +++ b/algebraic-structures.private.stream.zip.applicative.scm @@ -0,0 +1,11 @@ +(module (algebraic-structures private stream zip applicative) () + (import scheme + (srfi 41) + (chicken module)) + (export pure map2) + (reexport (algebraic-structures stream functor)) + + (define (pure x) (stream x)) + + (define (map2 f xs ys) + (stream-map f xs ys))) diff --git a/algebraic-structures.stream.alternative.scm b/algebraic-structures.stream.alternative.scm new file mode 100644 index 0000000..b117d52 --- /dev/null +++ b/algebraic-structures.stream.alternative.scm @@ -0,0 +1,4 @@ +(import (algebraic-structures alternative) + (only (algebraic-structures private stream alternative))) +(module (algebraic-structures stream alternative) = ((algebraic-structures alternative) + (algebraic-structures private stream alternative))) diff --git a/algebraic-structures.stream.applicative.scm b/algebraic-structures.stream.applicative.scm new file mode 100644 index 0000000..5ff5f0c --- /dev/null +++ b/algebraic-structures.stream.applicative.scm @@ -0,0 +1,4 @@ +(import (algebraic-structures applicative) + (only (algebraic-structures private stream applicative))) +(module (algebraic-structures stream applicative) = ((algebraic-structures applicative) + (algebraic-structures private stream applicative))) diff --git a/algebraic-structures.stream.foldable.scm b/algebraic-structures.stream.foldable.scm new file mode 100644 index 0000000..8313aa7 --- /dev/null +++ b/algebraic-structures.stream.foldable.scm @@ -0,0 +1,3 @@ +(import (algebraic-structures foldable) + (only (algebraic-structures private stream))) +(module (algebraic-structures stream foldable) = ((algebraic-structures foldable) (algebraic-structures private stream))) diff --git a/algebraic-structures.stream.functor.scm b/algebraic-structures.stream.functor.scm new file mode 100644 index 0000000..fb4d354 --- /dev/null +++ b/algebraic-structures.stream.functor.scm @@ -0,0 +1,3 @@ +(import (algebraic-structures functor) + (only (algebraic-structures private stream))) +(module (algebraic-structures stream functor) = ((algebraic-structures functor) (algebraic-structures private stream))) diff --git a/algebraic-structures.stream.monad.scm b/algebraic-structures.stream.monad.scm new file mode 100644 index 0000000..f7511d7 --- /dev/null +++ b/algebraic-structures.stream.monad.scm @@ -0,0 +1,4 @@ +(import (algebraic-structures monad) + (only (algebraic-structures private stream monad))) +(module (algebraic-structures stream monad) = ((algebraic-structures monad) + (algebraic-structures private stream monad))) diff --git a/algebraic-structures.stream.monoid.scm b/algebraic-structures.stream.monoid.scm new file mode 100644 index 0000000..d994a30 --- /dev/null +++ b/algebraic-structures.stream.monoid.scm @@ -0,0 +1,3 @@ +(import (algebraic-structures monoid) + (only (algebraic-structures private stream))) +(module (algebraic-structures stream monoid) = ((algebraic-structures monoid) (algebraic-structures private stream))) diff --git a/algebraic-structures.stream.reducible.scm b/algebraic-structures.stream.reducible.scm new file mode 100644 index 0000000..9d76890 --- /dev/null +++ b/algebraic-structures.stream.reducible.scm @@ -0,0 +1,3 @@ +(import (algebraic-structures reducible) + (only (algebraic-structures private stream))) +(module (algebraic-structures stream reducible) = ((algebraic-structures reducible) (algebraic-structures private stream))) diff --git a/algebraic-structures.stream.semigroup.scm b/algebraic-structures.stream.semigroup.scm new file mode 100644 index 0000000..6fbafe2 --- /dev/null +++ b/algebraic-structures.stream.semigroup.scm @@ -0,0 +1,3 @@ +(import (algebraic-structures semigroup) + (only (algebraic-structures private stream))) +(module (algebraic-structures stream semigroup) = ((algebraic-structures semigroup) (algebraic-structures private stream))) diff --git a/algebraic-structures.stream.zip.applicative.scm b/algebraic-structures.stream.zip.applicative.scm new file mode 100644 index 0000000..8d06b97 --- /dev/null +++ b/algebraic-structures.stream.zip.applicative.scm @@ -0,0 +1,4 @@ +(import (algebraic-structures applicative) + (only (algebraic-structures private stream zip applicative))) +(module (algebraic-structures stream zip applicative) = ((algebraic-structures applicative) + (algebraic-structures private stream zip applicative))) diff --git a/tests/run.scm b/tests/run.scm index eac7569..4005ef7 100644 --- a/tests/run.scm +++ b/tests/run.scm @@ -1,4 +1,6 @@ -(import (chicken load) (test)) +(import (chicken load) + (test) + (srfi 41)) (test-begin "algebraic-structures") @@ -23,6 +25,20 @@ (test 5 (mod7:<> 3 4)) +(test-begin "list") + +(import (prefix (algebraic-structures list semigroup) list:)) +(test '(a b c) (list:<> '(a b) '(c))) + +(test-end "list") + +(test-begin "stream") + +(import (prefix (algebraic-structures stream semigroup) stream:)) +(test '(a b c) (stream->list (stream:<> (stream 'a 'b) (stream 'c)))) + +(test-end "stream") + (test-end "semigroup") (test-begin "monoid") @@ -43,6 +59,20 @@ (test 1 mod7:unit) +(test-begin "list") + +(import (prefix (algebraic-structures list monoid) list:)) +(test '() (begin list:unit)) + +(test-end "list") + +(test-begin "stream") + +(import (prefix (algebraic-structures stream monoid) stream:)) +(test '() (stream->list stream:unit)) + +(test-end "stream") + (test-end "monoid") (test-begin "group") @@ -106,6 +136,37 @@ (test #t (list:member? 'c '(a b c) eq?)) (test #f (list:member? 'c '(a b) eq?)) +(test-begin "stream") + +(import (prefix (algebraic-structures stream foldable) stream:)) + +(test '(e d c b a) (stream:fold cons '() (stream 'a 'b 'c 'd 'e))) + +(test 0 (stream:length stream-null)) +(test 5 (stream:length (stream-take 5 (stream-from 1)))) + +(test 0 (stream:count even? (stream 1 3 5 7))) +(test 2 (stream:count even? (stream 1 3 4 7 8))) + +(test #f (stream:any (constantly #t) stream-null)) +(test #f (stream:any (cut member 'x <>) (stream '(a b c) '(d e f)))) +(test '(x f) (stream:any (cut member 'x <>) (stream '(a b c) '(d x f)))) +(test '(x f) (stream:any (cut member 'x <>) (stream '(a b c) '(d x f)))) +(test #t (stream:any even? (stream-from 1))) + +(test #t (stream:every (constantly #f) stream-null)) +(test #f (stream:every (cut member 'x <>) (stream '(a b c) '(d x f)))) +(test '(x f) (stream:every (cut member 'x <>) (stream '(a x c) '(d x f)))) +(test #f (stream:every even? (stream-from 0))) + +(test #t (stream:member? 3 (stream 1 3 7 5) =)) +(test #f (stream:member? 3 (stream 1 7 5) =)) +(test #t (stream:member? 'c (stream 'a 'b 'c) eq?)) +(test #f (stream:member? 'c (stream 'a 'b) eq?)) +(test #t (stream:member? 1000 (stream-from 1) =)) + +(test-end "stream") + (test-end "foldable") (test-begin "reducible") @@ -116,6 +177,16 @@ (test -3 (list:minimum '(1 8 -3 5 4) <)) (test 8 (list:maximum '(1 8 -3 5 4) <)) +(test-begin "stream") + +(import (prefix (algebraic-structures stream reducible) stream:)) + +(test 10 (stream:reduce + (stream 1 2 3 4))) +(test -3 (stream:minimum (stream 1 8 -3 5 4) <)) +(test 8 (stream:maximum (stream 1 8 -3 5 4) <)) + +(test-end "stream") + (test-end "reducible") (test-begin "semigroup.reducible") @@ -185,6 +256,14 @@ (test '((a) (b) (c)) (list:map1 list '(a b c))) +(test-begin "stream") + +(import (prefix (algebraic-structures stream functor) stream:)) + +(test '((a) (b) (c)) (stream->list (stream:map1 list (stream 'a 'b 'c)))) + +(test-end "stream") + (test-end "functor") (test-begin "applicative") @@ -199,6 +278,25 @@ (test '((a 1 z) (a 2 z) (b 1 z) (b 2 z) (c 1 z) (c 2 z)) (list:map list '(a b c) '(1 2) '(z))) +(test-begin "stream") + +(import (prefix (algebraic-structures stream applicative) stream:)) + +(test '(a) (stream->list (stream:pure 'a))) + +(test '((a 1) (a 2) (b 1) (b 2) (c 1) (c 2)) + (stream->list (stream:map2 list (stream 'a 'b 'c) (stream 1 2)))) + +(test '((a 1 z) (a 2 z) (b 1 z) (b 2 z) (c 1 z) (c 2 z)) + (stream->list + (stream:map list (stream 'a 'b 'c) (stream 1 2) (stream 'z)))) + +(test '((1 a) (1 b) (1 c) (2 a)) + (stream->list + (stream-take 4 (stream:map2 list (stream-from 1) (stream 'a 'b 'c))))) + +(test-end "stream") + (test-begin "list.zip") (import (prefix (algebraic-structures list zip applicative) list-zip:)) @@ -210,6 +308,17 @@ (test-end "list.zip") +(test-begin "stream.zip") + +(import (prefix (algebraic-structures stream zip applicative) stream-zip:)) + +(test '(a) (stream->list (stream:pure 'a))) + +(test '((a 1) (b 2)) + (stream->list (stream-zip:map2 list (stream 'a 'b 'c) (stream 1 2)))) + +(test-end "stream.zip") + (test-end "applicative") (test-begin "monad") @@ -229,6 +338,19 @@ (list 2) (list:pure (* x y z)))) +(test-begin "stream") + +(import (prefix (algebraic-structures stream monad) stream:)) + +(test '((1 a) (2 a)) + (stream->list + (stream:>>= (stream:pure 'a) + (lambda (x) + (stream (list 1 x) + (list 2 x)))))) + +(test-end "stream") + (test-end "monad") (test-begin "alternative") @@ -240,6 +362,22 @@ (list:guard (odd? x)) (list:pure (* x x)))) +(test-begin "stream") + +(import (prefix (algebraic-structures stream alternative) stream:)) + +(test '((3 4 5) (6 8 10) (5 12 13) (9 12 15) (8 15 17)) + (stream->list + (stream-take 5 + (stream:do (b <- (stream-from 1)) + (a <- (stream-range 1 b)) + (let c^2 = (+ (* a a) (* b b))) + (let-values (c r) = (exact-integer-sqrt c^2)) + (stream:guard (= r 0)) + (stream:pure (list a b c)))))) + +(test-end "stream") + (test-end "alternative") (test-end "algebraic-structures") |