diff options
24 files changed, 157 insertions, 268 deletions
diff --git a/algebraic-structures.alternative.list.base.scm b/algebraic-structures.alternative.list.base.scm deleted file mode 100644 index 3d1dba4..0000000 --- a/algebraic-structures.alternative.list.base.scm +++ /dev/null @@ -1,8 +0,0 @@ -(module (algebraic-structures alternative list base) (pure map map2 alt empty) - (import (except scheme map apply) - (algebraic-structures applicative list)) - - (define (alt x y) - (append x y)) - - (define empty '())) diff --git a/algebraic-structures.alternative.list.scm b/algebraic-structures.alternative.list.scm deleted file mode 100644 index d258b9e..0000000 --- a/algebraic-structures.alternative.list.scm +++ /dev/null @@ -1,5 +0,0 @@ -(import (only (algebraic-structures alternative make))) -(import (only (algebraic-structures alternative list base))) - -(module (algebraic-structures alternative list) = - ((algebraic-structures alternative make) (algebraic-structures alternative list base))) diff --git a/algebraic-structures.applicative.list.base.scm b/algebraic-structures.applicative.list.base.scm deleted file mode 100644 index a8c04d5..0000000 --- a/algebraic-structures.applicative.list.base.scm +++ /dev/null @@ -1,29 +0,0 @@ -(module (algebraic-structures applicative list base) (map pure map2) - (import (except scheme map) - (algebraic-structures 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-structures.applicative.list.scm b/algebraic-structures.applicative.list.scm deleted file mode 100644 index 85298e9..0000000 --- a/algebraic-structures.applicative.list.scm +++ /dev/null @@ -1,5 +0,0 @@ -(import (only (algebraic-structures applicative make))) -(import (only (algebraic-structures applicative list base))) - -(module (algebraic-structures applicative list) = - ((algebraic-structures applicative make) (algebraic-structures applicative list base))) diff --git a/algebraic-structures.egg b/algebraic-structures.egg index bf62bd3..6d72bf1 100644 --- a/algebraic-structures.egg +++ b/algebraic-structures.egg @@ -9,33 +9,10 @@ (test-dependencies test) (components (extension algebraic-structures.monoid.make) - (extension algebraic-structures.monoid.list.base) - (extension algebraic-structures.monoid.list) - (extension algebraic-structures.monoid.number.sum.base) - (extension algebraic-structures.monoid.number.sum) - (extension algebraic-structures.monoid.number.product.base) - (extension algebraic-structures.monoid.number.product) (extension algebraic-structures.monoid.make.fold) (extension algebraic-structures.group.make) - (extension algebraic-structures.group.number.sum) - (extension algebraic-structures.group.number.product) (extension algebraic-structures.foldable.make) - (extension algebraic-structures.foldable.list.base) - (extension algebraic-structures.foldable.list) - (extension algebraic-structures.foldable.vector.base) - (extension algebraic-structures.foldable.vector) (extension algebraic-structures.functor.make) - (extension algebraic-structures.functor.list.base) - (extension algebraic-structures.functor.list) - (extension algebraic-structures.functor.vector.base) - (extension algebraic-structures.functor.vector) (extension algebraic-structures.applicative.make) - (extension algebraic-structures.applicative.list.base) - (extension algebraic-structures.applicative.list) (extension algebraic-structures.monad.make) - (extension algebraic-structures.monad.list.base) - (extension algebraic-structures.monad.list) - (extension algebraic-structures.monad.list) - (extension algebraic-structures.alternative.make) - (extension algebraic-structures.alternative.list.base) - (extension algebraic-structures.alternative.list))) + (extension algebraic-structures.alternative.make))) diff --git a/algebraic-structures.foldable.list.base.scm b/algebraic-structures.foldable.list.base.scm deleted file mode 100644 index 936f03f..0000000 --- a/algebraic-structures.foldable.list.base.scm +++ /dev/null @@ -1,2 +0,0 @@ -(module (algebraic-structures foldable list base) (foldl foldr) - (import (only (chicken base) foldl foldr))) diff --git a/algebraic-structures.foldable.list.scm b/algebraic-structures.foldable.list.scm deleted file mode 100644 index 378a4c2..0000000 --- a/algebraic-structures.foldable.list.scm +++ /dev/null @@ -1,5 +0,0 @@ -(import (only (algebraic-structures foldable list base))) -(import (only (algebraic-structures foldable make))) - -(module (algebraic-structures foldable list) = ((algebraic-structures foldable make) - (algebraic-structures foldable list base))) diff --git a/algebraic-structures.foldable.vector.base.scm b/algebraic-structures.foldable.vector.base.scm deleted file mode 100644 index 90d06da..0000000 --- a/algebraic-structures.foldable.vector.base.scm +++ /dev/null @@ -1,21 +0,0 @@ -(module (algebraic-structures 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-structures.foldable.vector.scm b/algebraic-structures.foldable.vector.scm deleted file mode 100644 index 7fa3886..0000000 --- a/algebraic-structures.foldable.vector.scm +++ /dev/null @@ -1,5 +0,0 @@ -(import (only (algebraic-structures foldable vector base))) -(import (only (algebraic-structures foldable make))) - -(module (algebraic-structures foldable vector) = ((algebraic-structures foldable make) - (algebraic-structures foldable vector base))) diff --git a/algebraic-structures.functor.list.base.scm b/algebraic-structures.functor.list.base.scm deleted file mode 100644 index a9ebb01..0000000 --- a/algebraic-structures.functor.list.base.scm +++ /dev/null @@ -1,4 +0,0 @@ -(module (algebraic-structures functor list base) (map) - (import (rename (scheme) (map list:map))) - - (define (map f lst) (list:map f lst))) diff --git a/algebraic-structures.functor.list.scm b/algebraic-structures.functor.list.scm deleted file mode 100644 index 569cc60..0000000 --- a/algebraic-structures.functor.list.scm +++ /dev/null @@ -1,5 +0,0 @@ -(import (only (algebraic-structures functor list base))) -(import (only (algebraic-structures functor make))) - -(module (algebraic-structures functor list) = ((algebraic-structures functor make) - (algebraic-structures functor list base))) diff --git a/algebraic-structures.functor.vector.base.scm b/algebraic-structures.functor.vector.base.scm deleted file mode 100644 index 1449ed6..0000000 --- a/algebraic-structures.functor.vector.base.scm +++ /dev/null @@ -1,10 +0,0 @@ -(module (algebraic-structures 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-structures.functor.vector.scm b/algebraic-structures.functor.vector.scm deleted file mode 100644 index 748afca..0000000 --- a/algebraic-structures.functor.vector.scm +++ /dev/null @@ -1,5 +0,0 @@ -(import (only (algebraic-structures functor vector base))) -(import (only (algebraic-structures functor make))) - -(module (algebraic-structures functor vector) = ((algebraic-structures functor make) - (algebraic-structures functor vector base))) diff --git a/algebraic-structures.group.number.product.scm b/algebraic-structures.group.number.product.scm deleted file mode 100644 index a57cdf6..0000000 --- a/algebraic-structures.group.number.product.scm +++ /dev/null @@ -1,8 +0,0 @@ -(import (only (algebraic-structures group make))) -(module (algebraic-structures group number product) = (algebraic-structures group make) - (import scheme - (chicken module) - (algebraic-structures monoid number product)) - (export <> unit inv) - - (define (inv x) (/ x))) diff --git a/algebraic-structures.group.number.sum.scm b/algebraic-structures.group.number.sum.scm deleted file mode 100644 index 2bb7331..0000000 --- a/algebraic-structures.group.number.sum.scm +++ /dev/null @@ -1,8 +0,0 @@ -(import (only (algebraic-structures group make))) -(module (algebraic-structures group number sum) = (algebraic-structures group make) - (import scheme - (chicken module) - (algebraic-structures monoid number sum)) - (export <> unit inv) - - (define (inv x) (- x))) diff --git a/algebraic-structures.monad.list.base.scm b/algebraic-structures.monad.list.base.scm deleted file mode 100644 index e6a36ad..0000000 --- a/algebraic-structures.monad.list.base.scm +++ /dev/null @@ -1,7 +0,0 @@ -(module (algebraic-structures monad list base) (pure map map2 >>=) - (import (except scheme map) - (algebraic-structures applicative list) - (only (srfi 1) append-map)) - - (define (>>= lst f) - (append-map f lst))) diff --git a/algebraic-structures.monad.list.scm b/algebraic-structures.monad.list.scm deleted file mode 100644 index 7292bd1..0000000 --- a/algebraic-structures.monad.list.scm +++ /dev/null @@ -1,5 +0,0 @@ -(import (only (algebraic-structures monad make))) -(import (only (algebraic-structures monad list base))) - -(module (algebraic-structures monad list) = - ((algebraic-structures monad make) (algebraic-structures monad list base))) diff --git a/algebraic-structures.monoid.list.base.scm b/algebraic-structures.monoid.list.base.scm deleted file mode 100644 index 900c12e..0000000 --- a/algebraic-structures.monoid.list.base.scm +++ /dev/null @@ -1,5 +0,0 @@ -(module (algebraic-structures monoid list base) (<> unit) - (import scheme) - - (define <> append) - (define unit '())) diff --git a/algebraic-structures.monoid.list.scm b/algebraic-structures.monoid.list.scm deleted file mode 100644 index b91eeb0..0000000 --- a/algebraic-structures.monoid.list.scm +++ /dev/null @@ -1,5 +0,0 @@ -(import (only (algebraic-structures monoid list base))) -(import (only (algebraic-structures monoid make))) - -(module (algebraic-structures monoid list) = ((algebraic-structures monoid make) - (algebraic-structures monoid list base))) diff --git a/algebraic-structures.monoid.number.product.base.scm b/algebraic-structures.monoid.number.product.base.scm deleted file mode 100644 index 796a6c9..0000000 --- a/algebraic-structures.monoid.number.product.base.scm +++ /dev/null @@ -1,5 +0,0 @@ -(module (algebraic-structures monoid number product base) (<> unit) - (import scheme) - - (define <> *) - (define unit 1)) diff --git a/algebraic-structures.monoid.number.product.scm b/algebraic-structures.monoid.number.product.scm deleted file mode 100644 index 225e0a1..0000000 --- a/algebraic-structures.monoid.number.product.scm +++ /dev/null @@ -1,5 +0,0 @@ -(import (only (algebraic-structures monoid number product base))) -(import (only (algebraic-structures monoid make))) - -(module (algebraic-structures monoid number product) = ((algebraic-structures monoid make) - (algebraic-structures monoid number product base))) diff --git a/algebraic-structures.monoid.number.sum.base.scm b/algebraic-structures.monoid.number.sum.base.scm deleted file mode 100644 index 6fb1c59..0000000 --- a/algebraic-structures.monoid.number.sum.base.scm +++ /dev/null @@ -1,5 +0,0 @@ -(module (algebraic-structures monoid number sum base) (<> unit) - (import scheme) - - (define <> +) - (define unit 0)) diff --git a/algebraic-structures.monoid.number.sum.scm b/algebraic-structures.monoid.number.sum.scm deleted file mode 100644 index 28e025c..0000000 --- a/algebraic-structures.monoid.number.sum.scm +++ /dev/null @@ -1,5 +0,0 @@ -(import (only (algebraic-structures monoid number sum base))) -(import (only (algebraic-structures monoid make))) - -(module (algebraic-structures monoid number sum) = ((algebraic-structures monoid make) - (algebraic-structures monoid number sum base))) diff --git a/tests/run.scm b/tests/run.scm index 6b6a74e..2a5c941 100644 --- a/tests/run.scm +++ b/tests/run.scm @@ -2,24 +2,78 @@ (test-begin "algebraic-structures") -(import (prefix (algebraic-structures monoid list) list:)) +(test-begin "monoid") + +(import (algebraic-structures monoid make)) + +(module (mod7 monoid) = (algebraic-structures monoid make) + (import scheme + (chicken module) + (chicken base)) + (export <> unit) + + (define (<> x y) + (assert (integer? x)) + (assert (integer? y)) + (assert (not (zero? x))) + (assert (not (zero? y))) + (modulo (* x y) 7)) + + (define unit 1)) + +(import (prefix (mod7 monoid) mod7:) + (srfi 1)) -(import (only (algebraic-structures monoid make fold))) -(import (prefix (algebraic-structures foldable list) list:)) -(import (prefix (algebraic-structures foldable vector) vector:)) -(import (prefix (algebraic-structures monoid number sum) sum:)) -(import (prefix (algebraic-structures monoid number product) product:)) +(test 5 (mod7:<> 3 4)) +(test 1 mod7:unit) -(import (prefix (algebraic-structures functor list) list:)) -(import (prefix (algebraic-structures applicative list) list:)) -(import (prefix (algebraic-structures monad list) list:)) -(import (prefix (algebraic-structures alternative list) list:)) +(test-end "monoid") + +(test-begin "group") -(import (prefix (only (scheme) apply) list:)) +(import (algebraic-structures group make)) +(module (mod7 group) = (algebraic-structures group make) + (import scheme + (chicken base) + (chicken module) + matchable) + (reexport (mod7 monoid)) + (export inv) + + (define (inv n) + (assert (integer? n)) + (assert (not (zero? n))) + (match (modulo n 7) + (1 1) + (2 4) + (3 5) + (4 2) + (5 3) + (6 6)))) + +(import (prefix (mod7 group) mod7:)) + +(test (make-list 6 mod7:unit) + (map mod7:<> + '(1 2 3 4 5 6) + (map mod7:inv '(1 2 3 4 5 6)))) + +(test '(3 2 6 4 5 1) + (map (cut mod7:pow 3 <>) '(1 2 3 4 5 6))) + +(test (mod7:inv 4) (mod7:pow 4 -1)) + +(test-end "group") (test-begin "foldable") -(test-begin "foldable.list") +(import (algebraic-structures foldable make)) + +(module (data list foldable) = (algebraic-structures foldable make) + (import (chicken module)) + (reexport (only (chicken base) foldl foldr))) + +(import (prefix (data list 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))) @@ -39,88 +93,43 @@ (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:<> '(a b c) '(1 2 3))) -(test '(a b c x y z 1 2 3) (list:<> (list:<> '(a b c) '(x y z)) '(1 2 3))) -(test '(a b c x y z 1 2 3) (list:<> '(a b c) (list:<> '(x y z) '(1 2 3)))) - -(test-end "monoid.list") - -(test-begin "monoid.sum.fold.list") - -(module sum-fold = ((algebraic-structures monoid make fold) - (algebraic-structures monoid number sum) - (algebraic-structures foldable list))) -(import (prefix sum-fold sum:)) +(test-begin "monoid.fold") -(test 15 (sum:fold '(1 2 3 4 5))) -(test 0 (sum:fold '())) +(module (product monoid) = (algebraic-structures monoid make) + (import scheme + (chicken base) + (chicken module)) + (export <> unit) + (define (<> x y) + (assert (number? x)) + (assert (not (zero? x))) + (assert (number? y)) + (assert (not (zero? y))) + (* x y)) -(test-end "monoid.sum.fold.list") + (define unit 1)) -(test-begin "monoid.product.fold.vector") +(import (algebraic-structures monoid make fold)) +(module (product fold) = ((algebraic-structures monoid make fold) (product monoid) (data list foldable))) -(module product-fold = ((algebraic-structures monoid make fold) - (algebraic-structures monoid number product) - (algebraic-structures 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 "group") +(import (prefix (product monoid) product:)) +(import (prefix (product fold) product:)) -(import (prefix (algebraic-structures group number product) product:)) -(import (prefix (algebraic-structures group number sum) sum:)) +(test 120 (product:fold '(1 2 3 4 5))) -(test -9 (sum:inv 9)) -(test 9 (sum:pow 3 3)) +(test-end "monoid.fold") -(test 1/9 (product:inv 9)) -(test 9 (product:pow 3 2)) +(test-begin "functor") -(test-end "group") +(import (algebraic-structures functor make)) +(module (data list functor) = (algebraic-structures functor make) + (import scheme (chicken module)) + (export map)) -(test-begin "functor") +(import (prefix (data list functor) list:)) (test '((a) (b) (c)) (list:map list '(a b c))) @@ -128,6 +137,42 @@ (test-begin "applicative") +(import (algebraic-structures applicative make)) +(module (data list applicative) = (algebraic-structures applicative make) + (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:)) + (test '(a) (list:pure 'a)) (test '((a 1) (a 2) (b 1) (b 2) (c 1) (c 2)) @@ -140,6 +185,19 @@ (test-begin "monad") +(import (algebraic-structures monad make)) +(module (data list monad) = (algebraic-structures monad make) + (import (except scheme map) + (chicken module) + (srfi 1)) + (reexport (data list applicative)) + (export >>=) + + (define (>>= lst f) + (append-map f lst))) + +(import (prefix (data list monad) list:)) + (test '((1 a) (2 a)) (list:>>= (list:pure 'a) (lambda (x) @@ -157,6 +215,22 @@ (test-begin "alternative") +(import (algebraic-structures alternative make)) +(module (data list alternative) = (algebraic-structures alternative make) + (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:)) + (test '(9 25) (list:do (x <- '(2 3 4 5)) (list:guard (odd? x)) |