From e51a5f32bb8f23eb0fd27213cb36ce09a42a6386 Mon Sep 17 00:00:00 2001
From: Masaya Tojo <masaya@tojo.tokyo>
Date: Sun, 16 Jun 2024 12:15:11 +0900
Subject: Add stream implementations

---
 algebraic-structures.egg                           |  20 ++-
 ...braic-structures.private.stream.alternative.scm |  10 ++
 ...braic-structures.private.stream.applicative.scm |  17 +++
 algebraic-structures.private.stream.monad.scm      |  14 +++
 algebraic-structures.private.stream.scm            |  20 +++
 ...c-structures.private.stream.zip.applicative.scm |  11 ++
 algebraic-structures.stream.alternative.scm        |   4 +
 algebraic-structures.stream.applicative.scm        |   4 +
 algebraic-structures.stream.foldable.scm           |   3 +
 algebraic-structures.stream.functor.scm            |   3 +
 algebraic-structures.stream.monad.scm              |   4 +
 algebraic-structures.stream.monoid.scm             |   3 +
 algebraic-structures.stream.reducible.scm          |   3 +
 algebraic-structures.stream.semigroup.scm          |   3 +
 algebraic-structures.stream.zip.applicative.scm    |   4 +
 tests/run.scm                                      | 140 ++++++++++++++++++++-
 16 files changed, 260 insertions(+), 3 deletions(-)
 create mode 100644 algebraic-structures.private.stream.alternative.scm
 create mode 100644 algebraic-structures.private.stream.applicative.scm
 create mode 100644 algebraic-structures.private.stream.monad.scm
 create mode 100644 algebraic-structures.private.stream.scm
 create mode 100644 algebraic-structures.private.stream.zip.applicative.scm
 create mode 100644 algebraic-structures.stream.alternative.scm
 create mode 100644 algebraic-structures.stream.applicative.scm
 create mode 100644 algebraic-structures.stream.foldable.scm
 create mode 100644 algebraic-structures.stream.functor.scm
 create mode 100644 algebraic-structures.stream.monad.scm
 create mode 100644 algebraic-structures.stream.monoid.scm
 create mode 100644 algebraic-structures.stream.reducible.scm
 create mode 100644 algebraic-structures.stream.semigroup.scm
 create mode 100644 algebraic-structures.stream.zip.applicative.scm

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")
-- 
cgit v1.2.3