further improvements to full ttabling

parent ad122a37
......@@ -68,6 +68,7 @@
(match-next abs s v (atom (set! atom)) (pat . body) ...)))
))
(define-syntax match-next
(syntax-rules (=> ->)
;; no more clauses, the match failed
......@@ -104,6 +105,17 @@
;(pk `(match-one ,(syntax->datum (syntax l))))
(syntax (match-one* . l))))))
(define-syntax match-one+
(lambda (x)
(syntax-case x ()
((match-one+ (abs ((car cdr pair? null? equal? id . u_) pp)) s v . l)
;(pk `(match-one ,(syntax->datum (syntax l))))
(syntax (let ((w (id v s)))
(match-one* (abs ((car cdr pair? null? equal? id . u_) pp)) s
w . l)))))))
(define-syntax abs-drop
(syntax-rules ()
......
......@@ -17,20 +17,23 @@
(define tr (make-hash-table))
(define mp (make-hash-table))
(define n 0)
(analyze mp x s)
(define nn 0)
(pk 'gp->scm gp->scm)
(call-with-values (lambda () (gp->scm x s))
(lambda (x s)
(lambda (x)
(pk 'scm x)
(analyze mp x s)
(pk 'anal)
(let lp ((x x) (first #t))
(cond
((and (hash-ref mp x) first)
((and first (hashq-ref mp x))
(if (hash-ref tr x)
x
(let ((i n))
(set! n (+ n 1))
(hash-set! tr x (cons valf n))
(hash-ref tr x)
(let ((i nn))
(set! nn (+ nn 1))
(hash-set! tr x (cons valf i))
(cons* valf i (lp x #f)))))
((pair? x)
(cons (lp (car x) #t) (lp (cdr x) #t)))
((vector? x)
......@@ -60,10 +63,11 @@
(define vs vals)
(define n 0)
(define tr (make-hash-table))
(pk 'uncanon
(let lp ((x x))
(cond
((pair? x)
(if (pair? vs)
(if (and (pair? vs) (not (eq? (car x) valf)))
(cons (lp (car x)) (lp (cdr x)))
(let ((ca (car x))
(cd (cdr x)))
......@@ -98,5 +102,5 @@
(hash-set! tr x untag)
untag)
x)))
x)))))
x))))))
......@@ -486,8 +486,10 @@ before. This works very much like a fluid
(e (ref h))
(bt (mk api e h ref (dobt))))
(backtrack-add bt s)
(gp-fluid-set bt e)
(code s p
(lambda (s p)
(gp-fluid-set bt e)
(backtrack-remove h s)
(cc s p))))))))
......@@ -504,11 +506,12 @@ before. This works very much like a fluid
(e (ref h))
(bt (mk api e h ref (dobt))))
(backtrack-add bt s)
(gp-fluid-set bt e)
(let ((old-bt (bt)))
(code s p
(lambda (s pp)
(backtrack-remove h s)
(bt old-bt)
(backtrack-remove h s)
(gp-fluid-set bt e)
(cc s p)))))))))
......
......@@ -414,9 +414,9 @@ solve(X) :- X.
(<lookup> x) #t)))
x))
(<define> (vtosym-guard x)
(<define> (vtosym-guard x s)
(<let> ((a (car x)))
(if (or (gp? a) (pair? a) (vector? a) (struct? a))
(if (or (gp-pair? a s) (pair? a) (vector? a) (struct? a))
(<let> ((b (hashq-ref (fluid-ref recurs-map) a #f)))
(if (eq? b #t)
(<code> (hashq-set! (fluid-ref recurs-map) a (cadr x)))
......
......@@ -3,7 +3,7 @@
#:use-module (logic guile-log hash)
#:use-module (logic guile-log postpone)
#:use-module ((logic guile-log umatch) #:select
(gp-unifier gp-raw-unifier gp-m-unifier gp?))
(gp-unifier gp-raw-unifier gp-m-unifier gp? gp-pair?))
#:use-module (logic guile-log canonacalize)
#:use-module (logic guile-log dynamic-features)
#:use-module (logic guile-log)
......@@ -66,7 +66,7 @@ Also it is possible to solve inifinite recursion.
(define add-table-cc
(letrec
((F (lambda (s x_)
(let ((tag (canon-it x_ s)))
(let ((tag (canon-it-rec x_ s)))
(<lambda> (x)
(<=> x ,(un-canon-it tag))))))
(h
......@@ -102,15 +102,25 @@ Also it is possible to solve inifinite recursion.
(<define> (add-rec f tag x D F)
(<let> ((m (vhashq-ref (fluid-ref recs) f #f)))
(if m
(<let> ((x (vhasha-ref (fluid-ref m) tag #f)))
(if (not x)
(<and>
(<code> (fluid-set! m (vhash-consa tag
#t (fluid-ref m))))
(F))
<cc>))
(<recur> lp ((first #t))
(if first
(if (eq? (pk 'first (fluid-ref m)) vlist-null)
(D m
(<lambda> ()
(lp #f)))
(lp #f))
(<let> ((q (vhasha-ref (fluid-ref m) tag #f)))
(<pp> 'a-m)
(if (not q)
(<and>
(<pp> 'not-x)
(<code> (fluid-set! m (vhash-consa tag
#t (fluid-ref m))))
(F))
<cc>))))
(<let> ((m (<make-vhash>)))
(<pp> `(add-dynamics ,f))
(add-vhash-dynamics m)
(<code> (fluid-set! recs (vhash-consq f m (fluid-ref recs))))
(D m
......@@ -221,7 +231,7 @@ Also it is possible to solve inifinite recursion.
(<apply> f x)))))))))
(<define> (tabling f . x)
(<let*> ((tag (canon-it x S))
(<let*> ((tag (canon-it-rec x S))
(me (memo-ref0 f tag))
(first (table-ref0 f tag))
(p P)
......@@ -252,33 +262,42 @@ Also it is possible to solve inifinite recursion.
(with-state-guard-dynamic-object h
(<lambda> () (D h code)))))))
(define-syntax-rule (mk-rec-lam rec with get-tag)
(define-syntax-rule (get-tag s x) (map (lambda (x) (<lookup> x)) x))
(define-syntax-rule (mk-rec-lam rec with get-tag-1)
(define (rec f guard doit)
(<lambda> (lam . x)
(<let*> ((tag (get-tag S x)))
(<values> (tag) (guard tag))
(<let*> ((tag (get-tag-1 S x))
(x (get-tag S x)))
(<values> (tag) (guard tag S))
(cond
((eq? tag #f)
(<pp> 'false-tag)
<cc>)
(tag
(<pp> 'tag)
(<let> ((hit (rec-ref0 f tag)))
(if hit
(<and>
(<pp> 'hit)
(doit x)
(<apply> lam x))
(add-rec f tag x with
(<lambda> () (<apply> f lam x))))))
(else
(<pp> 'pos-tag)
(<apply> f lam x)))))))
(define-syntax-rule (mk-rec rec with get-tag)
(define-syntax-rule (mk-rec rec with get-tag-1)
(define (rec f guard doit)
(<lambda> x
(<let*> ((tag (get-tag S x)))
(<values> (tag) (guard tag))
(<let*> ((tag (get-tag-1 S x))
(x (get-tag S x)))
(<values> (tag) (guard tag S))
(cond
((eq? tag #t)
<cc>)
(tag
(<let> ((hit (rec-ref0 f tag)))
(if hit
......@@ -288,7 +307,6 @@ Also it is possible to solve inifinite recursion.
(else
(<apply> f x)))))))
(define-syntax-rule (get-tag s x) (map (lambda (x) (<lookup> x)) x))
(mk-rec rec (Q with-backtrack-dynamic-object) get-tag)
(mk-rec rec-once (Q with-backtrack-dynamic-object-once) get-tag)
......@@ -362,8 +380,9 @@ Also it is possible to solve inifinite recursion.
(mk <<define>> rec=* rec= (@@ (logic guile-log umatch) gp-unify-raw!-)
#t +r)
(<define> (unify-guard x)
(if (and-map (lambda (x) (or (gp? x) (pair? x) (vector? x) (struct? x)))
(<define> (unify-guard x s)
(if (and-map (lambda (x) (or (gp-pair? x s)
(pair? x) (vector? x) (struct? x)))
x)
(<cc> x)
(<cc> #f)))
......@@ -374,21 +393,26 @@ Also it is possible to solve inifinite recursion.
(<<define>> #:mode -r (rec-action* lam x)
(lam #(x)
(<and>
(<and>
(rec-action* lam x)))
(lam #(x ...)
(<and>
(rec-action lam x)))
(lam (a . b)
(lam (a . b)
(<and>
(<pp> 'cons)
(rec-action lam a)
(rec-action lam b)))
(lam x
(<let> ((x (<lookup> x)))
(<pp> 'element)
(cond
((variable? x)
(<pp> 'variable)
(rec-action lam (variable-ref x)))
((prolog-closure? x)
(<let> ((lx (prolog-closure-state x)))
(rec-action lam lx)))
......@@ -409,33 +433,35 @@ Also it is possible to solve inifinite recursion.
(define *gp->scm* (@@ (logic guile-log umatch) *gp->scm*))
(define *canon-it* (@@ (logic guile-log canonacalize) *canon-it*))
(define canon-it++ (@@ (logic guile-log canonacalize) canon-it++))
(define mpf (@@ (logic guile-log umatch) recurs-map))
(define (gp-cp-rec x s)
(define mpf (@@ (logic guile-log umatch) *gp-cp*))
(define mp (make-hash-table))
(fluid-set! mpf mp)
(<wrap-s> rec-action s
(<lambda> (x)
(<code> (hashq-set! mp x #t)))
(<lambda> (y)
(<code> (hashq-set! mp (<lookup> y) #t)))
x)
(gp-cp++ x s #f))
(define (gp->scm-rec x s)
(define mpf (@@ (logic guile-log umatch) *gp-cp*))
(define mp (make-hash-table))
(pk 'scm-anal)
(fluid-set! mpf mp)
(<wrap-s> rec-action s
(<lambda> (x)
(<code> (hashq-set! mp x #t)))
x)
(<lambda> (y)
(<pp> 'hit)
(<code> (hashq-set! mp (<lookup> y) #t)))
x)
(pk 'scm-it)
(gp-cp++ x s #t))
(define (canon-it-rec x s)
(define (analyze mp x s)
(<wrap-s> rec-action s
(<lambda> (x)
(<code> (hashq-set! mp x #t)))
(<lambda> (y)
(<code> (hashq-set! mp (pk 'analyze (<lookup> y)) #t)))
x))
(canon-it++ gp->scm-rec analyze x s))
(pk 'canon (canon-it++ gp->scm-rec analyze x s)))
......
......@@ -2562,7 +2562,7 @@ SCM_DEFINE(gp_cons_bang, "gp-cons!", 3, 0, 0, (SCM car, SCM cdr, SCM s),
DS(smob2scm(car, s));
DS(smob2scm(cdr, s));
SCM EOL = SCM_EOL;
if(GP(car))
if(GP(car) || SCM_VARIABLEP(car))
{
SCM *idd = GP_GETREF(car);
gp_lookup_l(id, idd, &EOL);
......@@ -2574,7 +2574,7 @@ SCM_DEFINE(gp_cons_bang, "gp-cons!", 3, 0, 0, (SCM car, SCM cdr, SCM s),
gp_set_val(GP_CAR(cons),car, EOL, gp);
}
if(GP(cdr))
if(GP(cdr) || SCM_VARIABLEP(cdr))
{
SCM *idd = GP_GETREF(cdr);
gp_lookup_l(id, idd, &EOL);
......@@ -2614,7 +2614,7 @@ SCM_DEFINE(gp_pair_bang, "gp-pair!?", 2, 0, 0, (SCM x, SCM s),
UNPACK_ALL(ci, l,ggp,gp,s,"failed to unpack s in gp_pair_bang");
gp_debus0("gp-pair!?>\n");
retry:
if(GP(x))
if(GP(x) || SCM_VARIABLEP(x))
x = gp_gp_lookup(x,s);
if(GP(x))
{
......@@ -2678,7 +2678,7 @@ SCM_DEFINE(gp_pair, "gp-pair?", 2, 0, 0, (SCM x, SCM s),
gp_debus0("gp-pair?>\n");
retry:
if(GP(x))
if(GP(x) || SCM_VARIABLEP(x))
x = gp_gp_lookup(x,s);
if(GP(x))
......@@ -2770,7 +2770,7 @@ SCM_DEFINE(gp_null_bang, "gp-null!?", 2, 0, 0, (SCM x, SCM s),
gp_debus0("gp-null!?>\n");
retry:
if(GP(x))
if(GP(x) || SCM_VARIABLEP(x))
x = gp_gp_lookup(x,s);
if(GP(x))
......@@ -2820,7 +2820,7 @@ SCM_DEFINE(gp_gp_lookup, "gp-lookup", 2, 0, 0, (SCM x, SCM s),
SCM * id,l;
UNPACK_S0(l,s,"failed to unpack s in gp_gp_lookup");
if(GP(x))
if(GP(x) || SCM_VARIABLEP(x))
{
//printf("lookup> gp\n");
gp_debug0("gp-lookup\n");
......@@ -2982,7 +2982,7 @@ SCM_DEFINE(gp_car, "gp-car", 2, 0, 0, (SCM x, SCM s),
#define FUNC_NAME s_gp_car
{
gp_debus0("gp-car?>\n");
if(GP(x))
if(GP(x) || SCM_VARIABLEP(x))
x = gp_gp_lookup(x,s);
if(GP(x))
......@@ -3014,7 +3014,7 @@ SCM_DEFINE(gp_gp_cdr, "gp-cdr", 2, 0, 0, (SCM x, SCM s),
{
gp_debus0("gp-cdr>\n");
if(GP(x))
if(GP(x) || SCM_VARIABLEP(x))
x = gp_gp_lookup(x,s);
if(GP(x))
......
......@@ -570,12 +570,9 @@
d
(let ((data (make-variable #f)))
(hashq-set! first-map x data)
(set! datas (cons (cons data (lp2 #f)) datas))))))
((variable? x)
(variable-ref x))
(set! datas (cons (cons data (lp2 #f)) datas))
data))))
((gp-attvar-raw? x s)
(if (memq x vs)
x
......@@ -621,11 +618,12 @@
(if (pair? datas)
(let lp ((l datas) (s s))
(if (pair? datas)
(if (pair? l)
(begin
(variable-set! (car l) (cdr l))
(variable-set! (caar l) (cdar l))
(lp (cdr l) s))
res)))))))
res))
res)))))
(define (get-free-variables-map x s)
(define tr (make-hash-table))
......
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