aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--algebraic-structures.foldable.scm54
-rw-r--r--algebraic-structures.monoid.fold.scm12
-rw-r--r--tests/run.scm10
3 files changed, 40 insertions, 36 deletions
diff --git a/algebraic-structures.foldable.scm b/algebraic-structures.foldable.scm
index 3ab1f6e..be3d615 100644
--- a/algebraic-structures.foldable.scm
+++ b/algebraic-structures.foldable.scm
@@ -1,39 +1,39 @@
-(functor ((algebraic-structures foldable) (F (foldl foldr)))
- (foldl foldr length find any every ->list)
- (import (except scheme length) F
+(functor ((algebraic-structures foldable) (F (fold)))
+ (fold
+ length
+ count
+ any
+ every)
+ (import (except scheme length)
+ F
(only (chicken base) add1 call/cc))
(define (length xs)
- (foldl (lambda (acc _) (add1 acc))
- 0
- xs))
+ (fold (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 (count p? xs)
+ (fold (lambda (e acc)
+ (if (p? e)
+ (add1 acc)
+ acc))
+ 0
+ xs))
(define (any pred xs)
(call/cc
(lambda (return)
- (foldl (lambda (acc e)
- (cond ((pred e) => return)
- (else acc)))
- #f
- xs))))
+ (fold (lambda (e acc)
+ (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)))
+ (fold (lambda (e acc)
+ (or (pred e) (return #f)))
+ #t
+ xs)))))
diff --git a/algebraic-structures.monoid.fold.scm b/algebraic-structures.monoid.fold.scm
index b18c03c..5e176f2 100644
--- a/algebraic-structures.monoid.fold.scm
+++ b/algebraic-structures.monoid.fold.scm
@@ -1,4 +1,10 @@
-(functor ((algebraic-structures monoid fold) (M (<> unit)) (F (foldl foldr))) (fold)
- (import scheme M F)
+(functor ((algebraic-structures monoid fold) (M (<> unit)) (F (fold))) (fold)
+ (import scheme M (rename F (fold foldable:fold)))
- (define (fold x) (foldl <> unit x)))
+ (define (fold x) (foldable:fold <> unit x))
+
+ (define (fold-map f x)
+ (foldable:fold (lambda (x acc)
+ (<> (f x) acc))
+ unit
+ x)))
diff --git a/tests/run.scm b/tests/run.scm
index b49db8e..8d78396 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -71,19 +71,17 @@
(module (data list foldable) = (algebraic-structures foldable)
(import (chicken module))
- (reexport (only (chicken base) foldl foldr)))
+ (reexport (only (srfi 1) fold)))
(import (prefix (data list foldable) list:))
-(test '(a b c d e) (list:foldr cons '() '(a b c d e)))
-(test '(((((() a) b) c) d) e) (list:foldl list '() '(a b c d e)))
+(test '(e d c b a) (list:fold cons '() '(a b c d e)))
(test 0 (list:length '()))
(test 5 (list:length '(a b c d e)))
-(test #f (list:find (constantly #t) '()))
-(test #f (list:find even? '(1 3 5 7)))
-(test 4 (list:find even? '(1 3 4 7 8)))
+(test 0 (list:count even? '(1 3 5 7)))
+(test 2 (list:count even? '(1 3 4 7 8)))
(test #f (list:any (constantly #t) '()))
(test #f (list:any (cut member 'x <>) '((a b c) (d e f))))