modern minikanren solver added

parent 5982bbae
......@@ -25,6 +25,7 @@ PSSOURCES = \
logic/guile-log/umatch.scm \
logic/guile-log/attributed.scm \
logic/guile-log/macros.scm \
logic/guile-log/guile-prolog/copy-term.scm \
logic/guile-log/match.scm \
logic/guile-log/undovar.scm \
logic/guile-log/interleave.scm \
......@@ -37,6 +38,7 @@ PSSOURCES = \
logic/guile-log/collects.scm \
logic/guile-log/canonacalize.scm \
logic/guile-log/kanren.scm \
logic/guile-log/minikanren.scm \
logic/guile-log/hash.scm \
logic/guile-log/parsing/scanner.scm \
logic/guile-log/parser.scm \
......@@ -45,11 +47,13 @@ PSSOURCES = \
logic/guile-log/parsing/sch-match.scm \
logic/guile-log/grep.scm \
logic/guile-log/dynlist.scm \
logic/guile-log/inheritance.scm \
logic/guile-log/postpone.scm \
logic/guile-log/util.scm \
logic/guile-log/functional-database.scm \
logic/guile-log/hash-dynamic.scm \
logic/guile-log/dynamic-features.scm \
logic/guile-log/iinterleave.scm \
logic/guile-log/weak-vhash.scm \
logic/guile-log/prolog/varstat.scm \
logic/guile-log/prolog/pre.scm \
......@@ -75,7 +79,6 @@ PSSOURCES = \
logic/guile-log/prolog/goal-transformers.scm \
logic/guile-log/prolog/base.scm \
logic/guile-log/guile-prolog/attribute.scm \
logic/guile-log/guile-prolog/copy-term.scm \
logic/guile-log/prolog/io.scm \
logic/guile-log/prolog/char-conversion.scm \
logic/guile-log/prolog/load.scm \
......@@ -135,9 +138,9 @@ PSSOURCES = \
language/prolog/modules/library/rbtrees.p \
language/prolog/modules/library/forward_chaining.pl \
language/prolog/modules/ex/att.pl \
language/prolog/modules/examples/cluster.pl \
language/prolog/modules/library/clpb.pl \
language/prolog/modules/library/clpfd.pl
language/prolog/modules/examples/cluster.pl
# language/prolog/modules/library/clpb.pl
# language/prolog/modules/library/clpfd.pl
# language/prolog/modules/library/apply_macros.pl
AM_MAKEINFOFLAGS=--force
......
......@@ -13,30 +13,8 @@
get_attr get_attrs del_attr del_attr_x raw_attvar
construct_attr attribute_cstor attach_attribute_cstor
call_residue_vars build_attribut_representation
attribute_prefix del_attrs del_attrs_x))
(<define> (build_attribut_representation res tail x)
(<let> ((x (<lookup> x)))
(if (gp-attvar-raw? x S)
(<recur> lp ((res res)
(l (map (lambda (x)
(let ((res
(attribute-cstor-repr (car x))))
(if res
res
x)))
(gp-att-data x S))))
(if (pair? l)
(<let> ((xx (car l)))
(if (pair? xx)
(<var> (t)
(<=> (,(vector (list put_attr x (car xx) (cdr xx))) . t)
res)
(lp t (cdr l)))
(<var> (t)
((car l) res t x)
(lp t (cdr l)))))
(<=> res tail))))))
attribute_prefix del_attrs del_attrs_x
build_attribut_representation))
(define *touched-attributes* (make-fluid vlist-null))
(<wrap> add-vhash-dynamics *touched-attributes*)
......@@ -174,9 +152,5 @@
(<var> (v)
(<set!> x v))
<cc>)))
(set! (@@ (logic guile-log run) put_attr) put_attr)
......@@ -4,8 +4,8 @@
gp-att-data
gp-make-attribute-from-data))
#:use-module (logic guile-log guile-prolog attribute)
#:use-module (logic guile-log)
#:use-module (logic guile-log macros)
#:use-module (logic guile-log umatch)
#:replace (copy_term)
#:export (duplicate_term
copy-term-2 copy-term-3
......@@ -66,9 +66,13 @@
(<and>
(<code> (variable-set! e y))
(<cc> e z))
(<and>
(<code> (hashq-set! h x #f))
(<cc> y z))))))))
(if (gp-attvar? x S)
(<and>
(<code> (hashq-set! h x y))
(<cc> y z))
(<and>
(<code> (hashq-set! h x #f))
(<cc> y z)))))))))
(else
(<with-guile-log> w (<cc> r '()))))))))
......@@ -80,9 +84,10 @@
(<let*> ((x (<lookup> x)))
(cond
((gp-attvar-raw? x S)
(check (h x y)
(<values> (data) (lp (gp-att-data x S)))
(<code> (set! y (gp-make-attribute-from-data x data)))))
(check (h x y)
(<values> (data) (lp (gp-att-data x S)))
(<code>
(set! y (gp-make-attribute-from-data x data)))))
((gp-var? x S)
(check (h x y)))
......@@ -117,13 +122,15 @@
(x (<cc> x))))))))))
(mk-copy-term-2 copy-term-2 #t)
(mk-copy-term-2 copy-term-2 #t)
(mk-copy-term-2 duplicate-term-2 #f)
(define the-tag (cons 'the 'tag))
(define-syntax-rule (mk-copy-term-3 copy-term-3 reuse?)
(<define> (copy-term-3 x)
(<let> ((h (make-hash-table)))
(define-syntax-rule (mk-copy-term-3 copy-term-3- copy-term-3 reuse?)
(begin
(<define> (copy-term-3- h x)
(<let> ()
(<recur> lp ((x x))
(<let*> ((x (<lookup> x)))
(cond
......@@ -131,10 +138,9 @@
(check (h x y z)
(<var> (repr)
(build_attribut_representation repr '() x)
(<values> (repr2 newrepr) (lp repr))
(<let> ((ret (gp-make-var)))
(<code> (set! y ret))
(<code> (set! z (append repr2 newrepr)))))))
(<code> (set! z (<scm> repr)))))))
((gp-var? x S)
(check (h x y z)))
......@@ -175,11 +181,21 @@
(<let> ((ret (vector aa bb)))
(<code> (set! y ret))
(<code> (set! z (append la lb)))))))
(x (<cc> x '()))))))))))
(mk-copy-term-3 copy-term-3 #t)
(mk-copy-term-3 duplicate-term-3 #f)
(x (<cc> x '())))))))))
(<define> (copy-term-3 p)
(<let> ((h (make-hash-table)))
(<values> (pp lq) (copy-term-3- h p))
(<recur> lp ((p lq) (l '()))
(<values> (q lq) (copy-term-3- h p))
(<let> ((lq (<lookup> lq))
(l (<lookup> l )))
(if (null? lq)
(<cc> pp (append q l))
(lp lq (append q l)))))))))
(mk-copy-term-3 copy-term-3- copy-term-3 #t)
(mk-copy-term-3 duplicate-term-3- duplicate-term-3 #f)
(define copy_term
(<case-lambda>
......@@ -204,5 +220,3 @@
(define (cp x s) (copy-term-2 s (lambda () #f) (lambda (s p x) x) x))
(set! (@@ (logic guile-log prolog error) ecp) cp)
(set! (@@ (logic guile-log prompts) cp) cp)
(define-module (logic guile-log iinterleave)
#:use-module (logic guile-log)
#:use-module ((logic guile-log umatch)
#:select (gp-rebased-level-ref gp-restore-wind
gp-store-state))
#:use-module (logic guile-log dynamic-features)
#:export (<or-ii> <and-ii> init-machines new-machine))
(define machine
(make-fluid (cons
(lambda (x) (error "no minikanren machine defined"))
0)))
(<wrap> add-fluid-dynamics machine)
(<define> (new-machine)
(fluid-guard-dynamic-object machine)
(machine-base))
(<define> (init-machines)
(state-guard-dynamic-object machine)
(new-machine))
(define (get-machine) (fluid-ref machine))
(<define> (machine-base)
(<let-with-guard> wind guard ((path '()) (head '()) (tail '()))
(guard
(<lambda> ()
(<let*> ((pack (lambda ()
(let lp ((h head) (t tail) (p path))
(if (null? p)
(begin
(set! head h)
(set! tail t)
(set! path '()))
(let ((l (vector h t)))
(let* ((x (car p))
(h (vector-ref x 0))
(t (vector-ref x 1)))
(lp h (cons l t) (cdr p))))))))
(next (lambda ()
(pack)
(let lp ((h head) (t tail) (p path))
(cond
((pair? h)
(let ((r (car h)))
(cond
((vector? r)
(lp (vector-ref r 0) (vector-ref r 1)
(cons (vector (cdr h) t) p)))
((pair? r)
(let ((hh (car r))
(tt (cdr r)))
(if (not (null? tt))
(set! tail (cons tt t))
(set! tail t))
(set! head (cdr h))
(set! path p)
hh))
(else
(set! head (cdr h))
(set! tail t)
(set! path p)
r))))
(else
(if (pair? t)
(lp (reverse t) '() p)
(if (pair? p)
(let ((x (car p)))
(lp (vector-ref x 0)
(vector-ref x 1) (cdr p)))
P)))))))
(mac (case-lambda
(()
(next))
((x)
(set! tail (cons x tail))
(next))
((prepend? l)
(if prepend?
(set! head (cons (vector l '()) head))
(set! tail (cons (vector l '()) tail))))))
(p (lambda () ((mac)))))
(<code>
(fluid-set! machine (cons mac wind)))
(<with-fail> p <cc>))))))
(define-guile-log <and-ii>
(syntax-rules ()
((and-ii w x) (<and> w x))
((and-ii w x ...) (<and> w (and-ii* (<lambda> () x) ...)))))
(define and-ii*
(<case-lambda>
(() <cc>)
((x) (x))
((x . l)
(<let*> ((y (<lambda> () (<apply> and-ii* l)))
(mac.wind (get-machine))
(mac (car mac.wind))
(wind (cdr mac.wind))
(cc
(lambda (s p)
(let* ((state (gp-store-state s))
(cc (lambda ()
(gp-restore-wind
state (gp-rebased-level-ref wind))
(y s p CC))))
((mac cc))))))
(<with-cc> cc (x))))))
(define-guile-log <or-ii>
(syntax-rules ()
((<or-ii> w)
(<and> w <fail>))
((<or-ii> w x)
(<and> w x))
((<or-ii> w x ...) (<and> w (or-ii* (<lambda> () x) ...)))))
(<define> (or-ii* . l)
(<let*> ((state (gp-store-state S))
(mac.wind (get-machine))
(wind (cdr mac.wind))
(mac (car mac.wind))
(cc
(lambda (s p)
(let ((p* (let ((state (gp-store-state s)))
(lambda ()
((mac
(lambda ()
(gp-restore-wind
state (gp-rebased-level-ref wind))
(p))))))))
(CC s p*))))
(p
(lambda () ((mac))))
(l2
(map (lambda (f)
(lambda ()
(gp-restore-wind
state (gp-rebased-level-ref wind))
(f S p cc)))
l))
(a
(lambda (s* p* cc*) ((mac)))))
(<code> (mac #f (list (append l2 (list P)))))
(a)))
This diff is collapsed.
......@@ -367,3 +367,8 @@ sort(X,L) :- msort(X,LL),unique(LL,L).
(set-procedure-property! list 'name 'list)
(export-scm)
(set! (@@ (logic guile-log prolog error) ecp)
(@@ (logic guile-log guile-prolog copy-term) cp))
(set! (@@ (logic guile-log prompts) cp)
(@@ (logic guile-log guile-prolog copy-term) cp))
......@@ -44,6 +44,7 @@
<raw-attvar> <attvar-raw?> <set> <set!>
<with-log-in-code>
dls-match
build_attribut_representation
))
(define old-pn (@ (guile) procedure-name))
......@@ -1272,13 +1273,16 @@ MAKE SURE TO REVISIT THIS IDEA LATER
(<define> (<attvar?> x) (if (gp-attvar? x S) <cc> <fail>))
(<define> (<attvar-raw?> x) (if (gp-attvar-raw? x S) <cc> <fail>))
(<define> (<put-attr> x m v)
(<code> (gp-put-attr x m v S)))
(<let> ((s (gp-put-attr x m v S)))
(<with-s> s <cc>)))
(<define> (<put-attr-guarded> x m v)
(<code> (gp-put-attr-guarded x m v S)))
(<let> ((s (gp-put-attr-guarded x m v S)))
(<with-s> s <cc>)))
(<define> (<put-attr-weak-guarded> x m v)
(<code> (gp-put-attr-weak-guarded x m v S)))
(<let> ((s (gp-put-attr-weak-guarded x m v S)))
(<with-s> s <cc>)))
(<define> (<put-attr!> x m v)
(<code> (gp-put-attr! x m v S)))
......@@ -1308,7 +1312,7 @@ MAKE SURE TO REVISIT THIS IDEA LATER
(ret (gp-get-attr x m S)))
(when ret
(doit_off)
(<r=> v ,(gp-lookup-1 ret))
(<r=> v ,(gp-lookup-1 ret S))
(doit_on))))
(<define> (<del-attr> x m) (<code> (gp-del-attr x m S)))
......@@ -1433,3 +1437,6 @@ MAKE SURE TO REVISIT THIS IDEA LATER
(cc (lambda x #t))
(s (fluid-ref *current-stack*)))
(parse<> (p s p cc) (<and> code ...))))
(define build_attribut_representation #f)
(define-module (logic guile-log minikanren)
#:use-module (logic guile-log)
#:use-module ((logic guile-log umatch)
#:select (gp-attvar-raw? set-attribute-cstor!))
#:use-module (logic guile-log run)
#:use-module (logic guile-log iinterleave)
#:use-module (logic guile-log guile-prolog attribute)
#:re-export (init-machines new-machine)
#:export
(conde fresh == =/= symbolo numbero booleano
run run* absento
pko pkdyno similar))
(define touch (make-fluid (make-hash-table)))
(define (init) (fluid-set! touch (make-hash-table)))
(define-syntax-rule (conde (x ...) ...)
(<lambda> ()
(<or-ii> (<and> (x) ...) ...)))
(define-syntax-rule (fresh (v ...) code ...)
(<lambda> ()
(<var> (v ...) (<and> (code) ...))))
(define-syntax-rule (== x y) (<lambda> () (<=> ,x ,y)))
(define (pko x)
(<lambda> () (<pp> x)))
(define (pkdyno x y)
(<lambda> () (<pp-dyn> x y)))
(define-inlinable (ground-<type>? pred)
(lambda (u s)
(pred (gp-lookup u s))))
(define ground-symbol?
(ground-<type>? symbol?))
(define ground-number?
(ground-<type>? number?))
(<define> (abs->abs test u)
(<var> (w)
(<if> (<get-attr> u isAbsent w)
(<let*> ((w (<lookup> w))
(new
(call-with-values
(lambda ()
(let lp ((l w))
(define (f x l d dd)
(if (eq? (cdr l) d)
l
(cons x d)))
(if (pair? l)
(call-with-values (lambda () (lp (cdr l)))
(lambda (d dd)
(let ((d (lp (cdr l)))
(x (car l)))
(cond
((attvar? x)
(values
(f x l d (cdr l))
dd))
((test x)
(values d (cons (cons u x) dd)))
(else
(values d dd))))))
(values '() '()))))
(lambda x x)))
(d (car new))
(dd (cadr new)))
(if (eq? d w)
<cc>
(<and>
(if (eq? d '())
(<del-attr> u isAbsent)
(<put-attr> u isAbsent d))
(if (eq? dd '())
<cc>
(<var> (w)
(<if> (<get-attr> u isNot w)
(<put-attr> u isNot (append dd (<lookup> w)))
(<put-attr> u isNot dd)))))))
<cc>)))
(define (symbolo u)
(<lambda> ()
(abs->abs symbol? u)
(<let> ((u (<lookup> u)))
(if (attvar? u)
(if (gp-attvar-raw? u S)
(<var> (w)
(<if> (<get-attr> u isSymbol w)
<cc>
(<if> (<or> (<get-attr> u isNumber w)
(<get-attr> u isBoolean w))
<fail>
(<put-attr> u isSymbol #t))))
(<put-attr> u isSymbol #t))
(when (ground-symbol? u S))))))
(define (booleano u)
(<lambda> ()
(abs->abs boolean? u)
(<let> ((u (<lookup> u)))
(if (attvar? u)
(if (gp-attvar-raw? u S)
(<var> (w)
(<if> (<get-attr> u isBoolean w)
<cc>
(<if> (<or> (<get-attr> u isNumber w)
(<get-attr> u isSymbol w))
<fail>
(<put-attr> u isBoolean #t))))
(<put-attr> u isSymbol #t))
(when (ground-symbol? u S))))))
(define (numbero u)
(<lambda> ()
(<let> ((u (<lookup> u)))
(abs->abs number? u)
(if (attvar? u)
(if (gp-attvar-raw? u S)
(<var> (w)
(<if> (<get-attr> u isSymbol w)
<fail>
(<if> (<or> (<get-attr> u isNumber w)
(<get-attr> u isBoolean w))
<cc>
(<put-attr> u isNumber #t))))
(<put-attr> u isNumber #t))
(when (ground-number? u S))))))
(define-syntax-rule (run n vs c ...)
(begin
(<clear>)
(with-fluids ((*gp-var-tr* '_.)
(*init-tr* init))
(<run> n vs
(<and>
(<logical++>)
(init-machines)
(<and> (c) ...))))))
(define-syntax-rule (run* vs c ...)
(begin
(<clear>)
(with-fluids ((*gp-var-tr* '_.)
(*init-tr* init))
(<run> * vs
(<and>
; (<logical++>)
(init-machines)
(<and> (c) ...))))))
(<define> (isAbsent val newval z)
(<recur> lp ((val (<lookup> val)))
(if (pair? val)
(<and>
(abse (car val) newval)
(lp (cdr val)))
<cc>)))
(<define> (pisAbsent h t v)
(<var> (w)
(<get-attr> v isAbsent w)
(<=> h ,`(,@(map (lambda (x) `(absento (,x ,v))) (<lookup> w)) . ,t))))
(set-attribute-cstor! isAbsent pisAbsent)
(<define> (abse u v)
(<let> ((u (<lookup> u)))
(<recur> lp ((v v))
(<<match>> (#:mode -) (v)
((? attvar? v)
(<let> ((v (<lookup> v)))
(if (gp-attvar-raw? v S)
(<var> (w)
(<cond>
((<get-attr> v isSymbol w)
(if (symbol? u)
(=/=* v u)
<cc>))
((<get-attr> v isBoolean w)
(if (boolean? u)
(=/=* v u)
<cc>))
((<get-attr> v isNumber w)
(if (number? u)
(=/=* v u)
<cc>))
((<get-attr> v isAbsent w)
(<let> ((w (<lookup> w)))
(if (member u w)
<cc>
(<put-attr> v isAbsent (cons u w)))))
(else
(<put-attr> v isAbsent (list u)))))
(<put-attr> v isAbsent (list u)))))
(,u <fail>)
((x . y)
(<and> (lp x) (lp y)))
(_ <cc>)))))
(define-inlinable (absento u v)
(<lambda> ()
(abse u v)))
(<define> (isNumber x y z)
(if (number? (<lookup> y))
<cc>
<fail>))
(<define> (pisNumber a tail x)
(<=> a (,`(num ,x) . tail)))
(set-attribute-cstor! isNumber pisNumber)
(define isSymbol
(<lambda> (x y z)
(if (symbol? (<lookup> y))
<cc>
<fail>)))
(<define> (pisSymbol a tail x)
(<=> a (,`(sym ,x) . tail)))
(set-attribute-cstor! isSymbol pisSymbol)
(define isBoolean
(<lambda> (x y z)
(if (boolean? (<lookup> y))
<cc>
<fail>)))
(<define> (pisBoolean a tail x)
(<=> a (,`(bool ,x) . tail)))
(set-attribute-cstor! isBoolean pisBoolean)
(define isNot
(<lambda> (val y z)
(<recur> lp ((val (<lookup> val)))
(if (pair? val)
(<and>
(=/=* (caar val) (cdar val))
(lp (cdr val)))
<cc>))))
(<define> (pisNot a tail x)
(<var> (r)
(<get-attr> x isNot r)
(<recur> lp ((r (<lookup> r)) (a a))
(if (pair? r)
(<let*> ((d (<lookup> (car r)))
(q (hashq-ref (fluid-ref touch) d #f)))
(if q
(lp (cdr r) a)
(<var> (t)
(<code> (hashq-set! (fluid-ref touch) d #t))
(<=> a ,`((=/= ,r) . ,t))
(lp (cdr r) t))))
(<=> a tail)))))
(set-attribute-cstor! isNot pisNot)
(<define> (add-test var test)
(<var> (v)
(<if> (<get-attr> var isNot v)
(<let> ((head (car test))
(tail (cdr test))
(v (<lookup> v)))
(<recur> lp ((vv v))
(if (pair? vv)
(if (and (eq? (<lookup> (caar vv)) head)
(eq? (<lookup> (cdar vv)) tail))
<cc>
(lp (cdr vv)))
(<put-attr> var isNot (cons test v)))))
(<put-attr> var isNot (list test)))))
(<define> (=/=* uu vv)
(<let> ((fr (<newframe>))
(test (cons (<lookup> uu) (<lookup> vv)))
(true #f)
(var #f))
(<recur> lp ((u uu) (v vv))
(<let> ((u (<lookup> u))
(v (<lookup> v)))
(if (attvar? u)
(<and>
(<code> (set! var #t))
(add-test u test))
<cc>)
(if (attvar? v)
(<and>
(<code> (set! var #t))
(add-test v test))
<cc>)
(if (not var)
(<<match>> (#:mode -) (u v)