new version of paralell

parent 3ce31216
......@@ -3,50 +3,39 @@
#:use-module (logic guile-log prolog goal-functors)
#:use-module (logic guile-log umatch)
#:use-module (logic guile-log paralell)
#:export (paralell pzip))
#:export (paralell pzip conjeur zipper same))
(define (recur Goal)
(<lambda> (data)
(<values> (f Next) (goal-eval Goal))
(<cc> (<lookup> f) (recur (<copy-term> Next)))))
(define paralell
(<case-lambda>
(() <fail>)
((x) (goal-eval x))
((fail x y)
(let ((fail- #f))
(<pand> n fail-
(p1 l1 s1 (gp-make-engine (+ n 1) 100) (goal-eval x))
(p2 l2 s2 (gp-make-engine (+ n 1) 100) (goal-eval y)))
(fail- (</.> (goal-eval fail)))))
((fail x y u)
(let ((fail- #f))
(<pand> n fail-
(p1 l1 s1 (gp-make-engine (+ n 1) 100) (goal-eval x))
(p2 l2 s2 (gp-make-engine (+ n 1) 100) (goal-eval y))
(p3 l3 s3 (gp-make-engine (+ n 1) 100) (goal-eval u)))
(fail- (</.> (goal-eval fail)))))
((fail x y u v)
(let ((fail- #f))
(<pand> n fail-
(p1 l1 s1 (gp-make-engine (+ n 1) 100) (goal-eval x))
(p2 l2 s2 (gp-make-engine (+ n 1) 100) (goal-eval y))
(p3 l3 s3 (gp-make-engine (+ n 1) 100) (goal-eval u))
(p4 l4 s4 (gp-make-engine (+ n 1) 100) (goal-eval v)))
(fail- (</.> (goal-eval fail)))))
((fail . l)
(let ((fail- #f)
(l-u (let lp ((l l) (u '()) (n (/ (length l) 2)))
(if (= n 0)
(cons l u)
(lp (cdr l) (cons (car l) u) (- n 1))))))
(<pand> n fail-
(p1 l1 s1 (gp-make-engine (+ n 1) 100)
(<apply> paralell fail (car l-u)))
(p3 l3 s3 (gp-make-engine (+ n 1) 100)
(<apply> paralell fail (cdr l-u))))
(fail- (</.> (goal-eval fail)))))))
(define (paralell . l)
(<<match>> (#:mode -) (l)
((fail data e c (d1 p1 x1) (d2 p2 x2))
(<pand> n (recur fail) da ee cc
((dd1 pp1 (gp-make-engine (+ n 1) 100) (goal-eval x1))
(dd2 pp2 (gp-make-engine (+ n 1) 100) (goal-eval x2)))
(<=> (da ee cc dd1 pp1 dd2 pp2)
(data e c d1 p1 d2 p2))))
((fail e c (d1 p1 x1) (d2 p2 x2) (d3 p3 x3))
(<pand> n (recur fail) ee cc
((dd1 pp1 (gp-make-engine (+ n 1) 100) (goal-eval x1))
(dd2 pp2 (gp-make-engine (+ n 1) 100) (goal-eval x2))
(dd3 pp3 (gp-make-engine (+ n 1) 100) (goal-eval x3)))
(<=> (da ee cc dd1 pp1 dd2 pp2 dd2 pp3)
(data e c d1 p1 d2 p2 d3 p3))))
((fail e c (d1 p1 x1) (d2 p2 x2) (d3 p3 x3) (d4 p4 x4))
(<pand> n (recur fail) ee cc
((dd1 pp1 (gp-make-engine (+ n 1) 100) (goal-eval x1))
(dd2 pp2 (gp-make-engine (+ n 1) 100) (goal-eval x2))
(dd3 pp3 (gp-make-engine (+ n 1) 100) (goal-eval x3))
(dd4 pp4 (gp-make-engine (+ n 1) 100) (goal-eval x4)))
(<=> (da ee cc dd1 pp1 dd2 pp2 dd3 pp3 dd4 pp4)
(data e c d1 p1 d2 p2 d3 p3 d4 p4))))))
(define (fail- x) x)
(define pzip
......@@ -54,26 +43,53 @@
(() <fail>)
((x) (goal-eval x))
((x y)
(<pzip> fail-
(p1 l1 s1 q1 (goal-eval x))
(p2 l2 s2 q2 (goal-eval y))))
(<pzip>
((goal-eval x))
((goal-eval y))))
((x y u)
(<pzip> fail-
(p1 l1 s1 q1 (goal-eval x))
(p2 l2 s2 q2 (goal-eval y))
(p3 l3 s3 q3 (goal-eval u))))
(<pzip>
((goal-eval x))
((goal-eval y))
((goal-eval u))))
((x y u v)
(<pzip> fail-
(p1 l1 s1 q1 (goal-eval x))
(p2 l2 s2 q2 (goal-eval y))
(p3 l3 s3 q3 (goal-eval u))
(p4 l4 s4 q4 (goal-eval v))))
(<pzip>
((goal-eval x))
((goal-eval y))
((goal-eval u))
((goal-eval v))))
(l
(let ((l-u (let lp ((l l) (u '()) (n (/ (length l) 2)))
(if (= n 0)
(cons l u)
(lp (cdr l) (cons (car l) u) (- n 1))))))
(<pzip> fail-
(p2 l2 s2 q2 (<apply> pzip (car l-u)))
(p3 l3 s3 q3 (<apply> pzip (cdr l-u))))))))
(<pzip>
((<apply> pzip (car l-u)))
((<apply> pzip (cdr l-u))))))))
(define (conjeur s p cc . l)
(call-with-values
(lambda ()
(apply conjunctioneur
(map (lambda (x) (gp_lookup s x)) l)))
(lambda (x y)
(cc s p x y))))
(define (zipper s p cc . l)
(call-with-values
(lambda ()
(apply jack-the-zipper
(map (lambda (x) (gp_lookup s x)) l)))
(lambda (x y)
(cc s p x y))))
(compile-prolog-string "
same(F) :-
P <= F,
cc(P,F).
cycle(Data) :- length(Data,N), cycle(Data,0,N).
cycle(Data,I,N) :- ref(Data,I,P), II is (I + 1) % N, cc(P,cycle(II,N)).
")
......@@ -1327,6 +1327,7 @@ MAKE SURE TO REVISIT THIS IDEA LATER
(syntax-rules ()
((_ w a ...)
(<with-guile-log> w code ...)))))
(define-syntax-rule (attvar? x) (gp-attvar? (gp-lookup x S) S))
(<define> (<attvar?> x) (if (gp-attvar? x S) <cc> <fail>))
(<define> (<attvar-raw?> x) (if (gp-attvar-raw? x S) <cc> <fail>))
......
(define-module (logic guile-log paralell)
#:use-module (logic guile-log)
#:use-module (srfi srfi-1)
#:use-module (logic guile-log code-load)
#:use-module (logic guile-log dynamic-features)
#:use-module (logic guile-log umatch)
#:export (<pand> <pzip> f test1 test2 test3 test4 next-level))
(<define-guile-log-rule> (<pit> s p cc code ...)
(<letrec> ((cc-internal
(lambda (s0 p0)
(set! cc-internal cc)
(CC s p))))
(<with-cc> (lambda (s p) (cc-internal s p))
code ...)))
(define *cc* (@@ (logic guile-log run) *cc*))
(<define> (check-bindings check key.vals)
......@@ -29,96 +21,118 @@
(define level 0)
(define next-level 0)
(<define-guile-log-rule> (<pand> n check (v l se engine code ...) ...)
(<nvar> (+ next-level 1) (v ...)
(let ((i level) (n next-level) (l level) ...)
(<dynwind>
(lambda x #f)
(lambda x
(set! level i)
(set! next-level n)))
(let ((data (list v ...))
(frame (<newframe>))
(se #f) ...
(p P)
(cc CC))
(let* ((s frame)
(ccc (lambda (ss pp)
(gp-combine-engines data)
(cc s p))))
(<with-s> s
(<pit> s p ccc
(<with-fail> p
(<with-s> (gp-push-engine frame engine)
(<code> (gp-combine-push data))
(<code> (gp-var-set v (gp-peek-engine) S))
(<dynwind>
(lambda x
(set! level (+ 1 n))
(set! next-level (+ 1 n)))
(lambda x #f))
(<code>
(set! level (+ 1 n))
(set! next-level (+ 1 n)))
code ...
(<dynwind>
(lambda x (set! l next-level))
(lambda x (set! next-level l)))
(<code>
(set! l next-level))
(<code> (set! se S))
(<code> (gp-pop-engine))))))
...
(<dynwind>
(lambda x
(set! next-level (max l ...))
(set! level i))
(lambda x #f))
(<code>
(set! next-level (max l ...))
(set! level i))
(<code> (gp-combine-engines data))
(<code>
(set! check
(<lambda> (fail-)
(let ((s.bindings (gp-combine-state s (list se ...))))
(check-bindings fail- (cdr s.bindings))
(<with-s> (car s.bindings))))))
(<with-fail> p <cc>))))))
(<define-guile-log-rule> (<pzip> check (v ll se p code ...) ...)
(<nvar> (+ next-level 1) (p ...)
(<letrec> ((l '())
(pwork
(lambda (q)
(if (pair? l)
(let ((pp (car l)))
(set! l (cdr l))
(pp))
(q))))
(pand-check #f)
(ccwork
(lambda (s pp cc)
(pwork (lambda () (cc s pp)))))
(pend
(lambda ()
(set! l (list (<lookup> p) ...))
(pwork #f))))
((</.>
(<pand> n pand-check
(v ll se (gp-make-engine (+ n 1) 100)
code ... (<set> p P)) ...)))
(ccwork)
(pand-check (check (</.> (<ret> (pend)))))
(<with-fail> pend <cc>))))
(define-guile-log <pand>
(lambda (x)
(define-syntax-rule (m x)
(case-lambda
(() x)
((a) (set! x a))))
(syntax-case x ()
((_ w n check data exit cc ((d pd engine code ...) ...) body ...)
(with-syntax (((v ...) (generate-temporaries #'(d...)))
((l ...) (generate-temporaries #'(d...)))
((cci ...) (generate-temporaries #'(d...)))
((st ...) (generate-temporaries #'(d...)))
((pd ...) (generate-temporaries #'(d...)))
((e ...) (generate-temporaries #'(d...)))
((se ...) (generate-temporaries #'(d...))))
#'(<nvar> w (+ next-level 1) (v ...)
(let ((i level) (n next-level) (p P))
(<let-with-lr-guard>
wind lguard rguard
((chk #f)
(l level) ...
(pd p) ...
(st (lambda () (p))) ...
(cci #f) ...
(se #f) ...
(e #f) ...)
(lguard
(</.>
(<dynwind>
(lambda x #f)
(lambda x
(set! level i)
(set! next-level n)))
(let* ((data (list v ...))
(frame (<newframe>))
(d (vector (m e) (m cci) (m st))) ...
(exit P)
(s frame))
(let ((cc CC))
(<with-s> s
(<code> (set! st CC))
(<with-cc> (lambda (s p . l)
(if (cci)
(apply (cci) s p l)
(apply CC s p l)))
(<with-fail> (lambda ()
(<with-s> (gp-push-engine frame engine)
(<code> (gp-combine-push data))
(<code> (gp-var-set v (gp-peek-engine) S))
(<dynwind>
(lambda x
(set! level (+ 1 n))
(set! next-level (+ 1 n)))
(lambda x #f))
(<code>
(set! level (+ 1 n))
(set! next-level (+ 1 n)))
code ...
(<dynwind>
(lambda x (set! l next-level))
(lambda x (set! next-level l)))
(<code>
(set! l next-level))
(<code> (set! se S))
(<code> (set! pd P))
(<code> (gp-pop-engine)))))))
...
(<code> (set! chk check)))
;; The stub below is always executed last at a backtrack
(<dynwind>
(lambda x
(set! next-level (max l ...))
(set! level i))
(lambda x #f))
(<code>
(set! next-level (max l ...))
(set! level i))
(<code> (gp-combine-engines data))
(<values> (f next) (chk data))
(<code> (set! chk next))
(rguard
(</.>
(let ((s.bindings (gp-combine-state s (list se ...))))
(check-bindings f (cdr s.bindings))
(<with-s> (car s.bindings)
(<with-fail> f body ...))))))))))))))))
(define (recur f) (<lambda> (data) (<cc> f (recur f))))
(define-guile-log <pzip>
(lambda (x)
(syntax-case x ()
((_ w (code ...) ...)
(with-syntax (((p ...) (generate-temporaries #'((code ...) ...)))
((d ...) (generate-temporaries #'((code ...) ...)))
((pd ...) (generate-temporaries #'((code ...) ...))))
(with-syntax (((zarg ...)
(fold-right (lambda (a b seed) (cons* a b seed))
'() #'(d ...) #'(pd ...))))
#'(<pand> w 0 (recur (jack-the-zipper zarg ...)) data exit cc
((d pd (gp-make-engine (+ n 1) 100) code ...)
...))))))))
(<define> (g x n)
(<recur> lp ((i 0) (x x))
......@@ -134,26 +148,91 @@
(if (< i n)
(<or> (<=> x i) (lp (+ i 1))))))
(define (idfail fail-all) fail-all)
(<define> (test1 x y)
(<pzip> idfail (v1 l1 s1 p1 (f x 3)) (v2 l2 s2 p2 (f y 3))))
(<define> (test1 x y) (<pzip> ((f x 3)) ((f y 3))))
#|
(<define> (test2 x y)
(<pzip> idfail (v1 l1 s1 p1 (<member> 1 x)) (v2 l2 s2 p2 (<member> 2 y))))
(<pzip> ((<member> 1 x)) ((<member> 2 y))))
(<define> (test3 x y)
(<pzip> idfail (v1 l1 s1 p1 (g x 10)) (v2 l2 s2 p2 (g y 10))))
(<pzip> ((g x 10)) ((g y 10))))
(<define> (test4 x y z w)
(<pzip> idfail (v1 l1 s1 p1 (test3 x y)) (v2 l2 s2 p2 (test3 z w))))
(<pzip> ((test3 x y)) ((test3 z w))))
|#
(define jack-the-zipper
(case-lambda
((d1 p1)
(values d1 p1))
((d1 p1 d2 p2)
(let* ((exit (make-variable (lambda ()
(error "not hooked in"))))
(exit-1 (vector-ref d1 0))
(exit-2 (vector-ref d2 0))
(cc-1 (vector-ref d1 1))
(cc-2 (vector-ref d2 1))
(start-1 (vector-ref d1 2))
(start-2 (vector-ref d2 2))
(start (lambda (s p)
(variable-set! cc-1 start-2)
(start-1 s p)))
(d (vector exit cc-2 start)))
(variable-set! exit-1
(lambda () ((variable-ref exit))))
(variable-set! exit-2
(lambda () ((variable-ref exit))))
(variable-set! cc-1
(lambda (s p) (p2)))
(values d p1)))
((d1 p1 d2 p2 . l)
(call-with-values (lambda () (apply jack-the-zipper d2 p2 l))
(lambda (d2 p2)
(jack-the-zipper d1 p1 d2 p2))))))
(define conjunctioneur
(case-lambda
((d1 p1)
(values d1 p1))
((d1 p1 d2 p2)
(let ((exit-1 (vector-ref d1 0))
(exit-2 (vector-ref d2 0))
(cc-1 (vector-ref d1 1))
(cc-2 (vector-ref d2 1))
(start-1 (vector-ref d1 2))
(start-2 (vector-ref d2 2))
(start (lambda (s p)
(vector-set! cc-1 1 start-2)
(start-1 s p)))
(d (vector exit-1 cc-2 0 start)))
(variable-set! exit-2
(lambda ()
(vector-set! exit-2 0 exit-1)
(vector-set! cc-1 1 start-2)
(p1)))
(values d p2)))
((d1 p1 d2 p2 . l)
(call-with-values (lambda () (apply conjunctioneur d2 p2 l))
(lambda (d2 p2)
(conjunctioneur d1 p1 d2 p2))))))
(define (do-the-twist-and-fail exit cc d p)
(let ((d-exit (vector-ref d 0))
(d-cc (vector-ref d 1)))
(variable-set! d-exit exit)
(variable-set! d-cc cc)
(p)))
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