aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMasaya Tojo <masaya@tojo.tokyo>2024-06-16 15:14:13 +0900
committerMasaya Tojo <masaya@tojo.tokyo>2024-06-16 15:14:13 +0900
commitc2f4dde340185a4b42beacd46355f94ae41e25e4 (patch)
treebf269e4fa29a24422ddd34670efe03bd3f79d0f9
parentded31df310122b0252c69bff90b915c3e5b0ad20 (diff)
Add vector implementations
-rw-r--r--algebraic-structures.egg12
-rw-r--r--algebraic-structures.private.vector.scm27
-rw-r--r--algebraic-structures.private.vector.zip.applicative.scm11
-rw-r--r--algebraic-structures.vector.applicative.scm4
-rw-r--r--algebraic-structures.vector.foldable.scm3
-rw-r--r--algebraic-structures.vector.functor.scm3
-rw-r--r--algebraic-structures.vector.monoid.scm3
-rw-r--r--algebraic-structures.vector.reducible.scm3
-rw-r--r--algebraic-structures.vector.semigroup.scm3
-rw-r--r--algebraic-structures.vector.zip.applicative.scm4
-rw-r--r--tests/run.scm70
11 files changed, 142 insertions, 1 deletions
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:))