refinements of paralell kanren

parent c6e37c96
...@@ -39,7 +39,7 @@ ...@@ -39,7 +39,7 @@
(define (lookup state var) (define (lookup state-in var)
(define bin (make-hash-table)) (define bin (make-hash-table))
(define (bin-here? state) (define (bin-here? state)
(aif here? (hashq-ref bin state #f) (aif here? (hashq-ref bin state #f)
...@@ -48,7 +48,7 @@ ...@@ -48,7 +48,7 @@
(hashq-set! bin state #t) (hashq-set! bin state #t)
#f))) #f)))
(let lp ((state state) (cont (lambda () var))) (let lp ((state state-in) (cont (lambda () var)))
(match state (match state
((and states #(y ...)) ((and states #(y ...))
(if (bin-here? states) (if (bin-here? states)
...@@ -62,7 +62,9 @@ ...@@ -62,7 +62,9 @@
(((v . y) . l) (((v . y) . l)
(if (eq? var v) (if (eq? var v)
y (if (variable? y)
(lookup state-in y)
y)
(lp l cont))) (lp l cont)))
(() (()
...@@ -87,14 +89,18 @@ ...@@ -87,14 +89,18 @@
(define (wrap-s s) (define (wrap-s s)
(list (vector (mk-v s)))) (list (vector (mk-v s))))
(define (with-s ss)
(lambda (s p cc) (cc ss p)))
(define (all-paralell s-comb . l) (define (all-paralell s-comb . l)
(lambda (s p cc) (lambda (s p cc)
(let ((ss (wrap-s s))) (let ((ss (wrap-s s)))
(letrec ((cc2 (lambda (s2 p2) (letrec ((cc2 (lambda (ss pp)
(set! cc2 cc) ((with-s s-comb)
(cc s-comb p)))) ss pp cc))))
((all-paralell0 cc l)
ss p cc2))))) ((all-paralell0 cc2 l)
ss p cc2)))))
(define (sv-value sv vv f) (define (sv-value sv vv f)
(lambda (s p cc) (lambda (s p cc)
...@@ -103,10 +109,11 @@ ...@@ -103,10 +109,11 @@
(sv s) (sv s)
(cc ss pp))))) (cc ss pp)))))
(define-syntax-rule (fresh-sv (data-s : (s v) ...) code ...) (define-syntax-rule (fresh-sv (data-s data : (s v) ...) code ...)
(let ((v (mk-v #f)) ... (let ((v (mk-v #f)) ...
(s (mk-v #f)) ...) (s (mk-v #f)) ...)
(let ((data-s (vector s ...))) (let ((data-s (vector s ...))
(data (list 'data v ...)))
(all code ...)))) (all code ...))))
...@@ -142,11 +149,18 @@ ...@@ -142,11 +149,18 @@
(define (scm s data) (define (scm s data)
(repr0 (lambda (v) v) s data)) (repr0 (lambda (v) v) s data))
(define-syntax-rule (wrap f) (lambda x (apply f x)))
(define (repeat f)
(any f (wrap (repeat f))))
(define *env* #f) (define *env* #f)
(define (ask string . data) (define (ask string . data)
(lambda (s p cc) (repeat
(apply format #t string (repr s data)) (lambda (s p cc)
(set! *env* (list s p data cc)))) (apply format #t string (repr s data))
(set! *env* (list s p data cc)))))
(define show (define show
...@@ -245,32 +259,67 @@ ...@@ -245,32 +259,67 @@
(define (back . l) (define (back . l)
((list-ref (apply get l) 1))) ((list-ref (apply get l) 1)))
(define-syntax-rule (k-when x)
(lambda (s p cc)
(if x (cc s p) (p))))
(define (g x . l)
(let lp ((l l) (x x))
(match l
((i . l)
(lp l (list-ref (x) (+ i 1))))
(() x))))
;;;; EXAMPLE A LITTLE GEOMTRY CONSTRUCTOR
(define (make-value x) (define (make-value x)
(any (any
(return-p #:value x) (return-p 'value x)
(values (((x) (ask "continue with new value x=~a~%" x))) (values (((x) (ask "continue with new value x=~a~%" x)))
(make-value x)))) (make-value x))))
(define (make-point x y) (define (make-point x y)
(any (any
(fresh-sv (s-point : (sx vx) (sy vy)) (fresh-sv (s-point point : (sx vx) (sy vy))
(all-paralell s-point (all-paralell s-point
(sv-value sx vx (make-value x)) (sv-value sx vx (make-value x))
(sv-value sy vy (make-value y))) (sv-value sy vy (make-value y)))
(return-p #:point vx vy)) (apply return-p point))
(values (((x y) (ask "continue with new point '(x=~a y=~a)~%" x y))) (values (((x y) (ask "continue with new point '(x=~a y=~a)~%" x y)))
(make-point x y)))) (make-point x y))))
(define (make-link x1 y1 x2 y2) (define (make-link x1 y1 x2 y2)
(any (any
(fresh-sv (s-link : (s-vp1 vp1) (s-vp2 vp2)) (fresh-sv (s-link link : (s-vp1 vp1) (s-vp2 vp2))
(all-paralell s-link (all-paralell s-link
(sv-value s-vp1 vp1 (make-point x1 y1)) (sv-value s-vp1 vp1 (make-point x1 y1))
(sv-value s-vp2 vp2 (make-point x2 y2))) (sv-value s-vp2 vp2 (make-point x2 y2)))
(return-p #:link vp1 vp2))
(k-when (or (not (= (g vp1 1 1) (g vp2 1 1)))
(not (= (g vp1 2 1) (g vp2 2 1)))))
(apply return-p link))
(values (((x1 y1 x2 y2) (values (((x1 y1 x2 y2)
(ask "continue with new link '(x1=~a y1=~a x2=~a y2=~a)~%" (ask "continue with new link '(x1=~a y1=~a x2=~a y2=~a)~%"
x1 y1 x2 y2))) x1 y1 x2 y2)))
(make-link x1 x2 y1 y2)))) (make-link x1 y1 x2 y2))))
(define (make-rectangle xmin ymin xmax ymax)
(any
(fresh-sv (s-rectangle rectangle : (s-vp1 vp1) (s-vp2 vp2))
(all-paralell s-rectangle
(sv-value s-vp1 vp1 (make-point xmin ymin))
(sv-value s-vp2 vp2 (make-point xmax ymax)))
(k-when (and (< (g vp1 1 1) (g vp2 1 1))
(< (g vp1 2 1) (g vp2 2 1))))
(apply return-p rectangle))
(values (((xmin ymin xmax ymax)
(ask "continue with new rectangle '(xmin=~a ymin=~a xmax=~a ymax=~a)~%" xmin ymin xmax ymax)))
(make-rectangle xmin ymin xmax ymax))))
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