usr_zip works (again)

parent 559ea5fa
......@@ -18,7 +18,6 @@ SOURCES = \
logic/guile-log/umatch.scm \
logic/guile-log/macros.scm \
logic/guile-log/run.scm \
logic/guile-log/macro-help.scm \
logic/guile-log/interleave.scm \
logic/guile-log/tools.scm \
logic/guile-log/prompts.scm \
......
......@@ -2038,6 +2038,8 @@ $1 = ((0 100) (1 101) (2 102) (3 103) (4 104)
lane(Tag_b,Y,c(Y,0)),
(((X mod 2) == 0 -> update(Tag_a)),
((Y mod 1) == 0 -> update(Tag_b)))).
$2 = ((1 100) (3 102) (5 104) (7 106) (9 108))
@end verbatim
@node prolog hash
......
......@@ -73,39 +73,39 @@
(<match> (#:mode - #:name usr_zip_1) (fs xs cs)
((f) (x) (c)
(<cut>
(<//> ((df ((y x)) (goal-eval c)))
(<=> x y) (<=> f ,(mk df))
(<//> ((df11 ((y x)) (goal-eval c)))
(<=> x y) (<=> f ,(mk df11))
(goal-eval guard))))))
((2)
(<match> (#:mode - #:name usr_zip_2) (fs xs cs)
((f1 f2) (x1 x2) (c1 c2)
(<cut>
(<//> ((df1 ((y1 x1)) (goal-eval c1))
(df2 ((y2 x2)) (goal-eval c2)))
(<//> ((df21 ((y1 x1)) (goal-eval c1))
(df22 ((y2 x2)) (goal-eval c2)))
(<=> (x1 x2) (y1 y2))
(<=> (f1 f2) (,(mk df1) ,(mk df2)))
(<=> (f1 f2) (,(mk df21) ,(mk df22)))
(goal-eval guard))))))
((3)
(<match> (#:mode - #:name usr_zip_3) (fs xs cs)
((f1 f2 f3) (x1 x2 x3) (c1 c2 c3)
(<cut>
(<//> ((df1 ((y1 x1)) (goal-eval c1))
(df2 ((y2 x2)) (goal-eval c2))
(df3 ((y3 x3)) (goal-eval c3)))
(<//> ((df31 ((y1 x1)) (goal-eval c1))
(df32 ((y2 x2)) (goal-eval c2))
(df33 ((y3 x3)) (goal-eval c3)))
(<=> (x1 x2 x3) (y1 y2 y3))
(<=> (f1 f2 f3) (,(mk df1) ,(mk df2) ,(mk df3)))
(<=> (f1 f2 f3) (,(mk df31) ,(mk df32) ,(mk df33)))
(goal-eval guard))))))
((4)
(<match> (#:mode - #:name usr_zip_4) (fs xs cs)
((f1 f2 f3 f4) (x1 x2 x3 x4) (c1 c2 c3 c4)
(<cut>
(<//> ((df1 ((y1 x1)) (goal-eval c1))
(df2 ((y2 x2)) (goal-eval c2))
(df3 ((y3 x3)) (goal-eval c3))
(df4 ((y4 x4)) (goal-eval c4)))
(<//> ((df41 ((y1 x1)) (goal-eval c1))
(df42 ((y2 x2)) (goal-eval c2))
(df43 ((y3 x3)) (goal-eval c3))
(df44 ((y4 x4)) (goal-eval c4)))
(<=> (x1 x2 x3 x4) (y1 y2 y3 y4))
(<=> (f1 f2 f3 f4) (,(mk df1) ,(mk df2) ,(mk df3) ,(mk df4)))
(<=> (f1 f2 f3 f4) (,(mk df41) ,(mk df42) ,(mk df43) ,(mk df44)))
(goal-eval guard))))))
(else
(syntax_error "unsuported usr_zip number of lanes")))))
......@@ -126,11 +126,11 @@
(define update
(<case-lambda>
((x)
(<let> ((y (<lookup> x)))
(y 1)))
((x . l)
(<let> ((y (<lookup> x)))
(y 2)
(<apply> update l)))))
((x)
(<let> ((y (<lookup> x)))
(y 1)))
((x . l)
(<let> ((y (<lookup> x)))
(y 2)
(<apply> update l)))))
......@@ -2,6 +2,7 @@
#:use-module (logic guile-log macros)
#:use-module (logic guile-log umatch)
#:use-module (ice-9 match)
#:use-module (ice-9 pretty-print)
#:use-module (syntax parse)
#:export (<or-i> <or-union> <and-i>
<//> <update> <update-val> <zip> <call>
......@@ -476,7 +477,7 @@ and-interleave
(define (nm s p cc lam x l f)
(let-with-lr-guard s wind lguard rguard ((cc cc))
(lguard s
(let ((s (gp-newframe s)))
(let ((s (gp-newframe s)))
((gp-lookup lam s)
s p (lambda (ss pp)
(let ((state (gp-store-state ss)))
......@@ -495,7 +496,10 @@ and-interleave
(pp)))))
(for-each (lambda (l x) (l x)) l xx)
(f ppp)
(cc s ppp)))))))))))
(cc s
(lambda ()
(error
"Bug, should not be exevcuted in <//>")))))))))))))
(fcall-m fcall)
......@@ -520,29 +524,43 @@ and-interleave
(set! fail v))) ...
(allfail P))
(<with-fail> allfail
(fcall (</.> code ...) (list x ...) (list xx2 ...)
(fcall (</.> code ...) (list x ...) (list xx2 ...)
fail2))
...
(rguard
(</.> (<let> ((ccx CC))
(<syntax-parameterize> ((CC2 (lambda z #'ccx)))
(<or> <cc>
(<update-val> (fail) ...))
body ...))))))))))))))
(</.>
(<let*> ((cc CC)
(ccx (lambda (s p) (cc s p)))
(p (lambda ()
(error "BUG we should be here in <//>")))
(s S))
(<syntax-parameterize> ((CC2 (lambda z #'ccx)))
(<with-fail> (lambda ()
((<lambda> ()
(<update> (fail) ...))
s p ccx))
((lambda (s p cccc)
(let ((ccc (lambda (ss pp)
((</.> body ...) s p cccc))))
(set! cc ccc)
(ccc s p)))))))))))))))))))
(define (pp x)
#;(pretty-print (syntax->datum x)) x)
(define-guile-log <update>
(syntax-rules ()
((_ (cut s p cc) (fail . l))
(fail CC2 . l))
((_ w x ... y)
(parse<> w (<and> (<update-val> x) ... (<update> y))))))
(lambda (x)
(pp x)
(syntax-case x ()
((_ (cut s p cc) (fail . l))
(pp #'(fail CC2 . l)))
((_ w x ... y)
#'(parse<> w (<and> (<update-val> x) ... (<update> y)))))))
;;preferably do not use this as a user
(define-guile-log <update-val>
(syntax-rules ()
((_ (cut s p cc) (fail . l))
(fail (lambda (ss pp) (parse<> (cut ss p cc) <cc>)) . l))
(fail (lambda (ss pp) (cc ss p)) . l))
((_ w x ... y)
(parse<> w (<and> (<update-val> x) ... (<update> y))))))
(use-modules (logic guile-log iso-prolog))
(use-modules (logic guile-log guile-prolog zip))
(compile-prolog-string
"
c(X,A) :- c(X,A,0).
c(X,A,N) :- N < 10, (X = A ; (B is A + 1, M is N + 1, c(X,B,M))).
f(X,Y) :- zip(lane(X, c(X,0) ),
lane(Y, c(Y,100) )).
g(X,Y) :- usr_zip(lane(Tag_a,X,c(X,0)),
lane(Tag_b,Y,c(Y,100)),
(((X mod 2) =:= 0 -> update(Tag_a) ; true),
((Y mod 2) =:= 1 -> update(Tag_b) ; true))).
")
(pk 'f (prolog-run * (X Y) (f X Y)))
(pk 'g (prolog-run * (X Y) (g X Y)))
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