partially wroks

parent 0dc263c8
(define-module (logic guile-log prolog goal-functors) (define-module (logic guile-log prolog goal-functors)
#:use-module ((logic guile-log) #:select #:use-module ((logic guile-log) #:select
(CUT SCUT <if> <define> <match> <<match>> <lambda> (CUT SCUT <if> <define> <match> <<match>> <lambda>
<let> <apply> <cut> <fail> S <values> <let> <apply> <cut> <fail> S <values> <scm>
<and> <with-cut> <cc> <pp> <lookup> <var?> <pp> <cut> <and> <with-cut> <cc> <pp> <lookup> <var?> <pp> <cut>
<code> </.> procedure-name <code> </.> procedure-name
define-guile-log)) define-guile-log))
...@@ -68,9 +68,9 @@ ...@@ -68,9 +68,9 @@
(<define> (subst code vars) (<define> (subst code vars)
(<<match>> (#:mode -) (code) (<<match>> (#:mode -) (code)
(#(("op2*" (and a #((f l))) code)) (#(("op2*" (and a #((f . l))) code))
(<and> (<and>
(<values> (vs) (get-vars l)) (<values> (vs) (get-vars (<scm> l)))
(let ((va (map car vs)) (let ((va (map car vs))
(vb (map cdr vs))) (vb (map cdr vs)))
(<values> (c) (<values> (c)
...@@ -87,19 +87,19 @@ ...@@ -87,19 +87,19 @@
(#(a) (#(a)
(<and> (<and>
(<values> aa (subst a vars)) (<values> (aa) (subst a vars))
(<cc> (lambda (x) (vector (aa x)))))) (<cc> (lambda (x) (vector (aa x))))))
(#(a b) (#(a b)
(<and> (<and>
(<values> aa (subst a vars)) (<values> (aa) (subst a vars))
(<values> bb (subst b vars)) (<values> (bb) (subst b vars))
(<cc> (lambda (x) (vector (aa x) (bb x)))))) (<cc> (lambda (x) (vector (aa x) (bb x))))))
((a . b) ((a . b)
(<and> (<and>
(<values> aa (subst a vars)) (<values> (aa) (subst a vars))
(<values> bb (subst b vars)) (<values> (bb) (subst b vars))
(<cc> (lambda (x) (cons (aa x) (bb x)))))) (<cc> (lambda (x) (cons (aa x) (bb x))))))
(a (a
...@@ -109,7 +109,9 @@ ...@@ -109,7 +109,9 @@
(if r (if r
(let ((r (cdr r))) (let ((r (cdr r)))
(if r (if r
(list-ref x r) (if (number? r)
(list-ref x r)
r)
a)) a))
a))))))) a)))))))
...@@ -129,7 +131,7 @@ ...@@ -129,7 +131,7 @@
(#(("op2*" #((f . val)) code)) (#(("op2*" #((f . val)) code))
(<and> (<and>
(<pp> val) (<pp> val)
(<values> (vars.vals) (get-vars val)) (<values> (vars.vals) (get-vars (<scm> val)))
(let* ((vars (map car vars.vals)) (let* ((vars (map car vars.vals))
(vals (map cdr vars.vals)) (vals (map cdr vars.vals))
(vvars (let lp ((i 0) (vv vars)) (vvars (let lp ((i 0) (vv vars))
...@@ -140,7 +142,7 @@ ...@@ -140,7 +142,7 @@
(code2 #f) (code2 #f)
(lp (<lambda> x (lp (<lambda> x
(goal-eval* cut scut (code2 x))))) (goal-eval* cut scut (code2 x)))))
(<values> (code3) (subst code (cons (cons f lp) vvars))) (<values> (code3) (subst code (cons (cons (<scm> f) lp) vvars)))
(<code> (set! code2 code3)) (<code> (set! code2 code3))
(<apply> lp vals)))) (<apply> lp vals))))
......
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