From 653b204b583da363a97464960a00f1bd0dbed865 Mon Sep 17 00:00:00 2001
From: Masaya Tojo <masaya@tojo.tokyo>
Date: Thu, 13 Jun 2024 02:07:46 +0900
Subject: Remove implementations

---
 tests/run.scm | 238 ++++++++++++++++++++++++++++++++++++++--------------------
 1 file changed, 156 insertions(+), 82 deletions(-)

(limited to 'tests')

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