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

Add amb and distinct?

Browse Source
This commit is contained in:
Dane Johnson 2024-12-16 10:35:33 -06:00
parent e209bfe130
commit 5b69379de1
2 changed files with 52 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
d-.scm
View File

@ -13,8 +13,12 @@
argmin
iterate
upply
distinct?
generator
macro-expand))
macro-expand
amb
amb-reset
amb-require))
(define-syntax ~>
(syntax-rules ()
@ -77,6 +81,12 @@
(let ([arm-f (apply compose fs)])
(cmp (arm-f a) (arm-f b))))
(define (distinct? . a)
(if (or (null? a) (null? (cdr a)))
#t
(and (not (any (lambda (x) (eq? (car a) x)) (cdr a)))
(apply distinct? (cdr a)))))
;; Shamelessly ripped from https://wingolog.org/archives/2013/02/25/on-generators
(define (make-generator f)
(define tag (make-prompt-tag))
@ -100,3 +110,25 @@
;; Why wasn't this included?
(define macro-expand (compose tree-il->scheme macroexpand))
;; This is the "classic" implementation of McCarthy's `amb'
;; Would rather it use delimited continuations, but I'm too dumb
(define (*fail*) (error "Could not satisfy amb"))
(define-syntax amb
(syntax-rules ()
[(amb) (*fail*)]
[(amb a) a]
[(amb a b ...)
(let ([fail0 *fail*])
(call/cc
(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"))))
(define (amb-require pred)
(or pred (amb)))

19
test.scm
View File

@ -80,3 +80,22 @@
(assert-equal 2 (number-generator))
(assert-equal 3 (number-generator))
(assert-equal 4 (number-generator))))
(define-test-suite "amb"
(define-test "liars"
(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)))
(assert-equal '(3 5 2 1 4) (liars))))