1) added support for newer guile distributions 2) added full support for…

1) added support for newer guile distributions 2) added full support for coroutines that generates many answers and backtracks
parent ed86ca2f
......@@ -19,9 +19,9 @@ SOURCES = \
logic/guile-log/umatch.scm \
logic/guile-log/attributed.scm \
logic/guile-log/macros.scm \
logic/guile-log/run.scm \
logic/guile-log/undovar.scm \
logic/guile-log/interleave.scm \
logic/guile-log/run.scm \
logic/guile-log/tools.scm \
logic/guile-log/prompts.scm \
logic/guile-log.scm \
......
......@@ -6,9 +6,5 @@
(compile-prolog-string
"
- adaptable_vars.
f1(X) :- X=[1,Y],Y=1.
- adaptable_vars.
f2(X) :- X=[1,Y],Y=2.
")
\ No newline at end of file
f(1).
")
......@@ -6,6 +6,7 @@
#:use-module (logic guile-log tools)
#:use-module (logic guile-log run)
#:use-module (logic guile-log prompts)
#:use-module (logic guile-log undovar)
#:re-export (gp-cons! gp-lookup gp-var! gp->scm gp-unify! gp-unify-raw! gp-m-unify!)
#:export (umatch))
......@@ -20,3 +21,4 @@
(re-export-all (logic guile-log tools))
(re-export-all (logic guile-log run))
(re-export-all (logic guile-log prompts))
(re-export-all (logic guile-log undovar))
......@@ -3,11 +3,13 @@
#:use-module (ice-9 match-phd)
#:use-module (logic guile-log guile-log-pre)
#:use-module (logic guile-log umatch)
#:use-module (logic guile-log undovar)
#:use-module (ice-9 pretty-print)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (system repl repl)
#:re-export (define-and-log
define-guile-log guile-log-macro? log-code-macro
log-code-macro?)
#:export (<next> <or> <and> <not> <cond> <if> <scm-if> <fast-if>
functorize adaptable_vars
......@@ -26,7 +28,6 @@
let<>
<state-ref> <state-set!> <lv*> <clear>
tr S P CC CUT <scm>
<with-generators> <next-generator-value>
<cons> <cons?> <var?> <values> <windlevel>
<syntax-parameterize>
<car> <cdr> <logical++> <logical-->
......@@ -44,8 +45,6 @@
(define (<wrap-s> f s . l)
(apply f s (lambda x #f) (lambda (s . x) s) l))
(re-export define-and-log
define-guile-log guile-log-macro? log-code-macro log-code-macro?)
(if (not (defined? 'syntax-parameterize))
......@@ -54,6 +53,7 @@
'syntax-parameterize
(module-ref (current-module) 'fluid-let-syntax)))
(define-syntax-parameter S
(lambda (x) (error "S should be bound by fluid-let")))
(define-syntax-parameter P
......@@ -596,6 +596,23 @@
(define <next> (lambda x x))
(define-guile-log <recur>
(syntax-rules ()
((_ (cut s p cc) n ((w v) ...) code ...)
(letrec ((n (lambda (ss pp cccc w ...)
(gp-gc)
(<with-guile-log> (cut ss pp cccc)
(<and> code ...)))))
(parse<> (cut s p cc)
(n v ...))))))
(define-guile-log <letrec>
(syntax-rules ()
((_ (cut s p cc) ((v . lam) ...) code ...)
(letrec ((v . lam) ...)
(parse<> (cut s p cc)
(<and> code ...))))))
(define-syntax get-module
(lambda (x)
#`'#,(datum->syntax #'<next>
......@@ -612,6 +629,44 @@
(set-procedure-property! name 'module get-module)
name)))))
(define delayers (@@ (logic guile-log code-load) *delayers*))
(define (get-del l old)
(let lp ((l l) (r '()))
(if (eq? l old)
r
(lp (cdr l) (cons (car l) r)))))
(<define> (dls old)
(<recur> lp ((l (get-del (fluid-ref delayers) old)))
(if (eq? l old)
(<code> (fluid-set! delayers old))
(<let> ((x (car l)))
(<apply> (car x) (cdr x))
(lp (cdr l))))))
(define-syntax-rule (dls-wrap (cut s p cc) code)
(let* ((old (fluid-ref delayers))
(p2 (lambda ()
(fluid-set! delayers old)
(p)))
(cut2 (lambda ()
(fluid-set! delayers old)
(cut))))
(<and> (cut2 s p2 cc)
code
(if (eq? (fluid-ref delayers) old)
<cc>
(dls old)))))
(define-syntax-rule (dls-match (cut s p cc) old code ...)
(<and> (cut s p cc)
(if (eq? (fluid-ref delayers) old)
<cc>
(dls old))
code ...))
(define *depth* (make-fluid))
(define-guile-log <match>
......@@ -695,23 +750,6 @@
(define-guile-log <recur>
(syntax-rules ()
((_ (cut s p cc) n ((w v) ...) code ...)
(letrec ((n (lambda (ss pp cccc w ...)
(gp-gc)
(<with-guile-log> (cut ss pp cccc)
(<and> code ...)))))
(parse<> (cut s p cc)
(n v ...))))))
(define-guile-log <letrec>
(syntax-rules ()
((_ (cut s p cc) ((v . lam) ...) code ...)
(letrec ((v . lam) ...)
(parse<> (cut s p cc)
(<and> code ...))))))
(define-syntax find-last0
(syntax-rules ()
((_ args v wc me as)
......@@ -748,10 +786,12 @@
(define-syntax find-last**
(syntax-rules ()
((_ (m nm dd) (pr ...) args v ((a)) ((b) ...) (cut s p cc))
(umatch (#:dual dd #:mode m #:status s #:tag <next> #:name nm) ()
((<with-guile-log> (cut s <next> cc) b))
...
((<with-guile-log> (cut s p cc) a))))
(let ((del (fluid-ref delayers)))
(umatch (#:clear del #:dual dd #:mode m #:status s
#:tag <next> #:name nm) ()
((dls-match (cut s <next> cc) del b))
...
((dls-match (cut s p cc) del a)))))
((_ m pr args v (a aa ...) (b ...) wc)
(find-last** m pr args v (aa ...) (b ... a) wc))
......@@ -759,12 +799,14 @@
((_ (m nm dd) (pr ...) args v ((as ...)) ((aas ...) ...) ((a)) ((b) ...)
(cut s p cc))
(umatch (#:dual dd #:mode m #:status s #:tag <next> #:name nm)
v
(aas ... (<with-guile-log> (cut s <next> cc) b))
...
(let ((del (fluid-ref delayers)))
(umatch (#:clear del #:dual dd #:mode m #:status s #:tag <next>
#:name nm)
v
(aas ... (dls-match (cut s <next> cc) del b))
...
(as ... (<with-guile-log> (cut s p cc) a))))
(as ... (dls-match (cut s p cc) del a)))))
((_ m pr args v ((as ...) (aas ...) ...) ((aass ...) ...) ((a) (aa) ...)
((b) ...) wc)
......@@ -813,35 +855,6 @@
;;TODO, this will unify with a cyclic check!
;;Not possible to use a pure raw form here
(define delayers (@@ (logic guile-log code-load) *delayers*))
(define (get-del l old)
(let lp ((l l) (r '()))
(if (eq? l old)
r
(lp (cdr l) (cons (car l) r)))))
(<define> (dls old)
(<recur> lp ((l (get-del (fluid-ref delayers) old)))
(if (eq? l old)
(<code> (fluid-set! delayers old))
(<let> ((x (car l)))
(<apply> (car x) (cdr x))
(lp (cdr l))))))
(define-syntax-rule (dls-wrap (cut s p cc) code)
(let* ((old (fluid-ref delayers))
(p2 (lambda ()
(fluid-set! delayers old)
(p)))
(cut2 (lambda ()
(fluid-set! delayers old)
(cut))))
(<and> (cut2 s p2 cc)
code
(if (eq? (fluid-ref delayers) old)
<cc>
(dls old)))))
(define-guile-log <=>
(syntax-rules ()
......@@ -1036,22 +1049,7 @@ MAKE SURE TO REVISIT THIS IDEA LATER
(let ((ss (gp-new-wind-level s)))
(parse<> (cut ss p cc))))))
(define-guile-log <with-generators>
(syntax-rules ()
((_ w ((x i) ...) code ...)
(<let-with-lr-guard> w wind lg rg ((x i) ...)
(lg (</.> code ...))))))
(define-guile-log <next-generator-value>
(syntax-rules ()
((_ w kons v x)
(begin
(set! v (kons (<scm> x) v))
(parse<> w <cc>)))))
(define-syntax <%p-values%>
(lambda (x)
(syntax-case x ()
......@@ -1215,3 +1213,5 @@ MAKE SURE TO REVISIT THIS IDEA LATER
(if (<var?> x)
(<with-s> (gp-set! x y S) <cc>)))
......@@ -2,10 +2,25 @@
#:use-module (logic guile-log umatch)
#:use-module (logic guile-log macros)
#:use-module (logic guile-log interleave)
#:use-module (logic guile-log undovar)
#:export (<f-vector> <vector> <fold> <fold-step> <fix-fold> <fix-fold-step>
<member> <uniq> m=))
<member> <uniq> m=
<with-generators> <next-generator-value>))
(define-guile-log <with-generators>
(syntax-rules ()
((_ w ((x i) ...) code ...)
(<let-with-lr-guard> w wind lg rg ((x i) ...)
(lg (</.> code ...))))))
(define-guile-log <next-generator-value>
(syntax-rules ()
((_ w kons v x)
(begin
(set! v (kons (<scm> x) v))
(parse<> w <cc>)))))
(<define> (<member> X L)
(<match> (#:name '<member>) (L)
((Y . _) (<=> X Y))
......@@ -78,10 +93,12 @@
(<define> (<uniq> Lam Y)
(<let-with-lr-guard> wind lguard rguard ((l '()))
(lguard Lam)
(<not> (<umember> Y l))
(<code> (set! l (cons (<cp> Y) l)))
(rguard (</.> <cc>))))
(lguard
(</.>
(Lam)
(<not> (<umember> Y l))
(<code> (set! l (cons (<cp> Y) l)))
(rguard (</.> <cc>))))))
;; This is a slow n² algorithm using the functional database
;; Indexing Framework, it can be designed to be essentially n¹
......
(define-module (logic guile-log undovar)
#:use-module (logic guile-log macros)
#:use-module (logic guile-log guile-log-pre)
#:use-module (logic guile-log umatch)
#:use-module (ice-9 match)
#:use-module (ice-9 pretty-print)
......@@ -181,4 +182,3 @@
...)
(let () code ...)))))))))))
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