Add "conjoin" from chicken scheme
This commit is contained in:
parent
7e00aac988
commit
1e3191340c
16
d-.scm
16
d-.scm
@ -12,6 +12,7 @@
|
||||
argmin
|
||||
iterate
|
||||
upply
|
||||
conjoin
|
||||
distinct?
|
||||
generator
|
||||
macro-expand
|
||||
@ -69,18 +70,30 @@
|
||||
vals))
|
||||
|
||||
(define (iterate n f v)
|
||||
"Repeatedly call f on values returned from (f v)"
|
||||
(if (zero? n)
|
||||
v
|
||||
(iterate (1- n) f (f v))))
|
||||
|
||||
(define (upply a b cmp . fs)
|
||||
"U-shapped apply, apply fs to a and b as in compose, then apply cmp to both results"
|
||||
(let ([arm-f (apply compose fs)])
|
||||
(cmp (arm-f a) (arm-f b))))
|
||||
|
||||
(define (conjoin . preds)
|
||||
"Returns a procedure that applies each pred to a single value, and returns #t if all return a truthy value. With no preds returns a one arg function that always returns true"
|
||||
(if (null? preds)
|
||||
(lambda (x) #t)
|
||||
(lambda (x)
|
||||
(if ((car preds) x)
|
||||
((apply conjoin (cdr preds)) x)
|
||||
#f))))
|
||||
|
||||
(define (distinct? . a)
|
||||
"Are all values distinct, as in equal?"
|
||||
(if (or (null? a) (null? (cdr a)))
|
||||
#t
|
||||
(and (not (any (lambda (x) (eq? (car a) x)) (cdr a)))
|
||||
(and (not (any (lambda (x) (equal? (car a) x)) (cdr a)))
|
||||
(apply distinct? (cdr a)))))
|
||||
|
||||
;; Shamelessly ripped from https://wingolog.org/archives/2013/02/25/on-generators
|
||||
@ -96,6 +109,7 @@
|
||||
value))))
|
||||
|
||||
(define-syntax generator
|
||||
;; generator with an anaphoric yield
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
[(generator expr ...)
|
||||
|
7
test.scm
7
test.scm
@ -63,6 +63,13 @@
|
||||
(define value (upply -3 5 = abs 1-))
|
||||
(assert-equal #t value)))
|
||||
|
||||
(define-test-suite "conjoin"
|
||||
(define-test "test"
|
||||
(assert-equal #t ((conjoin negative? odd? rational?) -3))
|
||||
(assert-equal #f ((conjoin negative? odd? rational?) -4)))
|
||||
(define-test "vacuous"
|
||||
(assert-equal #t ((conjoin) '(some donkus)))))
|
||||
|
||||
(define-test-suite "generator"
|
||||
(define-test "test"
|
||||
(define number-generator
|
||||
|
Loading…
Reference in New Issue
Block a user