refinements of paralell kanren

parent c6e37c96
......@@ -39,7 +39,7 @@
(define (lookup state var)
(define (lookup state-in var)
(define bin (make-hash-table))
(define (bin-here? state)
(aif here? (hashq-ref bin state #f)
......@@ -48,7 +48,7 @@
(hashq-set! bin state #t)
#f)))
(let lp ((state state) (cont (lambda () var)))
(let lp ((state state-in) (cont (lambda () var)))
(match state
((and states #(y ...))
(if (bin-here? states)
......@@ -62,7 +62,9 @@
(((v . y) . l)
(if (eq? var v)
y
(if (variable? y)
(lookup state-in y)
y)
(lp l cont)))
(()
......@@ -87,13 +89,17 @@
(define (wrap-s s)
(list (vector (mk-v s))))
(define (with-s ss)
(lambda (s p cc) (cc ss p)))
(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)
(letrec ((cc2 (lambda (ss pp)
((with-s s-comb)
ss pp cc))))
((all-paralell0 cc2 l)
ss p cc2)))))
(define (sv-value sv vv f)
......@@ -103,10 +109,11 @@
(sv s)
(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)) ...
(s (mk-v #f)) ...)
(let ((data-s (vector s ...)))
(let ((data-s (vector s ...))
(data (list 'data v ...)))
(all code ...))))
......@@ -142,11 +149,18 @@
(define (scm 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 (ask string . data)
(repeat
(lambda (s p cc)
(apply format #t string (repr s data))
(set! *env* (list s p data cc))))
(set! *env* (list s p data cc)))))
(define show
......@@ -245,32 +259,67 @@
(define (back . l)
((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)
(any
(return-p #:value x)
(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))
(fresh-sv (s-point 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))
(apply return-p point))
(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))
(fresh-sv (s-link 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))
(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)
(ask "continue with new link '(x1=~a y1=~a x2=~a y2=~a)~%"
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