new unify routines debugged

parent 60fd8bb9
(define-module (logic guile-log unify)
#:use-module (srfi srfi-9)
#:use-module (logic guile-log)
#:use-module ((logic guile-log umatch)
#:use-module (logic guile-log vlist)
#:use-module ((logic guile-log code-load)
#: select
(prolog-closure-closure
prolog-closure?
gp-lookup
gp-attvar-raw?
gp-car gp-cdr gp-pair?
prolog-closure-state
prolog-closure-closed?))
#:use-module (logic guile-log prolog closed)
#:use-module (logic guile-log guile-prolog namespace)
#:use-module (logic guile-log prolog namespace)
#:export (unify))
(define attributeU (@@ (logic guile-log macros) attributeU))
(define-syntax-rule (mk-unify def (x y sx sy
kind vec build gvar? gid)
(scm ...) (sc ...) defs ...)
(<define> def
(let ()
defs ...
(define-syntax-rule
(mk-unify name def
(x y sx sy kind vec build gvar? gid scm? scm-it
do-scm-x do-scm-y
do-attvar-x do-attvar-y
do-gvar-x do-gvar-y
do-namespace
)
(scm ...)
(sc ...)
defs ...)
(define (name s p cc . def)
defs ...
(define (check x y m)
(if (vhash? x)
(vhash-assoc (cons x y) m)
#f))
(define (check x y m)
(if (vhash? x)
(vhash-assoc (cons x y) m)
#f))
(define (inc x y m)
(if (vhash? m)
(vhash-cons (cons x y) #t m)
(if (< m 10)
(+ m 1)
(vhash-cons (cons x y) #t vlist-null))))
(<define> (do-attvar lp x y m)
(attributeU y x kind)
(<cc> m))
(<define> (do-prolog-closure lp x y m)
(if (eq? (prolog-closure-closure x)
(prolog-closure-closure y))
(lp (prolog-closure-state x)
(prolog-closure-state y) m sc ...)
(if (or (prolog-closure-closed? x)
(prolog-closure-closed? y))
(if (fluid_ref error-when-closed?)
(closed-err x y)))))
(<define> (do-namespace lp x y m)
(if (ns-unify S ns (build sx x) (build sy y) kind)
(<cc> m)
<fail>))
(<define> (do-vector lp x y m)
(if (and (vector? y)
(= (vector-length x)
(vector-length y)))
(if (check x y m)
(<cc> m)
(let ((n (vector-length x)))
(let lpvec ((i 0) (m (inc x y m)))
(if (< i n)
(<and>
(<values>
(m) (lp (vector-ref x i)
(vector-ref y i)
m sc ..))
(lpvece (+ i 1) m))
(<cc> m)))))
<fail>))
(define (inc x y m)
(if (vhash? m)
(vhash-cons (cons x y) #t m)
(if (< m 10)
(+ m 1)
(vhash-cons (cons x y) #t vlist-null))))
(<define> (do-prolog-closure lp x y m sc ...)
(if (eq? (prolog-closure-closure x)
(prolog-closure-closure y))
(lp (prolog-closure-state x)
(prolog-closure-state y) m sc ...)
(if (or (prolog-closure-closed? x)
(prolog-closure-closed? y))
(if (fluid-ref error-when-closed?)
(closed-err x y)))))
(<define> (do-vector lp x y m sc ...)
(if (and (vector? y)
(= (vector-length x)
(vector-length y)))
(if (check x y m)
(<cc> m)
(let ((n (vector-length x)))
(let lpvec ((i 0) (m (inc x y m)))
(if (< i n)
(<and>
(<values>
(m) (lp (vector-ref x i)
(vector-ref y i)
m sc ...))
(lpvec (+ i 1) m))
(<cc> m)))))
<fail>))
(<define> (do-and lp x y m sc ...)
(let ((n (vector-length x)))
(let lp-and ((i 1) (m m))
(if (< i n)
(<and>
(<values> (m) (lp (vector-ref x i) y m sc ...))
(lp-and (+ i 1) m))
(<cc> m)))))
(<define> (do-and lp x y m)
(let ((n (vector-length x)))
(let lp-and ((i 1) (m m))
(if (< i n)
(<and>
(<values> (m) (lp (vector-ref x i) y m sc ...))
(lp-and (+ i 1) m))
(<cc> m)))))
(<define> (do-or lp x y m sc ...)
(let ((n (vector-length x)))
(let lp-or ((i 1) (m m))
(if (< i n)
(<or>
(lp (vector-ref x i) y m sc ...)
(lp-or (+ i 1) m)))
<fail>)))
(<define> (do-or lp x y m)
(let ((n (vector-length x)))
(let lp-or ((i 1) (m m))
(if (< i n)
(<or>
(lp (vector-ref x i) y m sc ...)
(lp-or (+ i 1) m)))
<fail>)))
(<define> (do-cutor lp x y m sc ...)
(let ((n (vector-length x)))
(let lp-or ((i 1) (m m))
(if (< i n)
(<or>
(<and> (lp (vector-ref x i) y m sc ...) <cut>)
(lp-or (+ i 1) m)))
<fail>)))
(<define> (do-cutor lp x y m)
(let ((n (vector-length x)))
(let lp-or ((i 1) (m m))
(if (< i n)
(<or>
(<and> (lp (vector-ref x i) y m sc ...) <cut>)
(lp-or (+ i 1) m)))
<fail>)))
(<define> (do-not lp x y m)
(<and>
(<not>
(lp (vector-ref x 1) y 0 sc ...)
(<cc> m))))
(<define> (do-not lp x y m)
(<and>
(<not>
(lp (vector-ref x 1) y 0 sc ...)
(<cc> m))))
((<lambda> ()
(let lp ((x x) (y y) (m 0) scm ...)
(let ((x (gp-lookup x)) (y (gp-lookup y)))
(let ((x (gp-lookup x S)) (y (gp-lookup y S)))
(cond
((eq? x y)
(<cc> m))
((gp-attvar-raw? x s)
(do-attvar lp x (build S sy y) m))
(do-attvar-x lp x y m sc ...))
((gp-attvar-raw? y s)
(do-attvar lp y (build S sx x) m))
(do-attvar-y lp x y m sc ...))
((and kind (<var?> x))
(<set> x y))
......@@ -122,24 +124,19 @@
(<set> y x))
((scm? x)
(if sy
(unify (scm-it x) y kind)
(lp (scm-it x) y kind #t #f)))
(do-scm-x lp x y m sc ...))
((scm? y)
(if sx
(unify x (scm-it y) kind)
(lp x (scm-it y) kind #f #t)))
(do-scm-y lp x y m sc ...))
((and kind (gvar? x))
(unify (vector-ref vec (gid x)) (build s x) kind))
((gvar? x)
(do-gvar-x x y sc ...))
((and kind (gvar? y))
(unify (build s x)
(vector-ref vec (gid y)) kind))
((gvar? y)
(do-gvar-x x y sc ...))
((gp-pair? x S)
(if (gp-pair? y)
(if (gp-pair? y S)
(if (check x y m)
(<cc> m)
(<and>
......@@ -187,15 +184,15 @@
(if (keyword? a)
(cond
((eq? a #:and)
(do-and lp x y sx sy m))
(do-and lp x y m sc ...))
((eq? a #:or)
(do-or lp x y sx sy m))
(do-or lp x y m sc ...))
((eq? a #:cutor)
(do-cutor lp x y sx sy m))
(do-cutor lp x y m sc ...))
((eq? a #:not)
(do-not lp x y sx sy m))
(do-not lp x y m sc ...))
(else
(do-vector lp x y sx sy m)))
(do-vector lp x y m sc ...)))
(do-vector lp x y m))))
((vector? y)
......@@ -203,28 +200,28 @@
(if (keyword? a)
(cond
((eq? a #:and)
(do-and lp x y sx sy m))
(do-and lp x y m sc ...))
((eq? a #:or)
(do-or lp x y sx sy m))
(do-or lp x y m sc ...))
((eq? a #:cutor)
(do-cutor lp x y sx sy m))
(do-cutor lp x y m sc ...))
((eq? a #:not)
(do-not lp x y sx sy m))
(do-not lp x y m sc ...))
(else
<fail>))
<fail>)))
((namespace? x)
(do-namespace lp x y sx sy m))
(do-namespace lp x y m sc ...))
((namespace? y)
(do-namespace lp y x sx sy m))
(do-namespace lp y x m sc ...))
((prolog-closure? x)
(if (prolog-closure? y)
(if (check x y m)
(<cc> m)
(do-prolog-closure lp x y sx sy (inc x y m)))
(do-prolog-closure lp x y (inc x y m) sc ...))
<fail>))
((prolog-closure? y)
......@@ -233,7 +230,7 @@
(else
(if (equal? x y)
(<cc> m)
<fail>))))))))
<fail>)))))) s p cc)))
(define-record-type <scmwrap>
(make-scmwrap wrap)
......@@ -245,21 +242,55 @@
vec?
(id get-vec-id))
(mk-unify (unify-vec x y kind)
(x y sx sy kind vec build gvar? gid scm? scm-it)
(mk-unify unify-vec (x y kind vec)
(x y sx sy kind vec build gvar? gid scm? scm-it
do-scm-x do-scm-y
do-attvar-x do-attvar-y
do-gvar-x do-gvar-y
do-namespace)
((sx #f) (sy #f))
(sx sy)
(define (gvar? x) (vec? x))
(define (gid x) (get-vec-id x))
(define (scm? x) (scmwrap? x))
(define (scm-it x) (get-scmwrap x))
(<define> (do-gvar-x x y sx sy)
(unify (vector-ref vec (gid x)) (build S sy y) kind))
(<define> (do-gvar-y x y sx sy)
(unify (build S sx x) (vector-ref vec (gid y)) kind))
(<define> (do-scm-x lp x y m sx sy)
(if sy
(unify (scm-it x) y kind)
(lp (scm-it x) y m #t #f)))
(<define> (do-scm-y lp x y m sx sy)
(if sx
(unify x (scm-it y) kind)
(lp x (scm-it y) y m #f #t)))
(<define> (do-attvar-x lp x y m sx sy)
(attributeU (build S sy y) x kind)
(<cc> m))
(<define> (do-attvar-y lp x y m sx sy)
(attributeU (build S sx x) y kind)
(<cc> m))
(<define> (do-namespace lp x y m sc ...)
(if (ns-unify S (build S sx x) (build S sy y) kind)
(<cc> m)
<fail>))
(define (build s p x)
(if p
x
(let lp ((x x))
(let ((x (gp-lookup x s)))
(cond
((gvar? s x)
((gvar? x)
(vector-ref vec (gid x)))
((scm? x)
(scm-it x))
......@@ -289,12 +320,36 @@
x
(vector ay by))))
(else
(apply vector (lp (vector->list x)))))))))))))
(apply vector (lp (vector->list x)))))))
(else
x)))))))
(mk-unify (unify x y kind)
(x y sx sy kind vec build gvar? gid scm? scm-it)
(mk-unify unify (x y kind)
(x y sx sy kind vec build gvar? gid scm? scm-it
do-scm-x do-scm-y
do-attvar-x do-attvar-y
do-gvar-x do-gvar-y
do-namespace)
()
()
(<define> (do-scm-x lp x y m) (<cc> #f))
(<define> (do-scm-y lp x y m) (<cc> #f))
(<define> (do-gvar-x x y) (<cc> #f))
(<define> (do-gvar-y x y) (<cc> #f))
(<define> (do-attvar-x lp x y m)
(attributeU y x kind)
(<cc> m))
(<define> (do-attvar-y lp x y m)
(attributeU x y kind)
(<cc> m))
(<define> (do-namespace lp x y m)
(if (ns-unify S x y kind)
(<cc> m)
<fail>))
(define (gvar? x) #f)
(define (gid x) (get-vec-id x))
(define (scm? x) #f)
......
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