aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMasaya Tojo <masaya@tojo.tokyo>2024-06-16 12:15:11 +0900
committerMasaya Tojo <masaya@tojo.tokyo>2024-06-16 12:15:11 +0900
commite51a5f32bb8f23eb0fd27213cb36ce09a42a6386 (patch)
tree3c4d043a91d56fff6e7d59e3ed829dbeee0dbe26
parenta0ed10aa2a780894c8f63bd4bde218d56eba411e (diff)
Add stream implementations
-rw-r--r--algebraic-structures.egg20
-rw-r--r--algebraic-structures.private.stream.alternative.scm10
-rw-r--r--algebraic-structures.private.stream.applicative.scm17
-rw-r--r--algebraic-structures.private.stream.monad.scm14
-rw-r--r--algebraic-structures.private.stream.scm20
-rw-r--r--algebraic-structures.private.stream.zip.applicative.scm11
-rw-r--r--algebraic-structures.stream.alternative.scm4
-rw-r--r--algebraic-structures.stream.applicative.scm4
-rw-r--r--algebraic-structures.stream.foldable.scm3
-rw-r--r--algebraic-structures.stream.functor.scm3
-rw-r--r--algebraic-structures.stream.monad.scm4
-rw-r--r--algebraic-structures.stream.monoid.scm3
-rw-r--r--algebraic-structures.stream.reducible.scm3
-rw-r--r--algebraic-structures.stream.semigroup.scm3
-rw-r--r--algebraic-structures.stream.zip.applicative.scm4
-rw-r--r--tests/run.scm140
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")