aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMasaya Tojo <masaya@tojo.tokyo>2024-06-15 03:45:15 +0900
committerMasaya Tojo <masaya@tojo.tokyo>2024-06-15 03:45:15 +0900
commit3ab48119dd91fc26fd34c9964538027fa22b460d (patch)
tree787203069d9a3262e8d59c3a84d217a8019d0777
parent9080b0a664ab36bf271fe042e3dc446727b18eff (diff)
Add reducible
-rw-r--r--algebraic-structures.egg2
-rw-r--r--algebraic-structures.reducible.scm20
-rw-r--r--algebraic-structures.semigroup.reduce.scm4
-rw-r--r--tests/run.scm43
4 files changed, 69 insertions, 0 deletions
diff --git a/algebraic-structures.egg b/algebraic-structures.egg
index ba71745..ba4fd46 100644
--- a/algebraic-structures.egg
+++ b/algebraic-structures.egg
@@ -9,9 +9,11 @@
(test-dependencies test)
(components
(extension algebraic-structures.semigroup)
+ (extension algebraic-structures.semigroup.reduce)
(extension algebraic-structures.monoid)
(extension algebraic-structures.monoid.fold)
(extension algebraic-structures.group)
+ (extension algebraic-structures.reducible)
(extension algebraic-structures.foldable)
(extension algebraic-structures.functor)
(extension algebraic-structures.applicative)
diff --git a/algebraic-structures.reducible.scm b/algebraic-structures.reducible.scm
new file mode 100644
index 0000000..ce9d1b3
--- /dev/null
+++ b/algebraic-structures.reducible.scm
@@ -0,0 +1,20 @@
+(functor ((algebraic-structures reducible) (R (reduce)))
+ (reduce
+ maximum
+ minimum)
+ (import scheme
+ R)
+
+ (define (minimum xs less?)
+ (reduce (lambda (e acc)
+ (if (less? e acc)
+ e
+ acc))
+ xs))
+
+ (define (maximum xs less?)
+ (reduce (lambda (e acc)
+ (if (less? e acc)
+ acc
+ e))
+ xs)))
diff --git a/algebraic-structures.semigroup.reduce.scm b/algebraic-structures.semigroup.reduce.scm
new file mode 100644
index 0000000..f5340e7
--- /dev/null
+++ b/algebraic-structures.semigroup.reduce.scm
@@ -0,0 +1,4 @@
+(functor ((algebraic-structures semigroup reduce) (S (<>)) (R (reduce))) (reduce)
+ (import scheme S (rename R (reduce reducible:reduce)))
+
+ (define (reduce xs) (reducible:reduce <> xs)))
diff --git a/tests/run.scm b/tests/run.scm
index 4b2b885..8195ea8 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -114,6 +114,49 @@
(test-end "foldable")
+(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:))
+
+(test 10 (list:reduce + '(1 2 3 4)))
+(test -3 (list:minimum '(1 8 -3 5 4) <))
+(test 8 (list:maximum '(1 8 -3 5 4) <))
+
+(test-end "reducible")
+
+(test-begin "semigroup.reducible")
+
+(module (sum semigroup) = (algebraic-structures semigroup)
+ (import scheme
+ (chicken base)
+ (chicken module))
+ (export <>)
+
+ (define (<> x y)
+ (+ x y)))
+
+(import (algebraic-structures semigroup reduce))
+(module (sum reduce) = ((algebraic-structures semigroup reduce) (sum semigroup) (data list reducible)))
+
+(import (prefix (sum reduce) sum:))
+
+(test 3 (sum:reduce '(1 2)))
+
+(test-end "semigroup.reducible")
+
(test-begin "monoid.fold")
(module (product semigroup) = (algebraic-structures semigroup)