From 5931a79a5a915035e01b9fb22a3edfde7895e424 Mon Sep 17 00:00:00 2001
From: Masaya Tojo <masaya@tojo.tokyo>
Date: Sun, 16 Jun 2024 01:58:48 +0900
Subject: Add list implementations

---
 algebraic-structures.egg                           |  18 +++-
 algebraic-structures.list.alternative.scm          |   4 +
 algebraic-structures.list.applicative.scm          |   4 +
 algebraic-structures.list.foldable.scm             |   3 +
 algebraic-structures.list.functor.scm              |   3 +
 algebraic-structures.list.monad.scm                |   4 +
 algebraic-structures.list.monoid.scm               |   3 +
 algebraic-structures.list.reducible.scm            |   3 +
 algebraic-structures.list.semigroup.scm            |   3 +
 algebraic-structures.list.zip.applicative.scm      |   4 +
 algebraic-structures.private.list.alternative.scm  |   9 ++
 algebraic-structures.private.list.applicative.scm  |  30 ++++++
 algebraic-structures.private.list.monad.scm        |   8 ++
 algebraic-structures.private.list.scm              |  19 ++++
 ...aic-structures.private.list.zip.applicative.scm |  14 +++
 tests/run.scm                                      | 114 +++++----------------
 16 files changed, 151 insertions(+), 92 deletions(-)
 create mode 100644 algebraic-structures.list.alternative.scm
 create mode 100644 algebraic-structures.list.applicative.scm
 create mode 100644 algebraic-structures.list.foldable.scm
 create mode 100644 algebraic-structures.list.functor.scm
 create mode 100644 algebraic-structures.list.monad.scm
 create mode 100644 algebraic-structures.list.monoid.scm
 create mode 100644 algebraic-structures.list.reducible.scm
 create mode 100644 algebraic-structures.list.semigroup.scm
 create mode 100644 algebraic-structures.list.zip.applicative.scm
 create mode 100644 algebraic-structures.private.list.alternative.scm
 create mode 100644 algebraic-structures.private.list.applicative.scm
 create mode 100644 algebraic-structures.private.list.monad.scm
 create mode 100644 algebraic-structures.private.list.scm
 create mode 100644 algebraic-structures.private.list.zip.applicative.scm

diff --git a/algebraic-structures.egg b/algebraic-structures.egg
index ba4fd46..5e7eba3 100644
--- a/algebraic-structures.egg
+++ b/algebraic-structures.egg
@@ -18,4 +18,20 @@
   (extension algebraic-structures.functor)
   (extension algebraic-structures.applicative)
   (extension algebraic-structures.monad)
-  (extension algebraic-structures.alternative)))
+  (extension algebraic-structures.alternative)
+
+  ;; List
+  (extension algebraic-structures.private.list)
+  (extension algebraic-structures.list.semigroup)
+  (extension algebraic-structures.list.monoid)
+  (extension algebraic-structures.list.foldable)
+  (extension algebraic-structures.list.reducible)
+  (extension algebraic-structures.list.functor)
+  (extension algebraic-structures.private.list.zip.applicative)
+  (extension algebraic-structures.list.zip.applicative)
+  (extension algebraic-structures.private.list.applicative)
+  (extension algebraic-structures.list.applicative)
+  (extension algebraic-structures.private.list.monad)
+  (extension algebraic-structures.list.monad)
+  (extension algebraic-structures.private.list.alternative)
+  (extension algebraic-structures.list.alternative)))
diff --git a/algebraic-structures.list.alternative.scm b/algebraic-structures.list.alternative.scm
new file mode 100644
index 0000000..2804d61
--- /dev/null
+++ b/algebraic-structures.list.alternative.scm
@@ -0,0 +1,4 @@
+(import (algebraic-structures alternative)
+        (only (algebraic-structures private list alternative)))
+(module (algebraic-structures list alternative) = ((algebraic-structures alternative)
+                                                   (algebraic-structures private list alternative)))
diff --git a/algebraic-structures.list.applicative.scm b/algebraic-structures.list.applicative.scm
new file mode 100644
index 0000000..5165e96
--- /dev/null
+++ b/algebraic-structures.list.applicative.scm
@@ -0,0 +1,4 @@
+(import (algebraic-structures applicative)
+        (only (algebraic-structures private list applicative)))
+(module (algebraic-structures list applicative) = ((algebraic-structures applicative)
+                                                   (algebraic-structures private list applicative)))
diff --git a/algebraic-structures.list.foldable.scm b/algebraic-structures.list.foldable.scm
new file mode 100644
index 0000000..5150f9b
--- /dev/null
+++ b/algebraic-structures.list.foldable.scm
@@ -0,0 +1,3 @@
+(import (algebraic-structures foldable)
+        (only (algebraic-structures private list)))
+(module (algebraic-structures list foldable) = ((algebraic-structures foldable) (algebraic-structures private list)))
diff --git a/algebraic-structures.list.functor.scm b/algebraic-structures.list.functor.scm
new file mode 100644
index 0000000..a9707f2
--- /dev/null
+++ b/algebraic-structures.list.functor.scm
@@ -0,0 +1,3 @@
+(import (algebraic-structures functor)
+        (only (algebraic-structures private list)))
+(module (algebraic-structures list functor) = ((algebraic-structures functor) (algebraic-structures private list)))
diff --git a/algebraic-structures.list.monad.scm b/algebraic-structures.list.monad.scm
new file mode 100644
index 0000000..ebf142f
--- /dev/null
+++ b/algebraic-structures.list.monad.scm
@@ -0,0 +1,4 @@
+(import (algebraic-structures monad)
+        (only (algebraic-structures private list monad)))
+(module (algebraic-structures list monad) = ((algebraic-structures monad)
+                                             (algebraic-structures private list monad)))
diff --git a/algebraic-structures.list.monoid.scm b/algebraic-structures.list.monoid.scm
new file mode 100644
index 0000000..87e6119
--- /dev/null
+++ b/algebraic-structures.list.monoid.scm
@@ -0,0 +1,3 @@
+(import (algebraic-structures monoid)
+        (only (algebraic-structures private list)))
+(module (algebraic-structures list monoid) = ((algebraic-structures monoid) (algebraic-structures private list)))
diff --git a/algebraic-structures.list.reducible.scm b/algebraic-structures.list.reducible.scm
new file mode 100644
index 0000000..b98cfd7
--- /dev/null
+++ b/algebraic-structures.list.reducible.scm
@@ -0,0 +1,3 @@
+(import (algebraic-structures reducible)
+        (only (algebraic-structures private list)))
+(module (algebraic-structures list reducible) = ((algebraic-structures reducible) (algebraic-structures private list)))
diff --git a/algebraic-structures.list.semigroup.scm b/algebraic-structures.list.semigroup.scm
new file mode 100644
index 0000000..eac0c5e
--- /dev/null
+++ b/algebraic-structures.list.semigroup.scm
@@ -0,0 +1,3 @@
+(import (algebraic-structures semigroup)
+        (only (algebraic-structures private list)))
+(module (algebraic-structures list semigroup) = ((algebraic-structures semigroup) (algebraic-structures private list)))
diff --git a/algebraic-structures.list.zip.applicative.scm b/algebraic-structures.list.zip.applicative.scm
new file mode 100644
index 0000000..c72a8ec
--- /dev/null
+++ b/algebraic-structures.list.zip.applicative.scm
@@ -0,0 +1,4 @@
+(import (algebraic-structures applicative)
+        (only (algebraic-structures private list zip applicative)))
+(module (algebraic-structures list zip applicative) = ((algebraic-structures applicative)
+                                                       (algebraic-structures private list zip applicative)))
diff --git a/algebraic-structures.private.list.alternative.scm b/algebraic-structures.private.list.alternative.scm
new file mode 100644
index 0000000..a386e81
--- /dev/null
+++ b/algebraic-structures.private.list.alternative.scm
@@ -0,0 +1,9 @@
+(module (algebraic-structures private list alternative) (alt empty)
+  (import (except scheme map apply)
+          (chicken module))
+  (reexport (algebraic-structures list applicative))
+
+  (define empty '())
+
+  (define (alt xs ys)
+    (append xs ys)))
diff --git a/algebraic-structures.private.list.applicative.scm b/algebraic-structures.private.list.applicative.scm
new file mode 100644
index 0000000..6bbfad7
--- /dev/null
+++ b/algebraic-structures.private.list.applicative.scm
@@ -0,0 +1,30 @@
+(module (algebraic-structures private list applicative) ()
+  (import scheme
+          (only (srfi 1) append! reverse!)
+          (only (chicken base) assert cut)
+          (only matchable match)
+          (chicken module))
+  (export pure map2)
+  (reexport (algebraic-structures list functor))
+
+  (define (pure x) (list x))
+
+  (define (rev-map f lst)
+    (let loop ((lst lst)
+               (acc '()))
+      (match lst
+        [() acc]
+        [(h . t)
+         (loop t (cons (f h) acc))])))
+
+  (define (product op lst1 lst2)
+    (let loop ((lst lst1)
+               (acc '()))
+      (match lst
+        [() (reverse! acc)]
+        [(h . t)
+         (loop t
+               (append! (rev-map (cut op h <>) lst2)
+                        acc))])))
+
+  (define map2 product))
diff --git a/algebraic-structures.private.list.monad.scm b/algebraic-structures.private.list.monad.scm
new file mode 100644
index 0000000..96da332
--- /dev/null
+++ b/algebraic-structures.private.list.monad.scm
@@ -0,0 +1,8 @@
+(module (algebraic-structures private list monad) (>>=)
+  (import (except scheme map apply)
+          (chicken module)
+          (only (srfi 1) append-map))
+  (reexport (algebraic-structures list applicative))
+
+  (define (>>= xs f)
+    (append-map f xs)))
diff --git a/algebraic-structures.private.list.scm b/algebraic-structures.private.list.scm
new file mode 100644
index 0000000..4710b40
--- /dev/null
+++ b/algebraic-structures.private.list.scm
@@ -0,0 +1,19 @@
+(module (algebraic-structures private list) (<> unit fold reduce map1)
+  (import scheme
+          (rename (only (srfi 1) fold reduce)
+                  (fold srfi:fold)
+                  (reduce srfi:reduce))
+          (only (chicken base) assert))
+
+  (define <> append)
+
+  (define unit '())
+
+  (define fold srfi:fold)
+
+  (define (reduce f xs)
+    (assert (not (null? xs)))
+    (srfi:reduce f #f xs))
+
+  (define (map1 f xs)
+    (map f xs)))
diff --git a/algebraic-structures.private.list.zip.applicative.scm b/algebraic-structures.private.list.zip.applicative.scm
new file mode 100644
index 0000000..8713ef9
--- /dev/null
+++ b/algebraic-structures.private.list.zip.applicative.scm
@@ -0,0 +1,14 @@
+(module (algebraic-structures private list zip applicative) ()
+  (import scheme
+          (rename (only (srfi 1) fold reduce)
+                  (fold srfi:fold)
+                  (reduce srfi:reduce))
+          (only (chicken base) assert)
+          (chicken module))
+  (export pure map2)
+  (reexport (algebraic-structures list functor))
+
+  (define (pure x) (list x))
+
+  (define (map2 f xs ys)
+    (map f xs ys)))
diff --git a/tests/run.scm b/tests/run.scm
index 8195ea8..eac7569 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -83,13 +83,7 @@
 
 (test-begin "foldable")
 
-(import (algebraic-structures foldable))
-
-(module (data list foldable) = (algebraic-structures foldable)
-  (import (chicken module))
-  (reexport (only (srfi 1) fold)))
-
-(import (prefix (data list foldable) list:))
+(import (prefix (algebraic-structures list foldable) list:))
 
 (test '(e d c b a) (list:fold cons '() '(a b c d e)))
 
@@ -116,20 +110,7 @@
 
 (test-begin "reducible")
 
-(module (data list reducible) = (algebraic-structures reducible)
-  (import scheme
-          (algebraic-structures reducible)
-          (rename (srfi 1) (reduce srfi:reduce))
-          (only (chicken base) assert)
-          (chicken module))
-  (export reduce)
-
-  (define (reduce f xs)
-    (assert (list? xs))
-    (assert (not (null? xs)))
-    (srfi:reduce f #f xs)))
-
-(import (prefix (data list reducible) list:))
+(import (prefix (algebraic-structures list reducible) list:))
 
 (test 10 (list:reduce + '(1 2 3 4)))
 (test -3 (list:minimum '(1 8 -3 5 4) <))
@@ -149,7 +130,9 @@
     (+ x y)))
 
 (import (algebraic-structures semigroup reduce))
-(module (sum reduce) = ((algebraic-structures semigroup reduce) (sum semigroup) (data list reducible)))
+(module (sum reduce) = ((algebraic-structures semigroup reduce)
+                        (sum semigroup)
+                        (algebraic-structures list reducible)))
 
 (import (prefix (sum reduce) sum:))
 
@@ -182,7 +165,9 @@
   (define unit 1))
 
 (import (algebraic-structures monoid fold))
-(module (product fold) = ((algebraic-structures monoid fold) (product monoid) (data list foldable)))
+(module (product fold) = ((algebraic-structures monoid fold)
+                          (product monoid)
+                          (algebraic-structures list foldable)))
 
 (import (prefix (product monoid) product:))
 (import (prefix (product fold) product:))
@@ -196,12 +181,7 @@
 
 (test-begin "functor")
 
-(import (algebraic-structures functor))
-(module (data list functor) = (algebraic-structures functor)
-  (import (chicken module))
-  (reexport (rename scheme (map map1))))
-
-(import (prefix (data list functor) list:))
+(import (prefix (algebraic-structures list functor) list:))
 
 (test '((a) (b) (c)) (list:map1 list '(a b c)))
 
@@ -209,41 +189,7 @@
 
 (test-begin "applicative")
 
-(import (algebraic-structures applicative))
-(module (data list applicative) = (algebraic-structures applicative)
-  (import (except scheme map)
-          (chicken module)
-          (srfi 1)
-          matchable
-          (chicken base)
-          (data list functor))
-  (reexport (data list functor))
-  (export pure map2)
-
-  (define (pure x)
-    (list x))
-
-  (define (rev-map f lst)
-    (let loop ((lst lst)
-               (acc '()))
-      (match lst
-        [() acc]
-        [(h . t)
-         (loop t (cons (f h) acc))])))
-
-  (define (product op lst1 lst2)
-    (let loop ((lst lst1)
-               (acc '()))
-      (match lst
-        [() (reverse! acc)]
-        [(h . t)
-         (loop t
-               (append! (rev-map (cut op h <>) lst2)
-                        acc))])))
-
-  (define map2 product))
-
-(import (prefix (data list applicative) list:))
+(import (prefix (algebraic-structures list applicative) list:))
 
 (test '(a) (list:pure 'a))
 
@@ -253,22 +199,22 @@
 (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-end "applicative")
+(test-begin "list.zip")
 
-(test-begin "monad")
+(import (prefix (algebraic-structures list zip applicative) list-zip:))
 
-(import (algebraic-structures monad))
-(module (data list monad) = (algebraic-structures monad)
-  (import scheme
-          (chicken module)
-          (srfi 1))
-  (reexport (data list applicative))
-  (export >>=)
+(test '(a) (list:pure 'a))
+
+(test '((a 1) (b 2))
+      (list-zip:map2 list '(a b c) '(1 2)))
+
+(test-end "list.zip")
+
+(test-end "applicative")
 
-  (define (>>= lst f)
-    (append-map f lst)))
+(test-begin "monad")
 
-(import (prefix (data list monad) list:))
+(import (prefix (algebraic-structures list monad) list:))
 
 (test '((1 a) (2 a))
       (list:>>= (list:pure 'a)
@@ -287,21 +233,7 @@
 
 (test-begin "alternative")
 
-(import (algebraic-structures alternative))
-(module (data list alternative) = (algebraic-structures alternative)
-  (import (except scheme map)
-          (chicken module)
-          (chicken base)
-          (data list applicative))
-  (reexport (data list applicative))
-  (export alt empty)
-
-  (define (alt x y)
-    (append x y))
-
-  (define empty '()))
-
-(import (prefix (data list alternative) list:))
+(import (prefix (algebraic-structures list alternative) list:))
 
 (test '(9 25)
       (list:do (x <- '(2 3 4 5))
-- 
cgit v1.2.3