compiles

parent 507bd438
(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>> (CUT SCUT <if> <define> <match> <<match>> <lambda>
<let> <apply> <cut> <fail> S <let> <apply> <cut> <fail> S <values>
<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))
...@@ -54,63 +54,71 @@ ...@@ -54,63 +54,71 @@
(<define> (get-vars a) (<define> (get-vars a)
(<<match>> (#:mode -) (a) (<<match>> (#:mode -) (a)
((_ . _) ((x . y)
(<cc> a)) (<and>
(<values> (xx) (get-vars x))
(<values> (yy) (get-vars y))
(<cc> (cons xx yy))))
(#("," #(("," x y)) z) (#(("," x y))
(<values> (zz) (get-vars z)) (<cc> (cons x y)))
(<cc> (cons (cons x y) zz)))
(z (<cc> z)))) (z (<cc> z))))
(<define> (subst code vars) (<define> (subst code vars)
(#(("op2*" (and a #((f l))) code)) (<<match>> (#:mode -) (code)
(<values> (vs) (get-vars l)) (#(("op2*" (and a #((f l))) code))
(let ((va (map car vs)) (<and>
(vb (map cdr vs))) (<values> (vs) (get-vars l))
(<values> (c) (let ((va (map car vs))
(subst code (vb (map cdr vs)))
(append (cons* (<values> (c)
(cons f #f) (subst code
(map (lambda (x) (cons (car x) #f)) vs)) (append (cons*
vars))) (cons f #f)
(<values> (l) (subst vb vars)) (map (lambda (x) (cons (car x) #f)) vs))
(<cc> (lambda (x) (vector (list "op2*" vars)))
(map (lambda (v w) (cons v (w x))) (<values> (l) (subst vb vars))
va vb) (<cc> (lambda (x) (vector (list "op2*"
(c x))))))) (map (lambda (v w) (cons v (w x)))
va vb)
(c x))))))))
(#(a) (#(a)
(<values> aa (subst a vars)) (<and>
(<cc> (lambda (x) (vector (aa x))))) (<values> aa (subst a vars))
(<cc> (lambda (x) (vector (aa x))))))
(#(a b) (#(a b)
(<values> aa (subst a vars)) (<and>
(<values> bb (subst b vars)) (<values> aa (subst a vars))
(<cc> (lambda (x) (vector (aa x) (bb x))))) (<values> bb (subst b vars))
(<cc> (lambda (x) (vector (aa x) (bb x))))))
((a . b) ((a . b)
(<values> aa (subst a vars)) (<and>
(<values> bb (subst b vars)) (<values> aa (subst a vars))
(<cc> (lambda (x) (cons (aa x) (bb x))))) (<values> bb (subst b vars))
(<cc> (lambda (x) (cons (aa x) (bb x))))))
(a
(lambda (x)
(let ((r (assq a vars)))
(if r
(let ((r (cdr r)))
(if r
(list-ref x r)
a))
a)))))
(a
(<cc>
(lambda (x)
(let ((r (assq a vars)))
(if r
(let ((r (cdr r)))
(if r
(list-ref x r)
a))
a)))))))
(<define> (goal-eval* cut scut x) (<define> (goal-eval* cut scut x)
(<<match>> (#:mode - #:name goal-eval) ((pp 'goal-eval x)) (<<match>> (#:mode - #:name goal-eval) ((pp 'goal-eval x))
(#((,op2: mod #((n . l)))) (#((,op2: mod #((n . l))))
(<let> ((mod (get-module (procedure-name (<lookup> mod)))) (let ((mod (get-module (procedure-name (<lookup> mod))))
(n (<lookup> n))) (n (<lookup> n)))
(namespace-switch mod (namespace-switch mod
(</.> (</.>
(goal-eval* cut scut (goal-eval* cut scut
...@@ -118,21 +126,23 @@ ...@@ -118,21 +126,23 @@
(procedure-name n)) (procedure-name n))
l))))))) l)))))))
(#(("op2*" #((f val)) code)) (#(("op2*" #((f . val)) code))
(<values> (vars.vals) (get-vals val)) (<and>
(let* ((vars (map car vars.vals)) (<pp> val)
(vals (map cdr vars.vals)) (<values> (vars.vals) (get-vars val))
(vvars (lp ((i 0) (vv vars)) (let* ((vars (map car vars.vals))
(if (pair? vv) (vals (map cdr vars.vals))
(cons (cons (car vv) i) (vvars (let lp ((i 0) (vv vars))
(lp (+ i 1) (cdr vv))) (if (pair? vv)
'()))) (cons (cons (car vv) i)
(code2 #f) (lp (+ i 1) (cdr vv)))
(lp (<lambda> x '())))
(code2 #f)
(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 f lp) vvars)))
(<code> (set! code2 code3)) (<code> (set! code2 code3))
(<apply> lp vals))) (<apply> lp vals))))
(#((f . l)) (#((f . l))
(<let> ((f (<lookup> f))) (<let> ((f (<lookup> 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