Compare commits
No commits in common. "1e3191340c3b870a22a5e6805a4945ccd93200af" and "5b69379de159e0f612e41777416bafff301fcc06" have entirely different histories.
1e3191340c
...
5b69379de1
20
d-.scm
20
d-.scm
@ -6,13 +6,13 @@
|
|||||||
~>>
|
~>>
|
||||||
as~>
|
as~>
|
||||||
if-not
|
if-not
|
||||||
|
when-not
|
||||||
if-let
|
if-let
|
||||||
for
|
for
|
||||||
partial
|
partial
|
||||||
argmin
|
argmin
|
||||||
iterate
|
iterate
|
||||||
upply
|
upply
|
||||||
conjoin
|
|
||||||
distinct?
|
distinct?
|
||||||
generator
|
generator
|
||||||
macro-expand
|
macro-expand
|
||||||
@ -42,6 +42,9 @@
|
|||||||
(define-syntax-rule (if-not pred body ...)
|
(define-syntax-rule (if-not pred body ...)
|
||||||
(if (not pred) body ...))
|
(if (not pred) body ...))
|
||||||
|
|
||||||
|
(define-syntax-rule (when-not pred body ...)
|
||||||
|
(when (not pred) body ...))
|
||||||
|
|
||||||
(define-syntax-rule (if-let ([ident test]) expr ...)
|
(define-syntax-rule (if-let ([ident test]) expr ...)
|
||||||
(let ([ident test])
|
(let ([ident test])
|
||||||
(if ident
|
(if ident
|
||||||
@ -70,30 +73,18 @@
|
|||||||
vals))
|
vals))
|
||||||
|
|
||||||
(define (iterate n f v)
|
(define (iterate n f v)
|
||||||
"Repeatedly call f on values returned from (f v)"
|
|
||||||
(if (zero? n)
|
(if (zero? n)
|
||||||
v
|
v
|
||||||
(iterate (1- n) f (f v))))
|
(iterate (1- n) f (f v))))
|
||||||
|
|
||||||
(define (upply a b cmp . fs)
|
(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)])
|
(let ([arm-f (apply compose fs)])
|
||||||
(cmp (arm-f a) (arm-f b))))
|
(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)
|
(define (distinct? . a)
|
||||||
"Are all values distinct, as in equal?"
|
|
||||||
(if (or (null? a) (null? (cdr a)))
|
(if (or (null? a) (null? (cdr a)))
|
||||||
#t
|
#t
|
||||||
(and (not (any (lambda (x) (equal? (car a) x)) (cdr a)))
|
(and (not (any (lambda (x) (eq? (car a) x)) (cdr a)))
|
||||||
(apply distinct? (cdr a)))))
|
(apply distinct? (cdr a)))))
|
||||||
|
|
||||||
;; Shamelessly ripped from https://wingolog.org/archives/2013/02/25/on-generators
|
;; Shamelessly ripped from https://wingolog.org/archives/2013/02/25/on-generators
|
||||||
@ -109,7 +100,6 @@
|
|||||||
value))))
|
value))))
|
||||||
|
|
||||||
(define-syntax generator
|
(define-syntax generator
|
||||||
;; generator with an anaphoric yield
|
|
||||||
(lambda (x)
|
(lambda (x)
|
||||||
(syntax-case x ()
|
(syntax-case x ()
|
||||||
[(generator expr ...)
|
[(generator expr ...)
|
||||||
|
13
test.scm
13
test.scm
@ -30,6 +30,12 @@
|
|||||||
(define-test "test"
|
(define-test "test"
|
||||||
(assert-equal 'a (if-not #f 'a 'b))))
|
(assert-equal 'a (if-not #f 'a 'b))))
|
||||||
|
|
||||||
|
(define-test-suite "when-not"
|
||||||
|
(define-test "positive-case"
|
||||||
|
(assert-equal 'return (when-not #f 'do-some-stuff 'return)))
|
||||||
|
(define-test "negative-case"
|
||||||
|
(assert-unspecified (when-not #t 'do-some-stuff 'return))))
|
||||||
|
|
||||||
(define-test-suite "for"
|
(define-test-suite "for"
|
||||||
(define-test "permutation"
|
(define-test "permutation"
|
||||||
(define value (for ([i (iota 2)]
|
(define value (for ([i (iota 2)]
|
||||||
@ -63,13 +69,6 @@
|
|||||||
(define value (upply -3 5 = abs 1-))
|
(define value (upply -3 5 = abs 1-))
|
||||||
(assert-equal #t value)))
|
(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-suite "generator"
|
||||||
(define-test "test"
|
(define-test "test"
|
||||||
(define number-generator
|
(define number-generator
|
||||||
|
Loading…
Reference in New Issue
Block a user