new version of paralell

parent 3ce31216
...@@ -3,50 +3,39 @@ ...@@ -3,50 +3,39 @@
#:use-module (logic guile-log prolog goal-functors) #:use-module (logic guile-log prolog goal-functors)
#:use-module (logic guile-log umatch) #:use-module (logic guile-log umatch)
#:use-module (logic guile-log paralell) #: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 (define (paralell . l)
(<case-lambda> (<<match>> (#:mode -) (l)
(() <fail>) ((fail data e c (d1 p1 x1) (d2 p2 x2))
((x) (goal-eval x)) (<pand> n (recur fail) da ee cc
((fail x y) ((dd1 pp1 (gp-make-engine (+ n 1) 100) (goal-eval x1))
(let ((fail- #f)) (dd2 pp2 (gp-make-engine (+ n 1) 100) (goal-eval x2)))
(<pand> n fail- (<=> (da ee cc dd1 pp1 dd2 pp2)
(p1 l1 s1 (gp-make-engine (+ n 1) 100) (goal-eval x)) (data e c d1 p1 d2 p2))))
(p2 l2 s2 (gp-make-engine (+ n 1) 100) (goal-eval y)))
(fail- (</.> (goal-eval fail))))) ((fail e c (d1 p1 x1) (d2 p2 x2) (d3 p3 x3))
(<pand> n (recur fail) ee cc
((fail x y u) ((dd1 pp1 (gp-make-engine (+ n 1) 100) (goal-eval x1))
(let ((fail- #f)) (dd2 pp2 (gp-make-engine (+ n 1) 100) (goal-eval x2))
(<pand> n fail- (dd3 pp3 (gp-make-engine (+ n 1) 100) (goal-eval x3)))
(p1 l1 s1 (gp-make-engine (+ n 1) 100) (goal-eval x)) (<=> (da ee cc dd1 pp1 dd2 pp2 dd2 pp3)
(p2 l2 s2 (gp-make-engine (+ n 1) 100) (goal-eval y)) (data e c d1 p1 d2 p2 d3 p3))))
(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)))))))
((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 (fail- x) x)
(define pzip (define pzip
...@@ -54,26 +43,53 @@ ...@@ -54,26 +43,53 @@
(() <fail>) (() <fail>)
((x) (goal-eval x)) ((x) (goal-eval x))
((x y) ((x y)
(<pzip> fail- (<pzip>
(p1 l1 s1 q1 (goal-eval x)) ((goal-eval x))
(p2 l2 s2 q2 (goal-eval y)))) ((goal-eval y))))
((x y u) ((x y u)
(<pzip> fail- (<pzip>
(p1 l1 s1 q1 (goal-eval x)) ((goal-eval x))
(p2 l2 s2 q2 (goal-eval y)) ((goal-eval y))
(p3 l3 s3 q3 (goal-eval u)))) ((goal-eval u))))
((x y u v) ((x y u v)
(<pzip> fail- (<pzip>
(p1 l1 s1 q1 (goal-eval x)) ((goal-eval x))
(p2 l2 s2 q2 (goal-eval y)) ((goal-eval y))
(p3 l3 s3 q3 (goal-eval u)) ((goal-eval u))
(p4 l4 s4 q4 (goal-eval v)))) ((goal-eval v))))
(l (l
(let ((l-u (let lp ((l l) (u '()) (n (/ (length l) 2))) (let ((l-u (let lp ((l l) (u '()) (n (/ (length l) 2)))
(if (= n 0) (if (= n 0)
(cons l u) (cons l u)
(lp (cdr l) (cons (car l) u) (- n 1)))))) (lp (cdr l) (cons (car l) u) (- n 1))))))
(<pzip> fail- (<pzip>
(p2 l2 s2 q2 (<apply> pzip (car l-u))) ((<apply> pzip (car l-u)))
(p3 l3 s3 q3 (<apply> pzip (cdr 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 ...@@ -1327,6 +1327,7 @@ MAKE SURE TO REVISIT THIS IDEA LATER
(syntax-rules () (syntax-rules ()
((_ w a ...) ((_ w a ...)
(<with-guile-log> w code ...))))) (<with-guile-log> w code ...)))))
(define-syntax-rule (attvar? x) (gp-attvar? (gp-lookup x S) S)) (define-syntax-rule (attvar? x) (gp-attvar? (gp-lookup x S) S))
(<define> (<attvar?> x) (if (gp-attvar? x S) <cc> <fail>)) (<define> (<attvar?> x) (if (gp-attvar? x S) <cc> <fail>))
(<define> (<attvar-raw?> x) (if (gp-attvar-raw? x S) <cc> <fail>)) (<define> (<attvar-raw?> x) (if (gp-attvar-raw? x S) <cc> <fail>))
......
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