From 92eeab2815eae6cd9ef22530d2e50fe0a620ec46 Mon Sep 17 00:00:00 2001
From: Masaya Tojo <masaya@tojo.tokyo>
Date: Sun, 9 Jun 2024 05:13:44 +0900
Subject: Initial commit

---
 algebraic-structs.foldable.make.scm | 39 +++++++++++++++++++++++++++++++++++++
 1 file changed, 39 insertions(+)
 create mode 100644 algebraic-structs.foldable.make.scm

(limited to 'algebraic-structs.foldable.make.scm')

diff --git a/algebraic-structs.foldable.make.scm b/algebraic-structs.foldable.make.scm
new file mode 100644
index 0000000..46b4dd5
--- /dev/null
+++ b/algebraic-structs.foldable.make.scm
@@ -0,0 +1,39 @@
+(functor ((algebraic-structs foldable make) (F (foldl foldr)))
+    (foldl foldr length find any every ->list)
+  (import (except scheme length) F
+          (only (chicken base) add1 call/cc))
+
+  (define (length xs)
+    (foldl (lambda (acc _) (add1 acc))
+           0
+           xs))
+
+  (define (find p? xs)
+    (call/cc
+     (lambda (k)
+       (foldl (lambda (acc e)
+                (if (p? e)
+                    (k e)
+                    acc))
+              #f
+              xs))))
+
+  (define (any pred xs)
+    (call/cc
+     (lambda (return)
+       (foldl (lambda (acc e)
+                (cond ((pred e) => return)
+                      (else acc)))
+              #f
+              xs))))
+
+  (define (every pred xs)
+    (call/cc
+     (lambda (return)
+       (foldl (lambda (acc e)
+                (or (pred e) (return #f)))
+              #t
+              xs))))
+
+  (define (->list xs)
+    (foldr cons '() xs)))
-- 
cgit v1.2.3