parallell kanren

parent 76333b1f
......@@ -4,7 +4,7 @@
#:use-module (logic guile-log)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
#:export (delay_exp force_exp))
#:export (delay_exp delay_scm force_exp opexp))
(define-record-type <delay>
(make-delay exp var)
......@@ -20,9 +20,35 @@
"
'delay-match'(X,X):-!.
'delay-match'(X,(A,B)) :- 'delay-match'(X,A) -> true : 'delay-match'(X,B).
add_nonvar([X],X) :- !.
add_nonvar([X|L],(nonvar(X),U)) :- add_nonvar(L,U).
delay_exp(Rec,Exp|L) :-
pp(1),
add_nonvar(L,LL),
pp(2),
Goal1 = (LL,Exp),
pp(Goal1),
(
Goal1 ->
true ;
(
Goal2 = Goal1;Rec(|L),
delay_exp0(Goal2|L)
)
).
delay_scm(Rec,Scm,Z|L) :-
pp(0),
delay_exp(Rec,(ZZ is Scm, pp(ZZ), force_exp(Z,ZZ)),Z|L).
opexp(Z,Op,X,Y) :- pp(0),delay_scm(opexp,Op(X,Y),Z,Op,X,Y).
")
(<define> (delay_exp e . l)
(<define> (delay_exp0 e . l)
(<recur> lp ((l l) (hit? #f))
(<<match>> (#:mode -) (l)
(((and x ($ delay?)) . l)
......
(use-modules (ice-9 match))
(use-modules (ice-9 pretty-print))
(define (pretty x)
(pretty-print
(let lp ((x x))
(match x
((x . l)
(if (procedure? x)
(lp l)
(cons (lp x) (lp l))))
(x x)))))
(define (any . x)
(lambda (s p cc)
(match x
(() (p))
((f) (f s p cc))
((f . l) (f s (lambda () ((apply any l) s p cc)) cc)))))
(define (all . x)
(lambda (s p cc)
(match x
(() (cc s p))
((f) (f s p cc))
((f . l) (f s p (lambda (ss pp) ((apply all l) ss pp cc)))))))
(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
(define (get-s x) (x))
(define (mk-v data)
(define vf
(case-lambda
(() data)
((x) (set! data x))))
(set-procedure-property! vf 'vf #t)
vf)
(define (lookup state var)
(define bin (make-hash-table))
(define (bin-here? state)
(aif here? (hashq-ref bin state #f)
here?
(begin
(hashq-set! bin state #t)
#f)))
(let lp ((state state) (cont (lambda () var)))
(match state
((and states #(y ...))
(if (bin-here? states)
(cont)
(let lp2 ((y y))
(match y
((s . sl)
(lp s (lambda () (lp2 sl))))
(()
(cont))))))
(((v . y) . l)
(if (eq? var v)
y
(lp l cont)))
(()
(cont)))))
(define-syntax-rule (fresh (v ...) f ...)
(let ((v (make-variable #f)) ...)
(all f ...)))
(define (all-paralell0 cend l)
(lambda (s p cc)
(match l
(() (cc s p))
((f) (f s p cc))
((f . l)
(letrec ((cc2 (lambda (s2 p2)
(set! cc2 cend)
((all-paralell0 cend l)
s p cc))))
(f s p cc2))))))
(define (wrap-s s)
(list (vector (mk-v s))))
(define (all-paralell s-comb . l)
(lambda (s p cc)
(let ((ss (wrap-s s)))
(letrec ((cc2 (lambda (s2 p2)
(set! cc2 cc)
(cc s-comb p))))
((all-paralell0 cc l)
ss p cc2)))))
(define (sv-value sv vv f)
(lambda (s p cc)
(f s p (lambda (ss pp x)
(vv x)
(sv s)
(cc ss pp)))))
(define-syntax-rule (fresh-sv (data-s : (s v) ...) code ...)
(let ((v (mk-v #f)) ...
(s (mk-v #f)) ...)
(let ((data-s (vector s ...)))
(all code ...))))
(define (repr0 repr-var s data )
(match data
((x . l)
(cons (repr0 repr-var s x) (repr0 repr-var s l)))
(#(a ...)
(apply vector (repr0 repr-var s a)))
(a
(if (variable? a)
(lookup s a)
(if (procedure? a)
(if (procedure-property a 'vf)
(repr0 repr-var s (a))
a)
a)))))
(define (repr s data)
(define vmap (make-hash-table))
(define i 0)
(define (repr-var v)
(aif before? (hashq-ref vmap v #f)
before?
(let ((ret (string->symbol (format #f "v.~a" i))))
(set! i (+ i 1))
(hashq-set! vmap v ret)
ret)))
(repr0 repr-var s data))
(define (scm s data)
(repr0 (lambda (v) v) s data))
(define *env* #f)
(define (ask string . data)
(lambda (s p cc)
(apply format #t string (repr s data))
(set! *env* (list s p data cc))))
(define show
(case-lambda
(()
(match *env*
((s p data . _)
(format #t "Returned Data:~%")
(pretty (repr s data))))
(if #f #f))
((data)
(match *env*
((s p . _)
(format #t "Returned Data:~%")
(pretty (repr s data))
(if #f #f))))))
(define (data)
(match *env*
((s p data . _)
data)))
(define (continue . l)
(match *env*
(( s p data cc)
(apply cc s p l))))
(define (continue-f f)
(match *env*
((s p data cc)
(f s p cc))))
(define (return-p tag . l)
(lambda (s p cc)
(cc s p (cons* tag p l))))
(define-syntax values
(syntax-rules ()
((_ () code ...)
(all code ...))
((_ (((v ...) f) . l) code ...)
(lambda (s p cc)
(f s p (lambda (ss pp v ...)
((values l code ...) ss pp cc)))))))
(define (bind x y) (lambda (s p cc) (cc (cons (cons x y) s) p)))
(define true (lambda (s p cc) (cc s p)))
(define false (lambda (s p cc) (p)))
(define (== x y)
(match (cons x y)
(((x1 . y1) . (x2 . y2))
(all
(== x1 x2)
(== y1 y2)))
((#(a ...) . #(b ...))
(== a b))
(_
(if (variable? x)
(bind x y)
(if (variable? y)
(bind y x)
(if (eqv? x y)
true
false))))))
(define-syntax-rule (wrap f) (lambda (s p cc) (f s p cc)))
(define (run f) (f '() (lambda () #f)
(lambda (s p x)
(pretty (repr s x))
(set! *env* (list s p x))
(if #f #f))))
(define (next)
(match *env*
((s p . _)
(p))))
(define (get . l)
(match *env*
((_ _ data . _)
(let lp ((data data) (l l))
(match l
((i . l)
(lp ((list-ref data (+ 1 i))) l))
(()
data))))))
(define (back . l)
((list-ref (apply get l) 1)))
(define (make-value x)
(any
(return-p #:value x)
(values (((x) (ask "continue with new value x=~a~%" x)))
(make-value x))))
(define (make-point x y)
(any
(fresh-sv (s-point : (sx vx) (sy vy))
(all-paralell s-point
(sv-value sx vx (make-value x))
(sv-value sy vy (make-value y)))
(return-p #:point vx vy))
(values (((x y) (ask "continue with new point '(x=~a y=~a)~%" x y)))
(make-point x y))))
(define (make-link x1 y1 x2 y2)
(any
(fresh-sv (s-link : (s-vp1 vp1) (s-vp2 vp2))
(all-paralell s-link
(sv-value s-vp1 vp1 (make-point x1 y1))
(sv-value s-vp2 vp2 (make-point x2 y2)))
(return-p #:link vp1 vp2))
(values (((x1 y1 x2 y2)
(ask "continue with new link '(x1=~a y1=~a x2=~a y2=~a)~%"
x1 y1 x2 y2)))
(make-link x1 x2 y1 y2))))
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