refining the tabling, various bugfixes and interpreter improvements

parent 9974375a
......@@ -75,6 +75,7 @@ SOURCES = \
logic/guile-log/guile-prolog/zip.scm \
logic/guile-log/guile-prolog/readline.scm \
logic/guile-log/guile-prolog/fluid.scm \
logic/guile-log/guile-prolog/memoize.scm \
logic/guile-log/guile-prolog/interpreter.scm \
logic/guile-log/guile-prolog/state.scm \
logic/guile-log/guile-prolog/postpone.scm \
......
......@@ -18,6 +18,8 @@
#:use-module (logic guile-log prolog closed)
#:use-module (logic guile-log dynamic-features)
#:use-module (logic guile-log guile-prolog dynamic-features)
#:use-module (logic guile-log guile-prolog memoize)
#:use-module (logic guile-log guile-prolog postpone)
#:export (prolog-shell conversation leave read-prolog user_ref user_set
stall thin_stall))
......@@ -25,8 +27,11 @@
(define -all- (make-fluid false))
(<wrap> add-fluid-dynamics -all-)
(define -nsol- (make-fluid false))
(define -nsol- (make-fluid #f))
(define -mute?- (make-fluid #f))
(define -rec?- (make-fluid #f))
(define -nonrec?- (make-fluid #f))
(<wrap> add-fluid-dynamics -mute?-)
(define *user-data* (make-fluid vlist-null))
(<wrap> add-vhash-dynamics *user-data*)
(<define> (user_set a v)
......@@ -77,7 +82,8 @@
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
......@@ -140,14 +146,21 @@
action)
(else
(case action
((mute m) (set! mute? #t))
((all *) (set! all? #t))
((once) (set! nn? 1))
((h help) (set! help? #t))
((s save) (set! save ((@ (guile) read))))
((l load) (set! load ((@ (guile) read))))
((c cont) (set! cont #t))
((ref) (set! ref ((@ (guile) read))))
((rec) (begin
(fluid-set! -rec?- #t)
(fluid-set! -nonrec?- #f)))
((nonrec) (begin
(fluid-set! -rec?- #f)
(fluid-set! -nonrec?- #t)))
((mute m) (fluid-set! -mute?- #t))
((unmute um) (fluid-set! -mute?- #f))
((all *) (set! all? #t))
((once) (set! nn? 1))
((h help) (set! help? #t))
((s save) (set! save ((@ (guile) read))))
((l load) (set! load ((@ (guile) read))))
((c cont) (set! cont #t))
((ref) (set! ref ((@ (guile) read))))
((set) (set! set (list ((@ (guile) read))
((@ (guile) read)))))
((clear) (set! clear #t) (set! endl #\.))
......@@ -234,19 +247,20 @@
(format #t "
HELP FOR PROLOG COMMANDS
---------------------------------------------------------------------
(.n ) try to find n solutions
(.all | .* ) try to find all solutions
(.once | .1 ) try to find one solution
(.mute | .m ) no value output is written.
(.n ) try to find n solutions
(.all | .* ) try to find all solutions
(.once | .1 ) try to find one solution
(.mute | .m ) no value output is written.
(.unmute | .um) output values is written.
---------------------------------------------------------------------
(.save | .s ) <ref> associate current state with name ref
(.load | .l ) <ref> restore associate state with name ref
(.cont | .c ) continue the execution from last stall point
(.lold | .lo) restore the last state at a stall
(.clear ) clear the prolog stack and state
(.save | .s ) <ref> associate current state with name ref
(.load | .l ) <ref> restore associate state with name ref
(.cont | .c ) continue the execution from last stall point
(.lold | .lo) restore the last state at a stall
(.clear ) clear the prolog stack and state
---------------------------------------------------------------------
(.ref ) <ref> get value of reference user variable ref
(.set ) <ref> <val> set user variable ref to value val
(.ref ) <ref> get value of reference user variable ref
(.set ) <ref> <val> set user variable ref to value val
---------------------------------------------------------------------
")
'(if #f #f))
......@@ -273,10 +287,7 @@ HELP FOR PROLOG COMMANDS
(all? '(@ (logic guile-log iso-prolog) true))
(nn? nn?)
(else
'(@ (logic guile-log iso-prolog) false)))
,(if mute?
'(@ (logic guile-log iso-prolog) true)
'(@ (logic guile-log iso-prolog) false)))
'(@ (logic guile-log iso-prolog) false))))
((@ (logic guile-log) <code>)
((@ (logic guile-log umatch) gp-unwind) fr)))
(if #f #f))))
......@@ -340,21 +351,34 @@ conversation_ :-
consult(T,V,N,false,false)
) ; conversation_.
conversation1(X,All,Mute) :-
fluid_guard_dynamic_object(scm[-n-], scm[-nsol-], scm[-all-]),
state_guard_dynamic_object(scm[-n-], scm[-nsol-], scm[-all-],
conversation1(X,All) :-
fluid_guard_dynamic_object(scm[-n-], scm[-nsol-], scm[-all-], scm[-mute?-]),
state_guard_dynamic_object(scm[-n-], scm[-nsol-], scm[-all-], scm[-mute?-],
scm[*user-data*]),
wrap_frame,
conversation2(X,All,Mute).
conversation2(X,All).
conversation2(X,All,Mute) :-
do[(fluid-set! -n- (+ (fluid-ref -n-) 1))],
readline_term_str(X,T,[variables(V),variable_names(N)]),
consult(T,V,N,All,Mute).
tree :- when[(pk (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);
true.
consult(X,V,N,All,Mute) :-
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) :-
do[(fluid-set! -nsol- (<lookup> All))],
catch(((solve(X),output_and_more(Mute,V,N)) ; (nl,write(no),nl,fail)),
catch(((solve(X),output_and_more(V,N)) ; (nl,write(no),nl,fail)),
finish,
fail).
......@@ -384,8 +408,8 @@ hash_new(X,Y,H,I) :-
fluid_set(I,scm[(+ 1 (fluid-ref (<lookup> I)))]),
vhashq_cons(H,X,Y).
output_and_more(Mute,V,N) :-
Mute == true -> more ;
output_and_more(V,N) :-
when[(eq? (fluid-ref -mute?-) #t)] -> more ;
(
(V==[] -> write(\"yes\") ; (once(vtosym(V,VV)),write_out(VV,N),nl)), more
).
......@@ -396,7 +420,7 @@ write_out([V|Vs],[N|Ns])
write_out(Vs,Ns).
wstall :- stall.
wstall :- stall,tree.
more :-
scm[(fluid-ref -all-)] == true -> fail ;
......
(define-module (logic guile-log guile-prolog memoize)
#:use-module (logic guile-log memoize)
#:use-module (logic guile-log)
#:use-module (logic guile-log prolog goal-functors)
#:export (with_rational_trees with_non_ratioanl_tree rational_trees
non_rational_trees))
(<define> (with_rational_trees code)
(with-rec-unifyer (<lambda> () (goal-eval code))))
(<define> (with_non_rational_trees code)
(with-nonrec-unifyer (<lambda> () (goal-eval code))))
(<define> (rational_trees) (rec-unifyer))
(<define> (non_rational_trees) (nonrec-unifyer))
......@@ -12,9 +12,10 @@
#:use-module (logic guile-log guile-prolog closure)
#:export (memo rec tabling memo-rec memo-ref rec-ref table-ref
rec-once memos recs rec= rec== rec-action
with-rec-unifyer rec-0 rec-once-0 rec-lam
with-rec-unifyer rec-unifyer rec-0 rec-once-0 rec-lam
rec-lam-once rec-lam-0 rec-lam-once-0
gp-cp-rec gp->scm-rec canon-it-rec))
gp-cp-rec gp->scm-rec canon-it-rec
with-nonrec-unifyer nonrec-unifyer))
#|
Memoizing can speed up function evaluation by memoizing the input and output.
......@@ -247,16 +248,12 @@ Also it is possible to solve inifinite recursion.
(cc CC))
(cond
(me
(if (not first)
(postpone-frame 0 0 10000)
<cc>)
(do-tabling f tag x))
(first
(do-tabling f tag x first))
(else
(postpone-frame 0 0 10000)
(<let> ((p P))
(init-table f tag x (Q with-backtrack-dynamic-object)
(<lambda> ()
......@@ -440,14 +437,18 @@ Also it is possible to solve inifinite recursion.
(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 mp (make-hash-table))
(fluid-set! mpf mp)
(<wrap-s> rec-action s
(<lambda> (y)
(<code> (hashq-set! mp (<lookup> y) #t)))
x)
(gp-cp++ x s #f))
(define gp-cp-rec
(case-lambda
((x s)
(gp-cp-rec x '() s))
((x l s)
(define mp (make-hash-table))
(fluid-set! mpf mp)
(<wrap-s> rec-action s
(<lambda> (y)
(<code> (hashq-set! mp (<lookup> y) #t)))
x)
(gp-cp++ #f x l s))))
(define (gp->scm-rec x s)
(define mp (make-hash-table))
......@@ -456,7 +457,7 @@ Also it is possible to solve inifinite recursion.
(<lambda> (y)
(<code> (hashq-set! mp (<lookup> y) #t)))
x)
(gp-cp++ x s #t))
(gp-cp++ #t x s))
(define (canon-it-rec x s)
(define (analyze mp x s)
......@@ -484,6 +485,14 @@ Also it is possible to solve inifinite recursion.
(with-fluid-guard-dynamic-object x (<lambda> ()
(<apply> with code l))))))
((code) (code))))
(define on-status
(<case-lambda>
((code x . l)
(state-guard-dynamic-object x)
(fluid-guard-dynamic-object x)
(<apply> on-status code l))
((code) (code))))
(<define> (with-rec-unifyer code)
(with (<lambda> ()
......@@ -497,3 +506,53 @@ Also it is possible to solve inifinite recursion.
gp-unifier gp-raw-unifier gp-m-unifier
*canon-it* *gp->scm* *gp-cp*))
(<define> (rec-unifyer)
(on-status
(<lambda> ()
(<code> (fluid-set! gp-unifier gp-rec=)
(fluid-set! gp-m-unifier gp-rec==)
(fluid-set! gp-raw-unifier gp-rec=)
(fluid-set! *canon-it* canon-it-rec)
(fluid-set! *gp-cp* gp-cp-rec)
(fluid-set! *gp->scm* gp->scm-rec)))
gp-unifier gp-raw-unifier gp-m-unifier
*canon-it* *gp->scm* *gp-cp*))
(<define> (with-nonrec-unifyer code)
(with (<lambda> ()
(<code> (fluid-set! gp-unifier (@@ (logic guile-log code-load)
gp-unify!-))
(fluid-set! gp-m-unifier (@@ (logic guile-log code-load)
gp-m-unify!-))
(fluid-set! gp-raw-unifier (@@ (logic guile-log code-load)
gp-unify-raw!-))
(fluid-set! *canon-it* (@@ (logic guile-log canonacalize)
canon-it+))
(fluid-set! *gp-cp* (@@ (logic guile-log umatch)
gp-cp+))
(fluid-set! *gp->scm* (@@ (logic guile-log code-load)
gp->scm-))
(code)))
gp-unifier gp-raw-unifier gp-m-unifier
*canon-it* *gp->scm* *gp-cp*))
(<define> (nonrec-unifyer)
(on-status
(<lambda> ()
(<code> (fluid-set! gp-unifier (@@ (logic guile-log code-load)
gp-unify!-))
(fluid-set! gp-m-unifier (@@ (logic guile-log code-load)
gp-m-unify!-))
(fluid-set! gp-raw-unifier (@@ (logic guile-log code-load)
gp-unify-raw!-))
(fluid-set! *canon-it* (@@ (logic guile-log canonacalize)
canon-it+))
(fluid-set! *gp-cp* (@@ (logic guile-log umatch)
gp-cp+))
(fluid-set! *gp->scm* (@@ (logic guile-log code-load)
gp->scm-))))
gp-unifier gp-raw-unifier gp-m-unifier
*canon-it* *gp->scm* *gp-cp*))
This diff is collapsed.
......@@ -479,9 +479,10 @@ static void gp_unwind0(SCM *ci, SCM *si, SCM *cs, struct gp_stack *gp)
if(i != ci - 1)
{
ci = i + 1;
/*
scm_misc_error("gp_unwind0", "The stack has been splitted, unwind ci index point inside a stored stack frame ~a ~a ~a\n",
scm_list_3(ci[-1],ci[0],scm_from_int((scm_t_bits) (ci - 1 - i))));
scm_list_3(ci[-1],ci[0],scm_from_int((scm_t_bits) (ci - 1 - i))));*/
}
//We delay this because we can have reentrance and we should be able
......
......@@ -114,6 +114,7 @@
;;fast call 1 args
(gp-module-init)
(define newf (@@ (logic guile-log code-load) gp-newframe))
(define unw (@@ (logic guile-log code-load) gp-unwind))
......@@ -503,15 +504,15 @@
(define (gp->scm . x) (apply (fluid-ref *gp->scm*) x))
(define recurs-map (make-fluid #f))
(define (gp-cp+ x s) (gp-cp++ x s #f))
(define *gp-cp* (make-fluid gp-cp))
(define (gp-scm+ x s) (gp-cp++ x s #t))
(define (gp-cp+ . l) (apply gp-cp++ #f l))
(define *gp-cp* (make-fluid gp-cp+))
(define (gp-scm+ x s) (gp-cp++ #t x s))
(define gp-cp++
(case-lambda
((x s scm?)
(gp-cp++ x '() s scm?))
((x l s scm?)
(define vs (gp->scm l s))
((scm? x s )
(gp-cp++ scm? x '() s))
((scm? x l s)
(define vs (gp->scm- l s))
(define tr (make-hash-table))
(define datas '())
(define first-map (make-hash-table))
......@@ -558,7 +559,6 @@
(else
#f)))))
(let ((res
(let lp ((x x))
(let ((x (gp-lookup x s)))
......
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