any-union added

parent 0938f9c3
......@@ -9,6 +9,17 @@
((_ w a ...)
(parse<> w (interleave (list (</.> a) ...))))))
(define-guile-log <or-union>
(syntax-rules ()
((_ w)
(parse<> w <fail>))
((_ w a)
(parse<> w a))
((_ w a ...)
(parse<> w (interleave-union (list (</.> a) ...))))))
(define-guile-log <and-i>
(syntax-rules ()
((_ w)
......@@ -51,6 +62,54 @@
as)
'())
(fail))))
(define (interleave-union p cc as)
(with-guarded-states guard-set! ((l '()) (r '()) (gs '()) (gr '()))
(let ((s (gp-store-state)))
(define fail
(lambda ()
(let loop ((ll l) (rr r) (ggs gs) (ggr gr))
(if (null? ll)
(if (null? rr)
(p)
(loop (reverse rr) '() (reverse ggr) '()))
(let ((thunk (car ll)))
(guard-set! (cdr ll) rr (cdr ggs) ggr)
(thunk))))))
(define (mk-cont p)
(let ((state (gp-store-state)))
(lambda ()
(gp-restore-wind state)
(p))))
(guard-set!
(map (lambda (a)
(lambda ()
(gp-restore-wind s)
(a fail
(lambda (p2)
(let check ((ggs gs))
(if (pair? ggs)
(let ((fr (gp-newframe)))
((car ggs)
(lambda ()
(gp-unwind fr)
(check (cdr ggs)))
(lambda (p)
(gp-unwind fr)
(guard-set! l (cons (mk-cont p2) r)
gs (cons a gr))
(fail))))
(begin
(guard-set! l (cons (mk-cont p2) r)
gs (cons a gr))
(cc fail))))))))
as)
'()
as
'())
(fail))))
#|
......
......@@ -7,7 +7,7 @@
let-gls == query solve solution project project/no-check
predicate *equal? var? _ let-lv reify partially-eval-sgl
extend-relation extend-relation-with-recur-limit
intersect-relation exists))
intersect-relation exists any-union))
(define-syntax mk
......@@ -29,6 +29,7 @@
(mk all!! <and!!>)
(mk any <or>)
(mk any-interleave <or-i>)
(mk any-union <or-union>)
(mk all-interleave <and-i>)
(mk if-only <if>)
(mk if-some <if-some>)
......
......@@ -8,7 +8,7 @@
<and!> <and!!> <succeds>
<format> <tail-code> <code> <ret> <return>
<def> <<define>> <with-fail> <dynwind> parse<>
let<> <or-i> <stall> <continue> <take>
let<> <or-i> <or-union> <stall> <continue> <take>
<state-ref> <state-set!> <lv*> <clear>
<and-i> and-interleave interleave tr
<letg> <set!> define-guarded *gp-var-tr*)
......
......@@ -417,7 +417,7 @@
(solution (path) (towers-of-hanoi-path 3 path))
'((l m) (l r) (m r) (l m) (r l) (r m) (l m)))
; This is not supporeted technology, use guarded variables in stead
; This is not supporeted technology
#;
(let
((parents-of-scouts
......@@ -685,51 +685,36 @@
;; Test for nonoverlapping.
#;
(cout nl "any-union" nl)
#;
(format #t "~%any-union~%")
(test-check "R1+R2"
(solve 10 (x y)
(any-union (R1 x y) (R2 x y)))
'(((x.0 x1) (y.0 y1))
((x.0 x2) (y.0 y2))
((x.0 x3) (y.0 y3))))
'((x1 y1) (x2 y2) (x3 y3)))
#;
(test-check "R2+R1"
(solve 10 (x y)
(any-union (R2 x y) (R1 x y)))
'(((x.0 x1) (y.0 y1))
((x.0 x3) (y.0 y3))
((x.0 x2) (y.0 y2))))
#;
'((x1 y1) (x3 y3) (x2 y2)))
(test-check "R1+R1"
(solve 10 (x y)
(any-union (R1 x y) (R1 x y)))
'(((x.0 x1) (y.0 y1))
((x.0 x2) (y.0 y2))))
#;
'((x1 y1) (x2 y2)))
(test-check "Rinf+R1"
(solve 7 (x y)
(any-union (Rinf x y) (R1 x y)))
'(((x.0 z) (y.0 z))
((x.0 x1) (y.0 y1))
((x.0 (s z)) (y.0 (s z)))
((x.0 x2) (y.0 y2))
((x.0 (s (s z))) (y.0 (s (s z))))
((x.0 (s (s (s z)))) (y.0 (s (s (s z)))))
((x.0 (s (s (s (s z))))) (y.0 (s (s (s (s z))))))))
#;
'((z z) (x1 y1) ((s z) (s z)) (x2 y2)
((s (s z)) (s (s z))) ((s (s (s z))) (s (s (s z))))
((s (s (s (s z)))) (s (s (s (s z)))))))
(test-check "R1+RInf"
(solve 7 (x y)
(any-union (R1 x y) (Rinf x y)))
'(((x.0 x1) (y.0 y1))
((x.0 z) (y.0 z))
((x.0 x2) (y.0 y2))
((x.0 (s z)) (y.0 (s z)))
((x.0 (s (s z))) (y.0 (s (s z))))
((x.0 (s (s (s z)))) (y.0 (s (s (s z)))))
((x.0 (s (s (s (s z))))) (y.0 (s (s (s (s z))))))))
'((x1 y1) (z z) (x2 y2) ((s z) (s z)) ((s (s z)) (s (s z)))
((s (s (s z))) (s (s (s z)))) ((s (s (s (s z)))) (s (s (s (s z)))))))
; Infinitary relation Rinf2
......
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