much better print support of attributed variables plus acceptable copy_term/3

parent 0a62c3eb
......@@ -73,6 +73,7 @@ PSSOURCES = \
logic/guile-log/prolog/goal-transformers.scm \
logic/guile-log/prolog/base.scm \
logic/guile-log/guile-prolog/attribute.scm \
logic/guile-log/guile-prolog/copy-term.scm \
logic/guile-log/prolog/io.scm \
logic/guile-log/prolog/char-conversion.scm \
logic/guile-log/prolog/load.scm \
......
......@@ -4967,7 +4967,6 @@ difference_arcs(Vars, FreeLeft, FreeRight) :-
empty_assoc(E),
phrase(difference_arcs0(Vars, FreeLeft), [E], [NumVar]),
assoc_to_list(NumVar, LsNumVar),
write(lsNumVar(LsNumVar)),nl,
pairs_values(LsNumVar, FreeRight).
domain_to_list(Domain, List) :- phrase(domain_to_list0(Domain), List).
......@@ -5013,11 +5012,17 @@ clear_parent(V) :- del_attr(V, parent).
maximum_matching([]).
maximum_matching([FL|FLs]) :-
write(1),
augmenting_path_to([[FL]], Levels, To),
write(2),
phrase(augmenting_path(FL, To), Path),
write(3),
maplist(maplist(clear_parent), Levels),
write(4),
del_attr(To, free),
write(5),
adjust_alternate_1(Path),
write(6),
maximum_matching(FLs).
reachables([]) --> [].
......@@ -5028,7 +5033,6 @@ reachables([V|Vs]) -->
reachables_([], _) --> [].
reachables_([E|Es], V) -->
{ write(r(E,Es)),nl },
edge_reachable(E, V),
reachables_(Es, V).
......@@ -5118,25 +5122,15 @@ distinct(Vars) :-
length(FreeLeft, LFL),
length(FreeRight0, LFR),
LFL =< LFR,
write(a),
maplist(put_free, FreeRight0),
write(b),
maximum_matching(FreeLeft),
write(c),
include(free_node, FreeRight0, FreeRight),
write(d),
maplist(g_g0, FreeLeft),
write(e),
scc(FreeLeft, g0_successors),
write(f),
maplist(dfs_used, FreeRight),
write(g),
phrase(distinct_goals(FreeLeft), Gs)), Gs),
write(h),
disable_queue,
write(i),
maplist(call, Gs),
write(j),
enable_queue.
distinct_goals([]) --> [].
......
......@@ -19,14 +19,23 @@
(<let> ((x (<lookup> x)))
(if (gp-attvar-raw? x S)
(<recur> lp ((res res)
(l (map (lambda (x) (attribute-cstor-repr (car x)))
(l (map (lambda (x)
(let ((res
(attribute-cstor-repr (car x))))
(if res
res
x)))
(gp-att-data x S))))
(if (pair? l)
(if (car l)
(<let> ((xx (car l)))
(if (pair? xx)
(<var> (t)
(<=> (,(vector (list put_attr x (car xx) (cdr xx))) . t)
res)
(lp t (cdr l)))
(<var> (t)
((car l) res t x)
(lp t (cdr l)))
(lp res (cdr l)))
(lp t (cdr l)))))
(<=> res tail))))))
(define *touched-attributes* (make-fluid vlist-null))
......
(define-module (logic guile-log guile-prolog copy-term)
#:use-module ((logic guile-log umatch)
#:select (gp-var? gp-attvar-raw? gp-make-var
gp-att-data))
#:use-module (logic guile-log guile-prolog attribute)
#:use-module (logic guile-log)
#:replace (copy_term)
#:export (duplicate_term
copy-term-2 copy-term-3
duplicate-term-2 duplicate-term-3))
(define fail (lambda (x) x))
(define-guile-log check
(syntax-rules ()
((check w (h x r m ...) code ...)
(let ((r (hashq-ref h x fail)))
(if (eq? r fail)
(let ((r (make-variable #f)))
(hashq-set! h x r)
(<with-guile-log> w (<and> code ...)))
(<with-guile-log> w (<cc> r m ...)))))))
(define-syntax-rule (mk-copy-term-2 copy-term-2 reuse?)
(<define> (copy-term-2 x)
(<let> ((h (make-hash-table)))
(<recur> lp ((x x))
(<let*> ((x (<lookup> x)))
(cond
((gp-attvar-raw? x S)
(check (h x r)
(<values> (data) (lp (gp-att-data x S)))
(<let> ((y (gp-make-att-from-data data)))
(<code> (variable-set! r y))
(<cc> y))))
((gp-var? x S)
(check (h x r)
(<let> ((y (gp-make-var)))
(<code> (variable-set! r y))
(<cc> y))))
(else
(<<match>> (#:mode - #:name copy-term-2) (x)
((a . b)
(check (h x r)
(<values> (aa) (lp a))
(<values> (bb) (lp b))
(if (and reuse? (eqv? a aa) (eqv? b bb))
(<and>
(<code> (variable-set! r x))
(<cc> x))
(<let> ((ret (cons aa bb)))
(<code> (variable-set! r ret))
(<cc> ret)))))
(#(a)
(check (h x r)
(<values> (aa) (lp a))
(if (and reuse? (eqv? a aa))
(<and>
(<code> (variable-set! r x))
(<cc> x))
(<let> ((ret (vector aa)))
(<code> (variable-set! r ret))
(<cc> ret)))))
(#(a b)
(check (h x r)
(<values> (aa) (lp a))
(<values> (bb) (lp b))
(if (and reuse? (eqv? a aa) (eqv? b bb))
(<and>
(<code> (variable-set! r x))
(<cc> x))
(<let> ((ret (vector aa bb)))
(<code> (variable-set! r ret))
(<cc> ret)))))
(x (<cc> x))))))))))
(mk-copy-term-2 copy-term-2 #t)
(mk-copy-term-2 duplicate-term-2 #f)
(define-syntax-rule (mk-copy-term-3 copy-term-3 reuse?)
(<define> (copy-term-3 x)
(<let> ((h (make-hash-table)))
(<recur> lp ((x x))
(<let*> ((x (<lookup> x)))
(cond
((gp-attvar-raw? x S)
(check (h x r '())
(<var> (repr)
(build_attribut_representation repr '() x)
(<values> (repr2 newrepr) (lp repr))
(<let> ((ret (gp-make-var)))
(<code> (variable-set! r ret))
(<cc> ret (append repr2 newrepr))))))
((gp-var? x S)
(check (h x r '())
(<let> ((y (gp-make-var)))
(<code> (variable-set! r y))
(<cc> y '()))))
(else
(<<match>> (#:mode - #:name copy-term-2) (x)
((a . b)
(check (h x r '())
(<values> (aa la) (lp a))
(<values> (bb lb) (lp b))
(if (and reuse? (eqv? a aa) (eqv? b bb))
(<and>
(<code> (variable-set! r x))
(<cc> x '()))
(<let> ((ret (cons aa bb)))
(<code> (variable-set! r ret))
(<cc> ret (append la lb))))))
(#(a)
(check (h x r '())
(<values> (aa la) (lp a))
(if (and reuse? (eqv? a aa))
(<and>
(<code> (variable-set! r x))
(<cc> x '()))
(<let> ((ret (vector aa)))
(<code> (variable-set! r ret))
(<cc> ret la)))))
(#(a b)
(check (h x r '())
(<values> (aa la) (lp a))
(<values> (bb lb) (lp b))
(if (and reuse? (eqv? a aa) (eqv? b bb))
(<and>
(<code> (variable-set! r x))
(<cc> x '()))
(<let> ((ret (vector aa bb)))
(<code> (variable-set! r ret))
(<cc> ret (append la lb))))))
(x (<cc> x '()))))))))))
(mk-copy-term-3 copy-term-3 #t)
(mk-copy-term-3 duplicate-term-3 #f)
(define copy_term
(<case-lambda>
((x y) (<values> (yy) (copy-term-2 x)) (<=> y yy))
((x y z) (<values> (yy zz) (copy-term-3 x)) (<=> y yy) (<=> z zz))))
(define duplicate_term
(<case-lambda>
((x y) (<values> (yy) (duplicate-term-2 x)) (<=> y yy))
((x y z) (<values> (yy zz) (duplicate-term-3 x)) (<=> y yy) (<=> z zz))))
......@@ -28,6 +28,7 @@
#:use-module (logic guile-log guile-prolog memoize)
#:use-module (logic guile-log prolog global)
#:use-module (logic guile-log guile-prolog postpone)
#:use-module (logic guile-log guile-prolog copy-term)
#:export (prolog-shell conversation leave read-prolog user_ref user_set
stall thin_stall))
......@@ -406,15 +407,19 @@ consult(X,V,N,All) :-
catch((solve(V,N,X) ; (nl,write(no),nl,fail)),finish,
fail).
vtosym(X,Y) :- make_vhash(H),make_fluid(0,I),rec_analyze(X),vtosym4(X,Y,H,I).
add_N(H,[],[]).
add_N(H,[V|Vs],[N|Ns]) :-
(var(V) -> vhashq_cons(H,V,N) ; true),
add_N(H,Vs,Ns).
vtosym(X,Y,N,L,LL) :-
make_vhash(H),add_N(H,X,N),
make_fluid(0,I),
rec_analyze(X),vtosym4(X,Y,H,I),
rec_analyze(L),vtosym4(L,LL,H,I).
%vtosym_(X,Y,_,_) :- write([1,X,Y]),nl,fail.
vtosym_(X,Y,H,I) :-
attvar(X) -> (!,
(vhashq_ref(H,X,Y) -> true ;
( hash_new(X,Z,H,I),
build_attribut_representation(XX,[],X),
(XX=[] -> Z=Y ; vtosym_(XX,Y,H,I)))));
var(X) -> (!, (vhashq_ref(H,X,Y)->true ; hash_new(X,Y,H,I)));
namespace_p(X) -> (!, namespace_val(X,XX),
vtosym4(XX,YY,H,I),
......@@ -442,18 +447,33 @@ hash_new(X,Y,H,I) :-
output_and_more(V,N,More) :-
(when[(eq? (fluid-ref -mute?-) #t)] -> more ;
(
(V==[] -> (write(\"yes\"),nl) ; (once(vtosym(V,VV)),
setenv,write_out(VV,N),nl)),
(V==[] -> (write(\"yes\"),nl) ; (once((copy_term(V,U,L),
vtosym(U,VV,N,L,LL))),
setenv,write_out(VV,N,LL),nl)),
(More=#t -> more ; throw(finish))
)
).
%write_out(X,Y) :- write(writeout(X,Y)),nl,fail.
write_out([],[]).
write_out([V|Vs],[N|Ns])
:- nl,write(\" \"),write(N),write(\" = \"),write(V),
write_out(Vs,Ns).
write_out(VV,N,L) :- write_out0(VV,N,Empty), write_out_trail(L,Empty).
write_out0([],[],_).
write_out0([V|Vs],[N|Ns],Empty) :-
V == N -> write_out0(Vs,Ns,Empty) ;
Empty=1,nl,write(\" \"),write(N),write(\" = \"),write(V),
write_out2(Vs,Ns,Empty).
write_out2([],[],_).
write_out2([V|Vs],[N|Ns],Empty) :-
V == N -> write_out2(Vs,Ns,Empty) ;
Empty=1,write(','),nl,write(\" \"),write(N),write(\" = \"),write(V),
write_out2(Vs,Ns,Empty).
write_out_trail([A|B], Empty) :-
(Empty==1 -> write(',') ; true), nl,
write(\" \"),write(A), write_out_trail(B,1).
write_out_trail([],_) :-
Empty==1 -> write('.') ; true.
wstall :- stall,tree.
......
(define-module (logic guile-log prolog error)
#:use-module ((logic guile-log)
#:select (</.> <abort> <define> <match> <cut> <let>
#:select (</.> <abort> <define> <match> <cut> <let> <cp>
<pp> <lookup> <var?> <cc> <fail> <lambda> <fail>))
#:use-module (ice-9 match)
#:use-module (logic guile-log prompts)
......@@ -41,8 +41,8 @@
(<define> (abort1 code)
(user-exception-hook code
(<lambda> ()
(if (<lookup> code) (<pp> `(abort ,code)) <cc>)
(<abort> 'prolog non-reentrant code))))
(if (<lookup> code) #;(<pp> `(abort ,code)) <cc>)
(<abort> 'prolog non-reentrant (<cp> code)))))
(define-syntax-rule (define-error (nm a ...) code)
(define (nm s p cc a ...)
......
......@@ -23,6 +23,7 @@
#:use-module (logic guile-log prolog pre)
#:use-module (logic guile-log prolog operators)
#:use-module (logic guile-log prolog namespace)
#:use-module (logic guile-log guile-prolog copy-term)
#:use-module (rnrs io ports)
#:use-module (logic guile-log fstream)
#:replace (write open close read)
......@@ -1014,8 +1015,16 @@
(()
(<and>
(<cut>
(<code> (fformat s "~a" (scm->pl S t ns q i n))))))
<cut>
(<values> (t ts) (copy-term-3 t))
(<code> (fformat s "~a" (scm->pl S t ns q i n)))
(<recur> lp ((ts ts))
(if (pair? ts)
(<and>
<cut>
(<code> (fformat s ",~%~a" (scm->pl S (car ts) ns q i n)))
(lp (cdr ts)))
<cc>))))
(_
(instantiation_error)))))))))
((t opts)
......
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