finished tabling

parent e819a461
......@@ -24,6 +24,7 @@ SOURCES = \
logic/guile-log/tools.scm \
logic/guile-log/prompts.scm \
logic/guile-log.scm \
logic/guile-log/vlist-macros.scm \
logic/guile-log/collects.scm \
logic/guile-log/canonacalize.scm \
logic/guile-log/kanren.scm \
......
......@@ -8,14 +8,15 @@
(define valn (gensym "CANON-N-"))
(define valf (gensym "CANON-F-"))
(define nothing (lambda (a b c) #f))
(define (canon-it+ x s) (canon-it++ gp->scm nothing x s))
(define (id a b x s) x)
(define (canon-it+ x s) (canon-it++ gp->scm nothing id x s))
(define *canon-it* (make-fluid canon-it+))
(define (canon-it x s) ((fluid-ref *canon-it*) x s))
(define recurs-maps (make-fluid #f))
(define (canon-it++ gp->scm analyze x s)
(define vs vals)
(define tr (make-hash-table))
(define mp (make-hash-table))
(define tr (make-hash-table))
(define mp (make-hash-table))
(define n 0)
(define nn 0)
(call-with-values (lambda () (gp->scm x s))
......@@ -33,9 +34,11 @@
((pair? x)
(cons (lp (car x) #t) (lp (cdr x) #t)))
((vector? x)
(list->vector
(lp (vector->list x) #t)))
((gp-var? x s)
(let ((r (hash-ref tr x)))
(if r
......
......@@ -82,8 +82,6 @@
readline))
(define -n- (@ (logic guile-log guile-prolog readline)
-n-))
(define -has-postpone-frame- (make-fluid #f))
(<wrap> add-fluid-dynamics -has-postpone-frame-)
(define lold #f)
(define *usr-state* (make-fluid #f))
(define stall
......@@ -122,8 +120,8 @@
(define old #f)
(define clear #f)
(define endl #f)
(let* ((l
(with-input-from-port port
(let*
((l (with-input-from-port port
(lambda ()
(let lp ((first? #t) (ch (peek-char)) (r '()) (dot-cont? #f))
(when (eof-object? ch)
......@@ -175,6 +173,8 @@
(if #f #f))
((or fail? help?)
#f)
((pair? action)
action)
((or load save cont ref set old)
#t)
(else
......@@ -360,7 +360,7 @@ conversation1(X,All) :-
wrap_frame,
conversation2(X,All).
tree :- when[(pk (fluid-ref -rec?-))]
tree :- when[(fluid-ref -rec?-)]
-> (do[(fluid-set! -rec?- #f)],write(tree),nl,rational_trees);
when[(fluid-ref -nonrec?-)]
-> (do[(fluid-set! -rec?- #f)],non_rational_trees);
......@@ -370,12 +370,6 @@ conversation2(X,All) :-
do[(fluid-set! -n- (+ (fluid-ref -n-) 1))],
readline_term_str(X,T,[variables(V),variable_names(N)]),
tree,
fluid_guard_dynamic_object(scm[-has-postpone-frame-]),
(when[(not (fluid-ref -has-postpone-frame-))] ->
(
do[(fluid-set! -has-postpone-frame- #t)],
postpone_frame(0,0,100000)
) ; true),
consult(T,V,N,All).
consult(X,V,N,All) :-
......
(define-module (logic guile-log memoize)
#:use-module (logic guile-log vlist)
#:use-module (logic guile-log vlist-macros)
#:use-module (logic guile-log hash)
#:use-module (logic guile-log postpone)
#:use-module ((logic guile-log umatch) #:select
......@@ -31,7 +32,7 @@ Also it is possible to solve inifinite recursion.
((f tag e)
(let ((m (hashq-ref memos f #f)))
(if m
(vhash-ref (fluid-ref m) tag e)
(hash-ref m tag e)
e)))))
(define (add-memo-* F)
......@@ -39,23 +40,11 @@ Also it is possible to solve inifinite recursion.
(lambda (f tag x)
(let ((m (hashq-ref memos f #f)))
(if m
(let ((x (vhash-ref (fluid-ref m) tag #f)))
(let ((x (hash-ref m tag #f)))
(if (not x)
(fluid-set! m (vhash-cons tag (F tag x) (fluid-ref m) ))))
(hash-set! m tag (F tag x))))
(begin
(hashq-set! memos f (<make-vhash>))
(h f tag F))))))) h))
(define (add-table-* F)
(letrec ((h
(lambda (f tag x)
(let ((m (hashq-ref memos f #f)))
(if m
(let ((x (vhash-ref (fluid-ref m) tag #f)))
(if (not x)
(fluid-set! m (vhash-cons tag (F tag x) (fluid-ref m) ))))
(begin
(hashq-set! memos f (<make-vhash>))
(hashq-set! memos f (make-hash-table))
(h f tag F))))))) h))
(define add-memo-p (add-memo-* (lambda (tag x) (lambda (s p cc) (p)))))
......@@ -63,27 +52,36 @@ Also it is possible to solve inifinite recursion.
(<lambda> ()
(<=> x ,(un-canon-it tag))))))
(define add-table-p (lambda x #f))
(define add-table-p
(letrec
((h
(lambda (f tag x s)
(let ((m (hashq-ref memos f #f)))
(if m
(let lp ((l (hash-ref m tag #f)))
(if l
(hash-set! m tag (vhash-cons #t x l))
(lp vlist-null)))
(begin
(hashq-set! memos f (make-hash-table))
(h f tag x s)))))))
h))
(define add-table-cc
(letrec
((F (lambda (s x_)
(let ((tag (canon-it-rec x_ s)))
(<lambda> (x)
(<=> x ,(un-canon-it tag))))))
(h
((h
(lambda (f tag x s)
(let ((m (hashq-ref memos f #f)))
(if m
(let ((l (vhash-ref (fluid-ref m) tag #f)))
(let lp ((l (hash-ref m tag #f)))
(if l
(fluid-set!
m
(vhash-cons tag (cons (F s x) l) (fluid-ref m)))
(fluid-set!
m
(vhash-cons tag (cons (F s x) '()) (fluid-ref m)))))
(let ((c (canon-it-rec x s)))
(when (not (vhash-ref l c #f))
(hash-set! m tag (vhash-cons c x l))))
(lp vlist-null)))
(begin
(hashq-set! memos f (<make-vhash>))
(hashq-set! memos f (make-hash-table))
(h f tag x s)))))))
h))
......@@ -177,29 +175,29 @@ Also it is possible to solve inifinite recursion.
(<define> (table-ref f x) (<=> x ,(vhashq-ref (fluid-ref tables) f #f)))
(define do-tabling
(<case-lambda>
((f tag x first)
(<or>
(rec= x first)
(do-tabling f tag x)))
((f tag x)
(<recur> lp1 ((P '()))
(<let> ((L0 (memo-ref0 f tag '())))
(<recur> lp2 ((L L0))
(if (eq? L P)
(<and>
(if (not (eq? L0 '()))
(postpone 1 1)
<cc>)
(<recur> lp ()
(<let> ((L1 (memo-ref0 f tag '())))
(if (eq? L0 L1)
(<and> (postpone) (lp))
(lp1 L0)))))
(<case-lambda>
((f tag x first)
(<or>
(rec= x first)
(do-tabling f tag x)))
((f tag x)
(<recur> lp ((P vlist-null) (fail? #f))
(<let> ((L0 (memo-ref0 f tag vlist-null)))
(<vhash-fold> P () (key val) next L0
(<and>
(postpone 1 1)
(<recur> lp1 ()
(<let> ((L1 (memo-ref0 f tag '())))
(if (eq? L0 L1)
(<and> (postpone) (lp1))
(lp L0 fail?)))))
(if (eq? key #t)
<fail>
(<or>
(<and> ((car L) x))
(lp2 (cdr L))))))))))
(rec= (un-canon-it key) x)
(next)))))))))
(<define> (memo f . x)
......@@ -223,22 +221,22 @@ Also it is possible to solve inifinite recursion.
(cc CC))
(cond
(me (me))
(first
(rec= first x))
(else
(init-memo-rec f tag x (Q with-backtrack-dynamic-object)
(<lambda> ()
(<with-fail> (lambda ()
(add-memo-p f tag x) (p))
(<with-cc> (lambda (s p . u)
((<lambda> ()
(add-memo-cc f tag x)
(<with-cc> cc <cc>))
s p cc))
(<apply> f x)))))))))
(<define> (tabling f . x)
......@@ -256,15 +254,16 @@ Also it is possible to solve inifinite recursion.
(else
(<let> ((p P))
(init-table f tag x (Q (<lambda> (p c) (c)))
(init-table f tag x (Q (<lambda> (p c) (c)))
(<lambda> ()
(<with-fail> (lambda ()
(add-table-p f tag x)
(add-table-p f tag x #f)
(p))
(<with-cc> (lambda (s p . u)
(add-table-cc f tag x s)
(apply cc s p u))
(postpone-frame 0 0 100000)
(<apply> f x))))))))))
(define (Q D) (<lambda> (h code)
......@@ -460,15 +459,101 @@ Also it is possible to solve inifinite recursion.
x)
(gp-cp++ #t x s))
#|
THIS WAS TOO EXPENSIVE
(<define> (member-rec x l)
(if (pair? l)
(<and>
(<values> (ll) (member-rec x (cdr l)))
(if (not ll)
(<if> (rec== x (car l))
(<cc> l)
(<cc> #f))
(<cc> ll)))
(<cc> #f)))
(define (head? m mh x)
(let ((r (hashq-ref m x)))
(if r
(let ((u (hashq-ref mh x)))
(if u
#f
(begin
(hashq-set! mh x #t)
#t)))
#f)))
(define (recurse? mh x) (hashq-ref mh x))
(<define> (fcanon m mh x l first)
(cond
((and (not first) (head? m mh x))
(<values> (y e) (fcanon m mh x '() #t))
(<let> ((x (if (eq? y x)
x
(cp
(<values> (u) (member-rec x l))
(if u
(if (pp 'eq-u-l (eq? u l))
(<cc> x #f)
(<cc> x u))
(<cc> x #f)))
((recurse? mh x)
(<cc> x #f))
(else
(<let> ((ll (cons x l)))
(<match> (#:mode -r) (x)
((a . b)
(<cut>
(<and>
(<values> (yb eb) (fcanon m mh b ll #f))
(if (pp 'eb eb)
(if (pp '(eq? eb ll) (eq? eb ll))
(<cc> yb #f)
(<cc> yb eb))
(<and>
(<values> (ya ea) (fcanon m mh a ll #f))
(if (pp 'ea ea)
(if (pp '(eq? ea ll) (eq? ea ll))
(<cc> ya #f)
(<cc> ya ea))
(if (pp 'cons-check (and (eq? ya a) (eq? yb b)))
(<cc> x #f)
(<cc> (cons ya yb) #f))))))))
(#(a)
(<cut>
(<let> ((ll (cons x l)))
(<values> (ya ea) (fcanon m mh a ll #f))
(if ea
(if (eq? ea ll)
(<cc> ya #f)
(<cc> ya ea))
(if (eq? ya a)
(<cc> x #f)
(<cc> (vector ya) #f))))))
(a
(<cut>
(<and>
(<cc> a #f))))))))))
(define (canon m mp x s)
(fcanon s (lambda () #f) (lambda (s p x e) (pp 'out x)) m mp x '() #t))
|#
(define (pp . x) (car (reverse x)))
(define (canon-it-rec x s)
(define (id a b x s) x)
(define (analyze mp x s)
(<wrap-s> rec-action s
(<lambda> (y)
(<code> (hashq-set! mp (<lookup> y) #t)))
x))
(canon-it++ gp->scm-rec analyze x s))
(make-fluid-dynamics gp-unifier)
......@@ -557,3 +642,12 @@ Also it is possible to solve inifinite recursion.
gp-unifier gp-raw-unifier gp-m-unifier
*canon-it* *gp->scm* *gp-cp*))
;;; canonizing the self referentials
#|
f(X,L,Y,M)
node(X) -> send(X) ;
head(X) -> do(X,Y), member_rec(X,L,U), U == L -> M=false ; M=U.
[A|B] -> (f(B,[X|L],Z,U), U=true -> f(B,[X|L],Z,U), U = true ->
|#
......@@ -100,7 +100,7 @@
(if (pair? l)
(gp-fluid-set! *n* (car l))
(gp-fluid-set! *n* (+ 1 n)))))
(define (postpone-frame s p cc limit fact maxsize)
(gp-fluid-set *max-limit* (* 10 maxsize))
(gp-fluid-set *maxsize* maxsize)
......
(define-module (logic guile-log vlist-macros)
#:use-module (logic guile-log)
#:use-module (logic guile-log vlist)
#:export (<vhash-each> <vhash-fold>))
(define-syntax-rule (B x) (logand x #xfffffff))
(define-syntax-rule (get-bt-in x) (struct-ref x 0))
(define-syntax-rule (get-n-in x) (B (struct-ref x 1)))
(define-syntax-rule (get-ar x) (vector-ref x 0))
(define-syntax-rule (get-bt x) (vector-ref x 1))
(define-syntax-rule (get-n x) (B (vector-ref x 2)))
(define-syntax-rule (get-s x) (B (vector-ref x 3)))
(define-syntax-rule (get-key a n) (vector-ref a n))
(define-syntax-rule (get-val a s n) (vector-ref a (+ s n)))
(<define-guile-log-rule> (<vhash-each> P (key val) next in finish body)
(<let> ((btstart (get-bt-in P))
(istart (+ (get-n-in P) 1)))
(<letrec> ((f (<lambda> (bt n cc)
(<let> ((s (get-s bt)))
(if (eq? bt btstart)
(if (= s 0)
(cc)
(g bt n istart cc))
(if (= s 0)
(cc)
(f (get-bt bt) (get-n bt)
(<lambda> () (g bt n 0 cc))))))))
(g (<lambda> (bt n i cc)
(<let*> ((ar (get-ar bt))
(s (get-s bt)))
(<recur> lp ((i i))
(<let> ((next (<lambda> () (lp (+ i 1)))))
(if (<= i n)
(<let> ((key (get-key ar i))
(val (get-val ar s i)))
body)
(cc))))))))
(<let> ((x in))
(f (get-bt-in x) (get-n-in x) (<lambda> () finish))))))
(<define-guile-log-rule> (<vhash-fold> P ((seed sin) ...) (key val) next in
finish body)
(<let> ((btstart (get-bt-in P))
(istart (+ 1 (get-n-in P))))
(<letrec> ((f (<lambda> (seed ... bt n cc)
(<let> ((s (get-s bt)))
(if (eq? bt btstart)
(if (= s 0)
(cc seed ...)
(g seed ... bt n istart cc))
(if (= s 0)
(cc seed ...)
(f seed ... (get-bt bt) (get-n bt)
(<lambda> (seed ...)
(g seed ... bt n 0 cc))))))))
(g (<lambda> (seed ... bt n i cc)
(<let*> ((ar (get-ar bt))
(s (get-s bt)))
(<recur> lp ((i i) (seed seed) ...)
(<let> ((next (<lambda> (seed ...)
(lp (+ i 1) seed ...))))
(if (<= i n)
(<let> ((key (get-key ar i))
(val (get-val ar s i)))
body)
(cc seed ...))))))))
(<let> ((x in))
(f sin ... (get-bt-in x) (get-n-in x) (<lambda> (seed ...) finish))))))
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