Debugged and add test for // code

parent 8ae739ce
......@@ -424,9 +424,9 @@ and-interleave
(define-syntax-rule (fcall-m nm)
(define (nm s p cc lam x l f)
(let-with-guard s wind guard ((cc cc))
(let-with-lr-guard s wind lguard rguard ((cc cc))
(lguard s
(let ((s (gp-newframe s)))
(guard s
((gp-lookup lam s)
s p (lambda (ss pp)
(let ((state (gp-store-state ss)))
......@@ -443,7 +443,7 @@ and-interleave
(pp)))))
(for-each (lambda (l x) (l x)) l xx)
(f ppp)
(cc s ppp)))))))))))
(cc s ppp)))))))))))
(fcall-m fcall)
......@@ -458,25 +458,28 @@ and-interleave
(map generate-temporaries #'((xx ...) ...)))
((fail2 ...)
(generate-temporaries #'(fail ...))))
#'(<let-with-guard> guard ((xx #f) ... ... (fail #f) ...)
(<let> ((xx2 (lambda (v)
(set! xx v))) ... ...
(fail2 (lambda (v)
(set! fail v))) ...
(allfail P))
(<logical++>)
(<with-fail> allfail
(guard
(</.> (fcall (</.> code ...) (list x ...) (list xx2 ...)
fail2))))
...
(<logical-->)
(guard
(</.> (<let> ((ccx CC))
(<fluid-let-syntax> ((CC2 (lambda z #'ccx)))
(<or> <cc>
(<update-val> (fail) ...))
body ...)))))))))))
#'(parse<> w
(<let-with-lr-guard> wind lguard rguard
((xx #f) ... ... (fail #f) ...)
(lguard
(</.>
(<let> ((xx2 (lambda (v)
(set! xx v))) ... ...
(fail2 (lambda (v)
(set! fail v))) ...
(allfail P))
(<logical++>)
(<with-fail> allfail
(fcall (</.> code ...) (list x ...) (list xx2 ...)
fail2))
...
(<logical-->)
(rguard
(</.> (<let> ((ccx CC))
(<fluid-let-syntax> ((CC2 (lambda z #'ccx)))
(<or> <cc>
(<update-val> (fail) ...))
body ...))))))))))))))
(define-guile-log <update>
......
......@@ -14,6 +14,7 @@
<state-ref> <state-set!> <lv*> <clear>
<and-i> and-interleave interleave tr S P CC CUT
<set!> define-guarded *gp-var-tr* *kanren-assq* <scm> <zip>
<with-generators> <next-generator-value>
<cons> <values> <windlevel>
<//> <update> <update-val> <fluid-let-syntax>
<let-with-guard> <let-with-lr-guard> let-with-guard let-with-lr-guard
......@@ -963,3 +964,18 @@
(<call> ((Y Y))
(<uniq> Lam Y))
(<fold-step> kons knil Lam X L))
(define-guile-log <with-generators>
(syntax-rules ()
((_ w ((x i) ...) code ...)
(<let-with-lr-guard> w wind lg rg ((x i) ...)
(lg (</.> code ...))))))
(define-guile-log <next-generator-value>
(syntax-rules ()
((_ w kons v x)
(begin
(set! v (kons (<scm> x) v))
(parse<> w <cc>)))))
......@@ -196,7 +196,99 @@
(<continue>))))
(equal? a b)))
(define a (let loop ((i 0))
(if (< i 100)
(cons (random 100) (loop (+ i 1)))
'())))
(define a2 (let loop ((i 0))
(if (< i 100)
(cons (random 100) (loop (+ i 1)))
'())))
(define b (let loop ((i 0))
(if (< i 100)
(cons (random 100) (loop (+ i 1)))
'())))
(define b2 (let loop ((i 0))
(if (< i 100)
(cons (random 100) (loop (+ i 1)))
'())))
(define (//-test-1)
(<run> 100 (x y)
(<with-generators> ((i 0))
(<//> ((f1 ((aa x)) (<or-i> (<member> x a) (<member> x a2)))
(f2 ((bb y)) (<or-i> (<member> y b) (<member> y b2))))
(if (odd? aa)
(<update> (f1))
<cc>)
(if (odd? bb)
(<update> (f2))
<cc>)
(<=> x aa)
(<=> y bb)
(<next-generator-value> + i 1)
(if (= i 10) (<stall>) <cc>))))
(let* ((state (<state-ref>))
(a (<continue>))
(b (begin
(<state-set!> state)
(<continue>))))
(equal? a b)))
(define (//-test-2)
(<run> 100 (x y)
(<with-generators> ((i 0))
(<//> ((f1 ((aa x))
(<or-i> (<member> x a) (<member> x a2))
(<next-generator-value> + i 1)
(if (= i 10) (<stall>) <cc>))
(f2 ((bb y)) (<or-i> (<member> y b) (<member> y b2))))
(if (odd? aa)
(<update> (f1))
<cc>)
(if (odd? bb)
(<update> (f2))
<cc>)
(<=> x aa)
(<=> y bb))))
(let* ((state (<state-ref>))
(a (<continue>))
(b (begin
(<state-set!> state)
(<continue>))))
(equal? a b)))
(define (//-test-3)
(<run> 100 (x y)
(<with-generators> ((i 0))
(<//> ((f1 ((aa x))
(<or-i> (<and> (<member> x a)
(if (= i 10) (<stall>) <cc>))
(<member> x a2))
(<next-generator-value> + i 1))
(f2 ((bb y)) (<or-i> (<member> y b) (<member> y b2))))
(if (odd? aa)
(<update> (f1))
<cc>)
(if (odd? bb)
(<update> (f2))
<cc>)
(<=> x aa)
(<=> y bb))))
(let* ((state (<state-ref>))
(a (<continue>))
(b (begin
(<state-set!> state)
(<continue>))))
(equal? a b)))
#;
(with-test-prefix "guile-log, interleaving undo/redo"
(pass-if "or/1"
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment