diff options
32 files changed, 591 insertions, 0 deletions
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 @@ -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) |