From 3ab48119dd91fc26fd34c9964538027fa22b460d Mon Sep 17 00:00:00 2001
From: Masaya Tojo <masaya@tojo.tokyo>
Date: Sat, 15 Jun 2024 03:45:15 +0900
Subject: Add reducible

---
 algebraic-structures.egg                  |  2 ++
 algebraic-structures.reducible.scm        | 20 ++++++++++++++
 algebraic-structures.semigroup.reduce.scm |  4 +++
 tests/run.scm                             | 43 +++++++++++++++++++++++++++++++
 4 files changed, 69 insertions(+)
 create mode 100644 algebraic-structures.reducible.scm
 create mode 100644 algebraic-structures.semigroup.reduce.scm

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