From 92eeab2815eae6cd9ef22530d2e50fe0a620ec46 Mon Sep 17 00:00:00 2001
From: Masaya Tojo <masaya@tojo.tokyo>
Date: Sun, 9 Jun 2024 05:13:44 +0900
Subject: Initial commit

---
 .gitignore                                       |   7 +
 LICENSE                                          |  21 +++
 README.md                                        | 107 ++++++++++++++++
 algebraic-structs.alternative.list.base.scm      |   8 ++
 algebraic-structs.alternative.list.scm           |   5 +
 algebraic-structs.alternative.make.scm           |  10 ++
 algebraic-structs.applicative.list.base.scm      |  29 +++++
 algebraic-structs.applicative.list.scm           |   5 +
 algebraic-structs.applicative.make.scm           |  28 ++++
 algebraic-structs.egg                            |  38 ++++++
 algebraic-structs.foldable.list.base.scm         |   2 +
 algebraic-structs.foldable.list.scm              |   5 +
 algebraic-structs.foldable.make.scm              |  39 ++++++
 algebraic-structs.foldable.vector.base.scm       |  21 +++
 algebraic-structs.foldable.vector.scm            |   5 +
 algebraic-structs.functor.list.base.scm          |   4 +
 algebraic-structs.functor.list.scm               |   5 +
 algebraic-structs.functor.make.scm               |   3 +
 algebraic-structs.functor.vector.base.scm        |  10 ++
 algebraic-structs.functor.vector.scm             |   5 +
 algebraic-structs.monad.list.base.scm            |   7 +
 algebraic-structs.monad.list.scm                 |   5 +
 algebraic-structs.monad.make.scm                 |  29 +++++
 algebraic-structs.monoid.list.base.scm           |   5 +
 algebraic-structs.monoid.list.scm                |   5 +
 algebraic-structs.monoid.make.fold.scm           |   4 +
 algebraic-structs.monoid.make.scm                |   3 +
 algebraic-structs.monoid.number.product.base.scm |   5 +
 algebraic-structs.monoid.number.product.scm      |   5 +
 algebraic-structs.monoid.number.sum.base.scm     |   5 +
 algebraic-structs.monoid.number.sum.scm          |   5 +
 tests/run.scm                                    | 156 +++++++++++++++++++++++
 32 files changed, 591 insertions(+)
 create mode 100644 .gitignore
 create mode 100644 LICENSE
 create mode 100644 README.md
 create mode 100644 algebraic-structs.alternative.list.base.scm
 create mode 100644 algebraic-structs.alternative.list.scm
 create mode 100644 algebraic-structs.alternative.make.scm
 create mode 100644 algebraic-structs.applicative.list.base.scm
 create mode 100644 algebraic-structs.applicative.list.scm
 create mode 100644 algebraic-structs.applicative.make.scm
 create mode 100644 algebraic-structs.egg
 create mode 100644 algebraic-structs.foldable.list.base.scm
 create mode 100644 algebraic-structs.foldable.list.scm
 create mode 100644 algebraic-structs.foldable.make.scm
 create mode 100644 algebraic-structs.foldable.vector.base.scm
 create mode 100644 algebraic-structs.foldable.vector.scm
 create mode 100644 algebraic-structs.functor.list.base.scm
 create mode 100644 algebraic-structs.functor.list.scm
 create mode 100644 algebraic-structs.functor.make.scm
 create mode 100644 algebraic-structs.functor.vector.base.scm
 create mode 100644 algebraic-structs.functor.vector.scm
 create mode 100644 algebraic-structs.monad.list.base.scm
 create mode 100644 algebraic-structs.monad.list.scm
 create mode 100644 algebraic-structs.monad.make.scm
 create mode 100644 algebraic-structs.monoid.list.base.scm
 create mode 100644 algebraic-structs.monoid.list.scm
 create mode 100644 algebraic-structs.monoid.make.fold.scm
 create mode 100644 algebraic-structs.monoid.make.scm
 create mode 100644 algebraic-structs.monoid.number.product.base.scm
 create mode 100644 algebraic-structs.monoid.number.product.scm
 create mode 100644 algebraic-structs.monoid.number.sum.base.scm
 create mode 100644 algebraic-structs.monoid.number.sum.scm
 create mode 100644 tests/run.scm

diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..fdb55ac
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,7 @@
+*~
+*.import.scm
+*.so
+*.install.sh
+*.build.sh
+*.link
+*.o
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..26844f7
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,21 @@
+MIT License
+
+Copyright (c) 2024 Masaya Tojo
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.
diff --git a/README.md b/README.md
new file mode 100644
index 0000000..c5c24c6
--- /dev/null
+++ b/README.md
@@ -0,0 +1,107 @@
+# algebraic-structs
+
+Provides useful algebraic structures for programming using parameterized module.
+
+## Install
+
+Run `chicken-install` in the project's root directory.
+
+```
+$ cd algebraic-structs
+$ chicken-install
+```
+
+## Supported Features
+
+- Monoid
+  - list
+  - number (sum)
+  - number (product)
+- Foldable
+  - list
+  - vector
+- Functor
+  - list
+- Applicative
+  - list
+- Monad
+  - list
+- Alternative
+  - list
+
+## Example: `Optional` monad
+
+```
+(module (data optional) (<some> some some? some-value <none> none none?)
+  (import scheme (chicken base) (chicken format))
+
+  (define-record-type <some>
+    (some value)
+    some?
+    (value some-value))
+
+  (set! (record-printer <some>)
+    (lambda (x out)
+      (fprintf out "#<(some ~S)>" (some-value x))))
+
+  (define-record-type <none>
+    (none)
+    none?)
+
+  (set! (record-printer <none>)
+    (lambda (_ out)
+      (fprintf out "#<(none)>"))))
+
+(module (data optional monad base) (pure map map2 >>=)
+  (import (except scheme map)
+          (prefix (data optional) opt:)
+          matchable)
+
+  (define (map f opt)
+    (match opt
+      [($ opt:<some> x) (opt:some (f x))]
+      [($ opt:<none>) (opt:none)]))
+
+  (define (pure x)
+    (opt:some x))
+
+  (define (map2 f opt1 opt2)
+    (match opt1
+      [($ opt:<some> x)
+       (match opt2
+         [($ opt:<some> y) (opt:some (f x y))]
+         [($ opt:<none>) (opt:none)])]
+      [($ opt:<none>) (opt:none)]))
+
+  (define (>>= opt f)
+    (match opt
+      [($ opt:<some> x) (f x)]
+      [($ opt:<none>) (opt:none)])))
+
+(import (only (algebraic-structs functor make)))
+(import (only (algebraic-structs applicative make)))
+(import (only (algebraic-structs monad make)))
+(module (data optional functor) = ((algebraic-structs functor make) (data optional monad base)))
+(module (data optional applicative) = ((algebraic-structs applicative make) (data optional monad base)))
+(module (data optional monad) = ((algebraic-structs monad make) (data optional monad base)))
+
+(import (prefix (data optional) opt:)
+        (prefix (data optional functor) opt:)
+        (prefix (data optional applicative) opt:)
+        (prefix (data optional monad) opt:))
+
+;; (opt:map (lambda (x) (* x x)) (opt:pure 5)) => (some 25)
+;; (opt:map (lambda (x) (* x x)) (opt:none)) => (some 25)
+
+;; (opt:map* + (opt:pure 1) (opt:pure 2) (opt:pure 3)) => (some 6)
+;; (opt:map* + (opt:pure 1) (opt:none) (opt:pure 3)) => (none)
+
+;; (opt:do (x <- (opt:pure 3))
+;;         (y <- (opt:pure 4))
+;;         (opt:pure (+ x y)))
+;; => (some 7)
+```
+
+## LICENSE
+
+This program is licensed under the MIT License. See the LICENSE file for details.
diff --git a/algebraic-structs.alternative.list.base.scm b/algebraic-structs.alternative.list.base.scm
new file mode 100644
index 0000000..73f3c84
--- /dev/null
+++ b/algebraic-structs.alternative.list.base.scm
@@ -0,0 +1,8 @@
+(module (algebraic-structs alternative list base) (pure map map2 alt empty)
+  (import (except scheme map apply)
+          (algebraic-structs applicative list))
+
+  (define (alt x y)
+    (append x y))
+
+  (define empty '()))
diff --git a/algebraic-structs.alternative.list.scm b/algebraic-structs.alternative.list.scm
new file mode 100644
index 0000000..1c366ad
--- /dev/null
+++ b/algebraic-structs.alternative.list.scm
@@ -0,0 +1,5 @@
+(import (only (algebraic-structs alternative make)))
+(import (only (algebraic-structs alternative list base)))
+
+(module (algebraic-structs alternative list) =
+  ((algebraic-structs alternative make) (algebraic-structs alternative list base)))
diff --git a/algebraic-structs.alternative.make.scm b/algebraic-structs.alternative.make.scm
new file mode 100644
index 0000000..df4e0f4
--- /dev/null
+++ b/algebraic-structs.alternative.make.scm
@@ -0,0 +1,10 @@
+(functor ((algebraic-structs alternative make) (A (pure map map2 alt empty)))
+    (pure map map2 alt empty guard)
+  (import (except scheme map apply)
+          (only (chicken base) void)
+          A)
+
+  (define (guard b)
+    (if b
+        (pure (void))
+        empty)))
diff --git a/algebraic-structs.applicative.list.base.scm b/algebraic-structs.applicative.list.base.scm
new file mode 100644
index 0000000..01625ff
--- /dev/null
+++ b/algebraic-structs.applicative.list.base.scm
@@ -0,0 +1,29 @@
+(module (algebraic-structs applicative list base) (map pure map2)
+  (import (except scheme map)
+          (algebraic-structs functor list)
+          (only (chicken base) atom? cut)
+          (only (srfi 1) append! reverse!)
+          matchable)
+
+  (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-structs.applicative.list.scm b/algebraic-structs.applicative.list.scm
new file mode 100644
index 0000000..44d3a28
--- /dev/null
+++ b/algebraic-structs.applicative.list.scm
@@ -0,0 +1,5 @@
+(import (only (algebraic-structs applicative make)))
+(import (only (algebraic-structs applicative list base)))
+
+(module (algebraic-structs applicative list) =
+  ((algebraic-structs applicative make) (algebraic-structs applicative list base)))
diff --git a/algebraic-structs.applicative.make.scm b/algebraic-structs.applicative.make.scm
new file mode 100644
index 0000000..3681dfa
--- /dev/null
+++ b/algebraic-structs.applicative.make.scm
@@ -0,0 +1,28 @@
+(functor ((algebraic-structs applicative make) (A (pure map map2)))
+    (pure map map2 map* apply)
+  (import (rename scheme (map scheme:map) (apply scheme:apply))
+          (only (chicken base) sub1 add1 foldl case-lambda)
+          A
+          matchable)
+
+  (define (curry-n f n)
+    (let rec ((i n)
+              (k (lambda (args)
+                   (scheme:apply f args))))
+      (if (= i 1)
+          (lambda (x) (k (list x)))
+          (lambda (x)
+            (rec (sub1 i)
+                 (lambda (args)
+                   (k (cons x args))))))))
+
+  (define map*
+    (case-lambda
+      ((f x) (map f x))
+      ((f x y) (map2 f x y))
+      ((f x . xs)
+       (let ((g (curry-n f (add1 (length xs)))))
+         (foldl apply (apply (pure g) x) xs)))))
+
+  (define (apply a1 a2)
+    (map2 (lambda (f x) (f x)) a1 a2)))
diff --git a/algebraic-structs.egg b/algebraic-structs.egg
new file mode 100644
index 0000000..1a1a73d
--- /dev/null
+++ b/algebraic-structs.egg
@@ -0,0 +1,38 @@
+;;; -*- scheme -*-
+
+((synopsis "Provides useful algebraic structures for programming using parameterized module.")
+ (author "Masaya Tojo")
+ (license "BSD")
+ (category data)
+ (version "0.1.0")
+ (dependencies matchable)
+ (test-dependencies test)
+ (components
+  (extension algebraic-structs.monoid.make)
+  (extension algebraic-structs.monoid.list.base)
+  (extension algebraic-structs.monoid.list)
+  (extension algebraic-structs.monoid.number.sum.base)
+  (extension algebraic-structs.monoid.number.sum)
+  (extension algebraic-structs.monoid.number.product.base)
+  (extension algebraic-structs.monoid.number.product)
+  (extension algebraic-structs.monoid.make.fold)
+  (extension algebraic-structs.foldable.make)
+  (extension algebraic-structs.foldable.list.base)
+  (extension algebraic-structs.foldable.list)
+  (extension algebraic-structs.foldable.vector.base)
+  (extension algebraic-structs.foldable.vector)
+  (extension algebraic-structs.functor.make)
+  (extension algebraic-structs.functor.list.base)
+  (extension algebraic-structs.functor.list)
+  (extension algebraic-structs.functor.vector.base)
+  (extension algebraic-structs.functor.vector)
+  (extension algebraic-structs.applicative.make)
+  (extension algebraic-structs.applicative.list.base)
+  (extension algebraic-structs.applicative.list)
+  (extension algebraic-structs.monad.make)
+  (extension algebraic-structs.monad.list.base)
+  (extension algebraic-structs.monad.list)
+  (extension algebraic-structs.monad.list)
+  (extension algebraic-structs.alternative.make)
+  (extension algebraic-structs.alternative.list.base)
+  (extension algebraic-structs.alternative.list)))
diff --git a/algebraic-structs.foldable.list.base.scm b/algebraic-structs.foldable.list.base.scm
new file mode 100644
index 0000000..0f5c656
--- /dev/null
+++ b/algebraic-structs.foldable.list.base.scm
@@ -0,0 +1,2 @@
+(module (algebraic-structs foldable list base) (foldl foldr)
+  (import (only (chicken base) foldl foldr)))
diff --git a/algebraic-structs.foldable.list.scm b/algebraic-structs.foldable.list.scm
new file mode 100644
index 0000000..5f729e2
--- /dev/null
+++ b/algebraic-structs.foldable.list.scm
@@ -0,0 +1,5 @@
+(import (only (algebraic-structs foldable list base)))
+(import (only (algebraic-structs foldable make)))
+
+(module (algebraic-structs foldable list) = ((algebraic-structs foldable make)
+                                             (algebraic-structs foldable list base)))
diff --git a/algebraic-structs.foldable.make.scm b/algebraic-structs.foldable.make.scm
new file mode 100644
index 0000000..46b4dd5
--- /dev/null
+++ b/algebraic-structs.foldable.make.scm
@@ -0,0 +1,39 @@
+(functor ((algebraic-structs foldable make) (F (foldl foldr)))
+    (foldl foldr length find any every ->list)
+  (import (except scheme length) F
+          (only (chicken base) add1 call/cc))
+
+  (define (length xs)
+    (foldl (lambda (acc _) (add1 acc))
+           0
+           xs))
+
+  (define (find p? xs)
+    (call/cc
+     (lambda (k)
+       (foldl (lambda (acc e)
+                (if (p? e)
+                    (k e)
+                    acc))
+              #f
+              xs))))
+
+  (define (any pred xs)
+    (call/cc
+     (lambda (return)
+       (foldl (lambda (acc e)
+                (cond ((pred e) => return)
+                      (else acc)))
+              #f
+              xs))))
+
+  (define (every pred xs)
+    (call/cc
+     (lambda (return)
+       (foldl (lambda (acc e)
+                (or (pred e) (return #f)))
+              #t
+              xs))))
+
+  (define (->list xs)
+    (foldr cons '() xs)))
diff --git a/algebraic-structs.foldable.vector.base.scm b/algebraic-structs.foldable.vector.base.scm
new file mode 100644
index 0000000..0c5af89
--- /dev/null
+++ b/algebraic-structs.foldable.vector.base.scm
@@ -0,0 +1,21 @@
+(module (algebraic-structs foldable vector base) (foldl foldr)
+  (import scheme
+          (only (chicken base) add1 sub1))
+
+  (define (foldl f z v)
+    (let ((len (vector-length v)))
+      (let loop ((i 0)
+                 (acc z))
+        (if (= i len)
+            acc
+            (loop (add1 i)
+                  (f acc (vector-ref v i)))))))
+
+  (define (foldr f z v)
+    (let ((len (vector-length v)))
+      (let loop ((i (sub1 len))
+                 (acc z))
+        (if (< i 0)
+            acc
+            (loop (sub1 i)
+                  (f (vector-ref v i) acc)))))))
diff --git a/algebraic-structs.foldable.vector.scm b/algebraic-structs.foldable.vector.scm
new file mode 100644
index 0000000..1d68aaa
--- /dev/null
+++ b/algebraic-structs.foldable.vector.scm
@@ -0,0 +1,5 @@
+(import (only (algebraic-structs foldable vector base)))
+(import (only (algebraic-structs foldable make)))
+
+(module (algebraic-structs foldable vector) = ((algebraic-structs foldable make)
+                                               (algebraic-structs foldable vector base)))
diff --git a/algebraic-structs.functor.list.base.scm b/algebraic-structs.functor.list.base.scm
new file mode 100644
index 0000000..e3051d5
--- /dev/null
+++ b/algebraic-structs.functor.list.base.scm
@@ -0,0 +1,4 @@
+(module (algebraic-structs functor list base) (map)
+  (import (rename (scheme) (map list:map)))
+
+  (define (map f lst) (list:map f lst)))
diff --git a/algebraic-structs.functor.list.scm b/algebraic-structs.functor.list.scm
new file mode 100644
index 0000000..62c4910
--- /dev/null
+++ b/algebraic-structs.functor.list.scm
@@ -0,0 +1,5 @@
+(import (only (algebraic-structs functor list base)))
+(import (only (algebraic-structs functor make)))
+
+(module (algebraic-structs functor list) = ((algebraic-structs functor make)
+                                            (algebraic-structs functor list base)))
diff --git a/algebraic-structs.functor.make.scm b/algebraic-structs.functor.make.scm
new file mode 100644
index 0000000..23b366f
--- /dev/null
+++ b/algebraic-structs.functor.make.scm
@@ -0,0 +1,3 @@
+(functor ((algebraic-structs functor make) (F (map)))
+    (map)
+  (import F))
diff --git a/algebraic-structs.functor.vector.base.scm b/algebraic-structs.functor.vector.base.scm
new file mode 100644
index 0000000..2f44673
--- /dev/null
+++ b/algebraic-structs.functor.vector.base.scm
@@ -0,0 +1,10 @@
+(module (algebraic-structs functor vector base) (map)
+  (import (rename scheme (map list-map))
+          (only (chicken base) add1))
+
+  (define (map f v)
+    (let* ((len (vector-length v))
+           (new (make-vector len)))
+      (do ((i 0 (add1 i)))
+          ((= i len) new)
+        (vector-set! new i (vector-ref v i))))))
diff --git a/algebraic-structs.functor.vector.scm b/algebraic-structs.functor.vector.scm
new file mode 100644
index 0000000..26481cc
--- /dev/null
+++ b/algebraic-structs.functor.vector.scm
@@ -0,0 +1,5 @@
+(import (only (algebraic-structs functor vector base)))
+(import (only (algebraic-structs functor make)))
+
+(module (algebraic-structs functor vector) = ((algebraic-structs functor make)
+                                              (algebraic-structs functor vector base)))
diff --git a/algebraic-structs.monad.list.base.scm b/algebraic-structs.monad.list.base.scm
new file mode 100644
index 0000000..a7305a0
--- /dev/null
+++ b/algebraic-structs.monad.list.base.scm
@@ -0,0 +1,7 @@
+(module (algebraic-structs monad list base) (pure map map2 >>=)
+  (import (except scheme map)
+          (algebraic-structs applicative list)
+          (only (srfi 1) append-map))
+
+  (define (>>= lst f)
+    (append-map f lst)))
diff --git a/algebraic-structs.monad.list.scm b/algebraic-structs.monad.list.scm
new file mode 100644
index 0000000..edb5cf7
--- /dev/null
+++ b/algebraic-structs.monad.list.scm
@@ -0,0 +1,5 @@
+(import (only (algebraic-structs monad make)))
+(import (only (algebraic-structs monad list base)))
+
+(module (algebraic-structs monad list) =
+  ((algebraic-structs monad make) (algebraic-structs monad list base)))
diff --git a/algebraic-structs.monad.make.scm b/algebraic-structs.monad.make.scm
new file mode 100644
index 0000000..0598309
--- /dev/null
+++ b/algebraic-structs.monad.make.scm
@@ -0,0 +1,29 @@
+(functor ((algebraic-structs monad make) (M (pure map map2 >>=)))
+    (pure map map2 >>= do)
+  (import (rename scheme (map scheme:map) (do scheme:do))
+          M)
+  (import-for-syntax matchable
+                     (chicken syntax)
+                     (only (srfi 1) last))
+
+  (define-syntax do
+    (ir-macro-transformer
+     (lambda (expr inject compare)
+       (match expr
+         [(_ body ...)
+          (foldr (lambda (binding acc)
+                   (match binding
+                     [(var stx expr)
+                      (if (and (symbol? stx) (compare stx (inject '<-)))
+                          `(>>= ,expr (lambda (,var) ,acc))
+                          `(>>= ,binding (lambda (_) ,acc)))]
+                     [(let-stx var =-stx expr)
+                      (cond ((and (symbol? let-stx) (compare let-stx (inject 'let))
+                                  (symbol? =-stx) (compare =-stx (inject '=)))
+                             `((lambda (,var) ,acc) ,expr))
+                            (else
+                             `(>>= ,binding (lambda (_) ,acc))))]
+                     [expr
+                      `(>>= ,expr (lambda (_) ,acc))]))
+                 (last body)
+                 (butlast body))])))))
diff --git a/algebraic-structs.monoid.list.base.scm b/algebraic-structs.monoid.list.base.scm
new file mode 100644
index 0000000..76190f5
--- /dev/null
+++ b/algebraic-structs.monoid.list.base.scm
@@ -0,0 +1,5 @@
+(module (algebraic-structs monoid list base) (op id)
+  (import scheme)
+
+  (define op append)
+  (define id '()))
diff --git a/algebraic-structs.monoid.list.scm b/algebraic-structs.monoid.list.scm
new file mode 100644
index 0000000..226fcd4
--- /dev/null
+++ b/algebraic-structs.monoid.list.scm
@@ -0,0 +1,5 @@
+(import (only (algebraic-structs monoid list base)))
+(import (only (algebraic-structs monoid make)))
+
+(module (algebraic-structs monoid list) = ((algebraic-structs monoid make)
+                                           (algebraic-structs monoid list base)))
diff --git a/algebraic-structs.monoid.make.fold.scm b/algebraic-structs.monoid.make.fold.scm
new file mode 100644
index 0000000..995bae5
--- /dev/null
+++ b/algebraic-structs.monoid.make.fold.scm
@@ -0,0 +1,4 @@
+(functor ((algebraic-structs monoid make fold) (M (op id)) (F (foldl foldr))) (fold)
+  (import scheme M F)
+
+  (define (fold x) (foldl op id x)))
diff --git a/algebraic-structs.monoid.make.scm b/algebraic-structs.monoid.make.scm
new file mode 100644
index 0000000..89945d7
--- /dev/null
+++ b/algebraic-structs.monoid.make.scm
@@ -0,0 +1,3 @@
+(functor ((algebraic-structs monoid make) (F (op id)))
+    (op id)
+  (import F))
diff --git a/algebraic-structs.monoid.number.product.base.scm b/algebraic-structs.monoid.number.product.base.scm
new file mode 100644
index 0000000..34677c0
--- /dev/null
+++ b/algebraic-structs.monoid.number.product.base.scm
@@ -0,0 +1,5 @@
+(module (algebraic-structs monoid number product base) (op id)
+  (import scheme)
+
+  (define op *)
+  (define id 1))
diff --git a/algebraic-structs.monoid.number.product.scm b/algebraic-structs.monoid.number.product.scm
new file mode 100644
index 0000000..1f1da6e
--- /dev/null
+++ b/algebraic-structs.monoid.number.product.scm
@@ -0,0 +1,5 @@
+(import (only (algebraic-structs monoid number product base)))
+(import (only (algebraic-structs monoid make)))
+
+(module (algebraic-structs monoid number product) = ((algebraic-structs monoid make)
+                                                     (algebraic-structs monoid number product base)))
diff --git a/algebraic-structs.monoid.number.sum.base.scm b/algebraic-structs.monoid.number.sum.base.scm
new file mode 100644
index 0000000..c38a9fc
--- /dev/null
+++ b/algebraic-structs.monoid.number.sum.base.scm
@@ -0,0 +1,5 @@
+(module (algebraic-structs monoid number sum base) (op id)
+  (import scheme)
+
+  (define op +)
+  (define id 0))
diff --git a/algebraic-structs.monoid.number.sum.scm b/algebraic-structs.monoid.number.sum.scm
new file mode 100644
index 0000000..eac1f08
--- /dev/null
+++ b/algebraic-structs.monoid.number.sum.scm
@@ -0,0 +1,5 @@
+(import (only (algebraic-structs monoid number sum base)))
+(import (only (algebraic-structs monoid make)))
+
+(module (algebraic-structs monoid number sum) = ((algebraic-structs monoid make)
+                                                 (algebraic-structs monoid number sum base)))
diff --git a/tests/run.scm b/tests/run.scm
new file mode 100644
index 0000000..45534d5
--- /dev/null
+++ b/tests/run.scm
@@ -0,0 +1,156 @@
+(import (chicken load) (test))
+
+(test-begin "algebraic-structs")
+
+(import (prefix (algebraic-structs monoid list) list:))
+
+(import (only (algebraic-structs monoid make fold)))
+(import (prefix (algebraic-structs foldable list) list:))
+(import (prefix (algebraic-structs foldable vector) vector:))
+(import (prefix (algebraic-structs monoid number sum) sum:))
+(import (prefix (algebraic-structs monoid number product) product:))
+
+(import (prefix (algebraic-structs functor list) list:))
+(import (prefix (algebraic-structs applicative list) list:))
+(import (prefix (algebraic-structs monad list) list:))
+(import (prefix (algebraic-structs alternative list) list:))
+
+(import (prefix (only (scheme) apply) list:))
+
+(test-begin "foldable")
+
+(test-begin "foldable.list")
+
+(test '(a b c d e) (list:foldr cons '() '(a b c d e)))
+(test '(((((() a) b) c) d) e) (list:foldl list '() '(a b c d e)))
+
+(test 0 (list:length '()))
+(test 5 (list:length '(a b c d e)))
+
+(test #f (list:find (constantly #t) '()))
+(test #f (list:find even? '(1 3 5 7)))
+(test 4 (list:find even? '(1 3 4 7 8)))
+
+(test #f (list:any (constantly #t) '()))
+(test #f (list:any (cut member 'x <>) '((a b c) (d e f))))
+(test '(x f) (list:any (cut member 'x <>) '((a b c) (d x f))))
+
+(test #t (list:every (constantly #f) '()))
+(test #f (list:every (cut member 'x <>) '((a b c) (d x f))))
+(test '(x f) (list:every (cut member 'x <>) '((a x c) (d x f))))
+
+
+(test '(a b c d e) (list:->list '(a b c d e)))
+
+(test-end "foldable.list")
+
+(test-begin "foldable.vector")
+
+(test '(a b c d e) (vector:foldr cons '() #(a b c d e)))
+(test '(((((() a) b) c) d) e) (vector:foldl list '() #(a b c d e)))
+
+(test 0 (vector:length #()))
+(test 5 (vector:length #(a b c d e)))
+
+(test #f (vector:find (constantly #t) #()))
+(test #f (vector:find even? #(1 3 5 7)))
+(test 4 (vector:find even? #(1 3 4 7 8)))
+
+(test #f (vector:any (constantly #t) #()))
+(test #f (vector:any (cut member 'x <>) #((a b c) (d e f))))
+(test '(x f) (vector:any (cut member 'x <>) #((a b c) (d x f))))
+
+(test #t (vector:every (constantly #f) #()))
+(test #f (vector:every (cut member 'x <>) #((a b c) (d x f))))
+(test '(x f) (vector:every (cut member 'x <>) #((a x c) (d x f))))
+
+(test '(a b c d e) (vector:->list #(a b c d e)))
+
+(test-end "foldable.vector")
+
+(test-end "foldable")
+
+(test-begin "monoid")
+
+(test-begin "monoid.list")
+
+(test '(a b c 1 2 3) (list:op '(a b c) '(1 2 3)))
+(test '(a b c x y z 1 2 3) (list:op (list:op '(a b c) '(x y z)) '(1 2 3)))
+(test '(a b c x y z 1 2 3) (list:op '(a b c) (list:op '(x y z) '(1 2 3))))
+
+(test-end "monoid.list")
+
+(test-begin "monoid.sum.fold.list")
+
+(module sum-fold = ((algebraic-structs monoid make fold)
+                    (algebraic-structs monoid number sum)
+                    (algebraic-structs foldable list)))
+(import (prefix sum-fold sum:))
+
+(test 15 (sum:fold '(1 2 3 4 5)))
+(test 0 (sum:fold '()))
+
+
+(test-end "monoid.sum.fold.list")
+
+(test-begin "monoid.product.fold.vector")
+
+(module product-fold = ((algebraic-structs monoid make fold)
+                    (algebraic-structs monoid number product)
+                    (algebraic-structs foldable vector)))
+(import (prefix product-fold product:))
+
+(test 120 (product:fold #(1 2 3 4 5)))
+(test 1 (product:fold #()))
+
+(test-end "monoid.product.fold.vector")
+
+(test-end "monoid")
+
+(test-begin "functor")
+
+(test '((a) (b) (c)) (list:map list '(a b c)))
+
+(test-end "functor")
+
+(test-begin "applicative")
+
+(test '(a) (list:pure 'a))
+
+(test '((a 1) (a 2) (b 1) (b 2) (c 1) (c 2))
+      (list:map2 list '(a b c) '(1 2)))
+
+(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 "monad")
+
+(test '((1 a) (2 a))
+      (list:>>= (list:pure 'a)
+                (lambda (x)
+                  (list (list 1 x)
+                        (list 2 x)))))
+
+(test '(210 330 350 550)
+      (list:do (x <- '(3 5))
+               (let y = 10)
+               (z <- '(7 11))
+               (list 2)
+               (list:pure (* x y z))))
+
+(test-end "monad")
+
+(test-begin "alternative")
+
+(test '(9 25)
+      (list:do (x <- '(2 3 4 5))
+               (list:guard (odd? x))
+               (list:pure (* x x))))
+
+(test-end "alternative")
+
+(test-end "algebraic-structs")
+
+(test-exit)
-- 
cgit v1.2.3