From c2f4dde340185a4b42beacd46355f94ae41e25e4 Mon Sep 17 00:00:00 2001
From: Masaya Tojo <masaya@tojo.tokyo>
Date: Sun, 16 Jun 2024 15:14:13 +0900
Subject: Add vector implementations

---
 algebraic-structures.egg                           | 12 +++-
 algebraic-structures.private.vector.scm            | 27 +++++++++
 ...c-structures.private.vector.zip.applicative.scm | 11 ++++
 algebraic-structures.vector.applicative.scm        |  4 ++
 algebraic-structures.vector.foldable.scm           |  3 +
 algebraic-structures.vector.functor.scm            |  3 +
 algebraic-structures.vector.monoid.scm             |  3 +
 algebraic-structures.vector.reducible.scm          |  3 +
 algebraic-structures.vector.semigroup.scm          |  3 +
 algebraic-structures.vector.zip.applicative.scm    |  4 ++
 tests/run.scm                                      | 70 ++++++++++++++++++++++
 11 files changed, 142 insertions(+), 1 deletion(-)
 create mode 100644 algebraic-structures.private.vector.scm
 create mode 100644 algebraic-structures.private.vector.zip.applicative.scm
 create mode 100644 algebraic-structures.vector.applicative.scm
 create mode 100644 algebraic-structures.vector.foldable.scm
 create mode 100644 algebraic-structures.vector.functor.scm
 create mode 100644 algebraic-structures.vector.monoid.scm
 create mode 100644 algebraic-structures.vector.reducible.scm
 create mode 100644 algebraic-structures.vector.semigroup.scm
 create mode 100644 algebraic-structures.vector.zip.applicative.scm

diff --git a/algebraic-structures.egg b/algebraic-structures.egg
index 43a8c2d..7325c7e 100644
--- a/algebraic-structures.egg
+++ b/algebraic-structures.egg
@@ -5,7 +5,7 @@
  (license "BSD")
  (category data)
  (version "0.1.0")
- (dependencies matchable srfi-41)
+ (dependencies matchable srfi-41 srfi-133)
  (test-dependencies test)
  (components
   (extension algebraic-structures.semigroup)
@@ -36,6 +36,16 @@
   (extension algebraic-structures.private.list.alternative)
   (extension algebraic-structures.list.alternative)
 
+  ;; Vector
+  (extension algebraic-structures.private.vector)
+  (extension algebraic-structures.vector.semigroup)
+  (extension algebraic-structures.vector.monoid)
+  (extension algebraic-structures.vector.foldable)
+  (extension algebraic-structures.vector.reducible)
+  (extension algebraic-structures.vector.functor)
+  (extension algebraic-structures.private.vector.zip.applicative)
+  (extension algebraic-structures.vector.zip.applicative)
+
   ;; Stream
   (extension algebraic-structures.private.stream)
   (extension algebraic-structures.stream.semigroup)
diff --git a/algebraic-structures.private.vector.scm b/algebraic-structures.private.vector.scm
new file mode 100644
index 0000000..c9deb22
--- /dev/null
+++ b/algebraic-structures.private.vector.scm
@@ -0,0 +1,27 @@
+(module (algebraic-structures private vector) (<> unit fold reduce map1)
+  (import (except scheme
+                  vector-fill! vector->list list->vector)
+          (only (chicken base) add1 assert)
+          (srfi 133))
+
+  (define (<> xs ys) (vector-append xs ys))
+
+  (define unit #())
+
+  (define (fold f z v)
+    (vector-fold (lambda (x y) (f y x))
+                 z
+                 v))
+
+  (define (reduce f v)
+    (assert (not (zero? (vector-length v))))
+    (let ((len (vector-length v)))
+      (let loop ((i 1)
+                 (acc (vector-ref v 0)))
+        (if (= i len)
+            acc
+            (loop (add1 i)
+                  (f (vector-ref v i) acc))))))
+
+  (define (map1 f v)
+    (vector-map f v)))
diff --git a/algebraic-structures.private.vector.zip.applicative.scm b/algebraic-structures.private.vector.zip.applicative.scm
new file mode 100644
index 0000000..5e644e0
--- /dev/null
+++ b/algebraic-structures.private.vector.zip.applicative.scm
@@ -0,0 +1,11 @@
+(module (algebraic-structures private vector zip applicative) ()
+  (import scheme
+          (chicken module)
+          (only (srfi 133) vector-map))
+  (export pure map2)
+  (reexport (algebraic-structures vector functor))
+
+  (define (pure x) (vector x))
+
+  (define (map2 f xs ys)
+    (vector-map f xs ys)))
diff --git a/algebraic-structures.vector.applicative.scm b/algebraic-structures.vector.applicative.scm
new file mode 100644
index 0000000..5cf27c2
--- /dev/null
+++ b/algebraic-structures.vector.applicative.scm
@@ -0,0 +1,4 @@
+(import (algebraic-structures applicative)
+        (only (algebraic-structures private vector applicative)))
+(module (algebraic-structures vector applicative) = ((algebraic-structures applicative)
+                                                     (algebraic-structures private vector applicative)))
diff --git a/algebraic-structures.vector.foldable.scm b/algebraic-structures.vector.foldable.scm
new file mode 100644
index 0000000..aa77afa
--- /dev/null
+++ b/algebraic-structures.vector.foldable.scm
@@ -0,0 +1,3 @@
+(import (algebraic-structures foldable)
+        (only (algebraic-structures private vector)))
+(module (algebraic-structures vector foldable) = ((algebraic-structures foldable) (algebraic-structures private vector)))
diff --git a/algebraic-structures.vector.functor.scm b/algebraic-structures.vector.functor.scm
new file mode 100644
index 0000000..3c4a310
--- /dev/null
+++ b/algebraic-structures.vector.functor.scm
@@ -0,0 +1,3 @@
+(import (algebraic-structures functor)
+        (only (algebraic-structures private vector)))
+(module (algebraic-structures vector functor) = ((algebraic-structures functor) (algebraic-structures private vector)))
diff --git a/algebraic-structures.vector.monoid.scm b/algebraic-structures.vector.monoid.scm
new file mode 100644
index 0000000..6699b8e
--- /dev/null
+++ b/algebraic-structures.vector.monoid.scm
@@ -0,0 +1,3 @@
+(import (algebraic-structures monoid)
+        (only (algebraic-structures private vector)))
+(module (algebraic-structures vector monoid) = ((algebraic-structures monoid) (algebraic-structures private vector)))
diff --git a/algebraic-structures.vector.reducible.scm b/algebraic-structures.vector.reducible.scm
new file mode 100644
index 0000000..d2e3638
--- /dev/null
+++ b/algebraic-structures.vector.reducible.scm
@@ -0,0 +1,3 @@
+(import (algebraic-structures reducible)
+        (only (algebraic-structures private vector)))
+(module (algebraic-structures vector reducible) = ((algebraic-structures reducible) (algebraic-structures private vector)))
diff --git a/algebraic-structures.vector.semigroup.scm b/algebraic-structures.vector.semigroup.scm
new file mode 100644
index 0000000..39dfcd6
--- /dev/null
+++ b/algebraic-structures.vector.semigroup.scm
@@ -0,0 +1,3 @@
+(import (algebraic-structures semigroup)
+        (only (algebraic-structures private vector)))
+(module (algebraic-structures vector semigroup) = ((algebraic-structures semigroup) (algebraic-structures private vector)))
diff --git a/algebraic-structures.vector.zip.applicative.scm b/algebraic-structures.vector.zip.applicative.scm
new file mode 100644
index 0000000..ea1b9a3
--- /dev/null
+++ b/algebraic-structures.vector.zip.applicative.scm
@@ -0,0 +1,4 @@
+(import (algebraic-structures applicative)
+        (only (algebraic-structures private vector zip applicative)))
+(module (algebraic-structures vector zip applicative) = ((algebraic-structures applicative)
+                                                         (algebraic-structures private vector zip applicative)))
diff --git a/tests/run.scm b/tests/run.scm
index 4005ef7..bcebd31 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -32,6 +32,13 @@
 
 (test-end "list")
 
+(test-begin "vector")
+
+(import (prefix (algebraic-structures vector semigroup) vector:))
+(test #(a b c) (vector:<> #(a b) #(c)))
+
+(test-end "vector")
+
 (test-begin "stream")
 
 (import (prefix (algebraic-structures stream semigroup) stream:))
@@ -66,6 +73,13 @@
 
 (test-end "list")
 
+(test-begin "vector")
+
+(import (prefix (algebraic-structures vector monoid) vector:))
+(test #() (begin vector:unit))
+
+(test-end "vector")
+
 (test-begin "stream")
 
 (import (prefix (algebraic-structures stream monoid) stream:))
@@ -136,6 +150,33 @@
 (test #t (list:member? 'c '(a b c) eq?))
 (test #f (list:member? 'c '(a b) eq?))
 
+(test-begin "vector")
+
+(import (prefix (algebraic-structures vector foldable) vector:))
+
+(test '(e d c b a) (vector:fold cons '() #(a b c d e)))
+
+(test 0 (vector:length #()))
+(test 5 (vector:length #(a b c d e)))
+
+(test 0 (vector:count even? #(1 3 5 7)))
+(test 2 (vector:count even? #(1 3 4 7 8)))
+
+(test #f (vector:any (constantly #t) #()))
+(test #f (vector:any (cut member 'x <>) (vector '(a b c) '(d e f))))
+(test '(x f) (vector:any (cut member 'x <>) (vector '(a b c) '(d x f))))
+
+(test #t (vector:every (constantly #f) #()))
+(test #f (vector:every (cut member 'x <>) (vector '(a b c) '(d x f))))
+(test '(x f) (vector:every (cut member 'x <>) (vector '(a x c) '(d x f))))
+
+(test #t (vector:member? 3 #(1 3 7 5) =))
+(test #f (vector:member? 3 #(1 7 5) =))
+(test #t (vector:member? 'c #(a b c) eq?))
+(test #f (vector:member? 'c #(a b) eq?))
+
+(test-end "vector")
+
 (test-begin "stream")
 
 (import (prefix (algebraic-structures stream foldable) stream:))
@@ -177,6 +218,16 @@
 (test -3 (list:minimum '(1 8 -3 5 4) <))
 (test 8 (list:maximum '(1 8 -3 5 4) <))
 
+(test-begin "vector")
+
+(import (prefix (algebraic-structures vector reducible) vector:))
+
+(test 10 (vector:reduce + #(1 2 3 4)))
+(test -3 (vector:minimum #(1 8 -3 5 4) <))
+(test 8 (vector:maximum #(1 8 -3 5 4) <))
+
+(test-end "vector")
+
 (test-begin "stream")
 
 (import (prefix (algebraic-structures stream reducible) stream:))
@@ -256,6 +307,14 @@
 
 (test '((a) (b) (c)) (list:map1 list '(a b c)))
 
+(test-begin "vector")
+
+(import (prefix (algebraic-structures vector functor) vector:))
+
+(test (vector '(a) '(b) '(c)) (vector:map1 list (vector 'a 'b 'c)))
+
+(test-end "vector")
+
 (test-begin "stream")
 
 (import (prefix (algebraic-structures stream functor) stream:))
@@ -308,6 +367,17 @@
 
 (test-end "list.zip")
 
+(test-begin "vector.zip")
+
+(import (prefix (algebraic-structures vector zip applicative) vector-zip:))
+
+(test #(a) (vector-zip:pure 'a))
+
+(test (vector '(a 1) '(b 2))
+      (vector-zip:map2 list #(a b c) #(1 2)))
+
+(test-end "vector.zip")
+
 (test-begin "stream.zip")
 
 (import (prefix (algebraic-structures stream zip applicative) stream-zip:))
-- 
cgit v1.2.3