dane/d-
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Whitespace cleanup

Browse Source
This commit is contained in:
Dane Johnson 2025-01-03 10:28:27 -06:00
parent ec07a4e2ea
commit 337ddf8396
3 changed files with 61 additions and 61 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

50
d-.scm
View File

@ -45,8 +45,8 @@
(define-syntax-rule (if-let ([ident test]) expr ...)
(let ([ident test])
(if ident
(begin expr ...)
#f)))
(begin expr ...)
#f)))
(define-syntax for
(syntax-rules ()
@ -54,20 +54,20 @@
[(for ([ident lst] bindings ...) expr ...)
(let iter ([rest lst])
(if (pair? rest)
(let ([ident (car rest)])
(append (for (bindings ...) expr ...) (iter (cdr rest))))
'()))]))
(let ([ident (car rest)])
(append (for (bindings ...) expr ...) (iter (cdr rest))))
'()))]))
(define (partial fn . args)
(lambda x (apply fn (append args x))))
(define (argmin arg lt? . vals)
(reduce (lambda (val min)
(if (lt? (arg val) (arg min))
val
min))
#f
vals))
(if (lt? (arg val) (arg min))
val
min))
#f
vals))
(define (iterate n f v)
"Repeatedly call f on values returned from (f v)"
@ -85,16 +85,16 @@
(if (null? preds)
(lambda (x) #t)
(lambda (x)
(if ((car preds) x)
((apply conjoin (cdr preds)) x)
#f))))
(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) (equal? (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
(define (make-generator f)
@ -105,8 +105,8 @@
(call-with-prompt tag
thunk
(lambda (k value)
(set! thunk k)
value))))
(set! thunk k)
value))))
(define-syntax generator
;; generator with an anaphoric yield
@ -114,9 +114,9 @@
(syntax-case x ()
[(generator expr ...)
(with-syntax ([yield (datum->syntax x 'yield)])
#'(make-generator
(lambda (yield)
expr ...)))])))
#'(make-generator
(lambda (yield)
expr ...)))])))
;; Why wasn't this included?
(define macro-expand (compose tree-il->scheme macroexpand))
@ -131,12 +131,12 @@
[(amb a b ...)
(let ([fail0 *fail*])
(call/cc
(lambda (cc)
(set! *fail*
(lambda ()
(set! *fail* fail0)
(cc (amb b ...))))
(cc a))))]))
(lambda (cc)
(set! *fail*
(lambda ()
(set! *fail* fail0)
(cc (amb b ...))))
(cc a))))]))
(define (amb-reset)
;; Shouldn't be necessary, but prompts are hard and I'm dumb dumb dummy
(set! *fail* (lambda () (error "Could not satisfy amb"))))

40
d-/test.scm
View File

@ -13,25 +13,25 @@
(lambda (stx)
(with-syntax ([fail (datum->syntax stx 'fail)])
(define (assert-stx expr)
(syntax-case expr (assert-equal assert-not-equal)
[(assert-equal e a) #'(assert e a equal? fail)]
[(assert-not-equal e a) #'(assert e a (compose not equal?) fail)]
[(assert-unspecified v) #'(assert (when #f 'a) v eq? fail)]
[else #'else]))
(syntax-case expr (assert-equal assert-not-equal)
[(assert-equal e a) #'(assert e a equal? fail)]
[(assert-not-equal e a) #'(assert e a (compose not equal?) fail)]
[(assert-unspecified v) #'(assert (when #f 'a) v eq? fail)]
[else #'else]))
(define (define-test-stx test)
(syntax-case test (define-test)
[(define-test test-name e ...)
#`(call/ec (lambda (fail)
(format #t "~a: " test-name)
(begin
#,@(map assert-stx #'(e ...)))
(display "ok")
(newline)))]))
(syntax-case test (define-test)
[(define-test test-name e ...)
#`(call/ec (lambda (fail)
(format #t "~a: " test-name)
(begin
#,@(map assert-stx #'(e ...)))
(display "ok")
(newline)))]))
(syntax-case stx ()
[(define-test-suite name test ...)
#`(begin
(format #t "Suite ~a:" name)
(newline)
#,@(map define-test-stx
#'(test ...))
(newline))]))))
[(define-test-suite name test ...)
#`(begin
(format #t "Suite ~a:" name)
(newline)
#,@(map define-test-stx
#'(test ...))
(newline))]))))

32
test.scm
View File

@ -34,8 +34,8 @@
(define-test-suite "for"
(define-test "permutation"
(define value (for ([i (iota 2)]
[j (iota 2)])
(cons i j)))
[j (iota 2)])
(cons i j)))
(assert-equal '((0 . 0) (0 . 1) (1 . 0) (1 . 1)) value)))
(define-test-suite "if-let"
@ -76,8 +76,8 @@
(define number-generator
(generator
(let loop ([i 1])
(yield i)
(loop (1+ i)))))
(yield i)
(loop (1+ i)))))
(assert-equal 1 (number-generator))
(assert-equal 2 (number-generator))
(assert-equal 3 (number-generator))
@ -88,18 +88,18 @@
(define (liars)
(amb-reset)
(let ([betty (amb 1 2 3 4 5)]
[ethel (amb 1 2 3 4 5)]
[joan (amb 1 2 3 4 5)]
[kitty (amb 1 2 3 4 5)]
[mary (amb 1 2 3 4 5)])
;; The "Liars" problem
(amb-require (distinct? betty ethel joan kitty mary))
(amb-require (or (= kitty 1) (= betty 3)))
(amb-require (or (= ethel 1) (= joan 2)))
(amb-require (or (= joan 3) (= ethel 5)))
(amb-require (or (= kitty 2) (= mary 4)))
(amb-require (or (= mary 4) (= betty 1)))
(list betty ethel joan kitty mary)))
[ethel (amb 1 2 3 4 5)]
[joan (amb 1 2 3 4 5)]
[kitty (amb 1 2 3 4 5)]
[mary (amb 1 2 3 4 5)])
;; The "Liars" problem
(amb-require (distinct? betty ethel joan kitty mary))
(amb-require (or (= kitty 1) (= betty 3)))
(amb-require (or (= ethel 1) (= joan 2)))
(amb-require (or (= joan 3) (= ethel 5)))
(amb-require (or (= kitty 2) (= mary 4)))
(amb-require (or (= mary 4) (= betty 1)))
(list betty ethel joan kitty mary)))
(assert-equal '(3 5 2 1 4) (liars))))
(define-test-suite "json"