suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Using tagged continuations and aborts rather than heavy conts

Browse Source
This commit is contained in:
Jay McCarthy 2010-04-29 15:31:31 -06:00
parent cf68210bd0
commit 198850eb9f
1 changed files with 54 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

103
collects/raclog/raclog.rkt
View File

@ -17,11 +17,11 @@
(syntax-rules ()
((%or g ...)
(lambda (__fk)
(let/cc __sk
(let/cc __fk
(__sk ((logic-var-val* g) __fk)))
...
(__fk 'fail))))))
(let/raclog-cc __sk
(let/raclog-cc __fk
(__sk ((logic-var-val* g) __fk)))
...
(__fk 'fail))))))
(define-syntax %and
(syntax-rules ()
@ -48,18 +48,18 @@
((%rel (v ...) ((a ...) subgoal ...) ...)
(lambda __fmls
(lambda (__fk)
(let/cc __sk
(let ((this-! (lambda (fk1) __fk)))
(syntax-parameterize
([! (make-rename-transformer #'this-!)])
(%let (v ...)
(let/cc __fk
(let* ((__fk ((%= __fmls (list a ...)) __fk))
(__fk ((logic-var-val* subgoal) __fk))
...)
(__sk __fk)))
...
(__fk 'fail))))))))))
(let/raclog-cc __sk
(let ((this-! (lambda (fk1) __fk)))
(syntax-parameterize
([! (make-rename-transformer #'this-!)])
(%let (v ...)
(let/raclog-cc __fk
(let* ((__fk ((%= __fmls (list a ...)) __fk))
(__fk ((logic-var-val* subgoal) __fk))
...)
(__sk __fk)))
...
(__fk 'fail))))))))))
(define %fail
(lambda (fk) (fk 'fail)))
@ -110,8 +110,8 @@
(define ((make-negation p) . args)
;basically inlined cut-fail
(lambda (fk)
(if (let/cc k
((apply p args) (lambda (d) (k #f))))
(if (let/raclog-cc k
((apply p args) (lambda (d) (k #f))))
(fk 'fail)
fk)))
@ -142,8 +142,8 @@
(define (%not g)
(lambda (fk)
(if (let/cc k
((logic-var-val* g) (lambda (d) (k #f))))
(if (let/raclog-cc k
((logic-var-val* g) (lambda (d) (k #f))))
(fk 'fail) fk)))
(define (%empty-rel . args)
@ -178,8 +178,8 @@
(syntax-rules ()
((%free-vars (v ...) g)
(make-goal-with-free-vars
(list v ...)
g))))
(list v ...)
g))))
(define ((make-bag-of kons) lv goal bag)
(let ((fvv '()))
@ -190,15 +190,15 @@
(define (make-bag-of-aux kons fvv lv goal bag)
(lambda (fk)
(let/cc sk
(let ((lv2 (cons fvv lv)))
(let* ((acc '())
(fk-final
(lambda (d)
(sk ((separate-bags fvv bag acc) fk))))
(fk-retry (goal fk-final)))
(set! acc (kons (logic-var-val* lv2) acc))
(fk-retry 'retry))))))
(let/raclog-cc sk
(let ((lv2 (cons fvv lv)))
(let* ((acc '())
(fk-final
(lambda (d)
(sk ((separate-bags fvv bag acc) fk))))
(fk-retry (goal fk-final)))
(set! acc (kons (logic-var-val* lv2) acc))
(fk-retry 'retry))))))
(define (separate-bags fvv bag acc)
(let ((bags (let loop ((acc acc)
@ -230,30 +230,35 @@
(%and (%set-of x g s)
(%= s (cons (_) (_)))))
(define *more-k* (box 'forward))
(define *more-fk* (box (λ (d) (error '%more "No active %which"))))
(define-syntax %which
(syntax-rules ()
((%which (v ...) g)
(%let (v ...)
(let/cc __qk
(set-box! *more-k* __qk)
(set-box! *more-fk*
((logic-var-val* g)
(lambda (d)
(set-box! *more-fk* #f)
((unbox *more-k*) #f))))
((unbox *more-k*)
(list (cons 'v (logic-var-val* v))
...)))))))
(with-raclog-prompt
(%let (v ...)
(set-box! *more-fk*
((logic-var-val* g)
(lambda (d)
(set-box! *more-fk* #f)
(abort-to-raclog-prompt #f))))
(abort-to-raclog-prompt
(list (cons 'v (logic-var-val* v))
...)))))))
(define (%more)
(let/cc k
(set-box! *more-k* k)
(if (unbox *more-fk*)
((unbox *more-fk*) 'more)
#f)))
(with-raclog-prompt
(if (unbox *more-fk*)
((unbox *more-fk*) 'more)
#f)))
(define raclog-prompt-tag (make-continuation-prompt-tag 'raclog))
(define (abort-to-raclog-prompt a)
(abort-current-continuation raclog-prompt-tag (λ () a)))
(define-syntax-rule (with-raclog-prompt e ...)
(call-with-continuation-prompt (λ () e ...) raclog-prompt-tag))
(define-syntax-rule (let/raclog-cc k e ...)
(call-with-current-continuation (λ (k) e ...) raclog-prompt-tag))
(define (%member x y)
(%let (xs z zs)