diff options
-rw-r--r-- | algebraic-structures.foldable.scm | 54 | ||||
-rw-r--r-- | algebraic-structures.monoid.fold.scm | 12 | ||||
-rw-r--r-- | tests/run.scm | 10 |
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)))) |