new implementation of when coroutine compiles

parent 72f06359
(define-module (logic guile-log guile-prolog coroutine)
#:use-module (logic guile-log)
#:use-module (logic guile-log iso-prolog)
#:use-module (logic guile-log guile-prolog attribute)
#:use-module (logic guile-log guile-prolog hash)
#:use-module (logic guile-log guile-prolog gc-call)
#:use-module (logic guile-log umatch)
#:export (freeze frozen when dif))
......@@ -43,7 +46,10 @@ frozen(Var,Goal) :-
get_attr(Var, freezeId, Atts) ->
combine_atts(Atts,Goal);
Goal = true.
")
(compile-prolog-string
"
%when(Condition, Goal)
do_all_atts_when(Val,[Id, u(J,G) | L]) :-
......@@ -52,91 +58,100 @@ do_all_atts_when(Val,[Id, u(J,G) | L]) :-
do_all_atts_when([]).
doVs(X,[]).
doVs(X,[X|Vs]) :- doVs(X,Vs).
doNs(X,[]).
doNs(X,[N|Ns]) :- (nonvar(X) -> N=true) , doNs(X,Ns).
doGs(X,[]).
doGs(X,[G|Gs]) :- (atomic(X) -> G=true) , doGs(X,Gs).
doVs(X,Vs) :- var(Vs) -> true ; [X]=Vs.
doNs(X,Ns) :- var(Ns) -> true ; ([N]=Ns,nonvar(X) -> N=true).
doGs(X,Gs) :- var(Gs) -> true ; ([G]=Gs,atomic(X) -> G=true).
whenId(Val,Var,#t) :-
raw_attvar(Var, Raw),
(
Raw = Val,
get_attr(Var,whenId,[G,M,Vs,Ns,Gs]),!,
get_attr(Var,whenId,[G,M,[K,Once],Vs,Ns,Gs]),!,
doVs(Raw,Vs),doNs(Raw,Ns),doGs(Raw,Gs),
\\+M -> true , call(G)
var(Once) ->
( (\\+call(M)) -> true ;
(
(K=false -> Once=true;true),
call(G)
)
); true
);
Raw=Val.
difId(Val, Var, #t) :-
var(Val);attvar(Val);
(
get_attr(Var,whenId, Atts),
del_attr(Var, whenId),
Var = Val,
do_all_atts_when(Atts)
).
")
process_cond(M,(X,Y),L,LL) :- !,
process_cond(Mx,X,L,LL1),
process_cond(My,Y,LL1,LL),
(compile-prolog-string
"
process_cond(M,(X,Y),L) :- !,
process_cond(Mx,X,L),
process_cond(My,Y,L),
M=(Mx,My).
process_cond(M,(X;Y),L,LL) :- !,
process_cond(Mx,X,L,LL1),
process_cond(My,Y,LL1,LL),
process_cond(M,(X;Y),L) :- !,
process_cond(Mx,X,L),
process_cond(My,Y,L),
M=(Mx;My).
process_cond(M,X=Y,L,LL)
process_cond2(Mx,X,L,LL1),
process_cond2(My,Y,LL1,LL),
process_cond(M,X=Y,L) :- !,
process_cond2(Mx,X,L),
process_cond2(My,Y,L),
M=(Mx=My).
process_cond(M,nonvar(X),L,LL) :-
add_nonvar(M,X,L,LL).
process_cond(M,nonvar(X),L) :- !,
add_nonvar(M,X,L).
process_cond(M,ground(X),L,LL) :-
add_ground(M,X,L,LL).
process_cond(M,ground(X),L) :- !,
add_ground(M,X,L).
process_cond(M,[X|Y],L,LL)
process_cond2(Mx,X,L,LL1),
process_cond2(My,Y,LL1,LL),
process_cond(M,[X|Y],L) :- !,
process_cond2(Mx,X,L),
process_cond2(My,Y,L),
M=[Mx|My].
process_cond2(M,X,L,LL) :-
var(X) -> add_var(M,X,L,LL) ;
X~=[F|U] -> (process_cond2(MM,U,L,LL),M~=[F|MM]) ;
process_cond2(M,X,L) :-
var(X) -> add_var(M,X,L) ;
attvar(X) -> add_var(M,X,L) ;
X=..[F|U] -> (process_cond2(MM,U,L),M=..[F|MM]) ;
(M=X,L=LL).
add_var(MG,G,M,X,L,LL) :-
hash_ref(L,X,[Vs|U],LL) -> hash_set_x(X,[[M|Vs]|U,LL) ;
hash_set_x(X,[[M],[],[]],LL).
add_nonvar(MG,G,nonvar(M),X,L,LL) :-
hash_ref(L,X,[Vs,Ns,Gs],LL) -> hash_set_x(X,[Vs,[M|Ns],Vs],LL) ;
hash_set_x(X,[[],[M],[]],LL).
add_var(M,X,L) :-
vhashq_ref(L,X,[Vs, Ns, Gs]) -> Vs=[M] ;
vhashq_cons(L,X,[[M], Ns, Gs]).
add_ground(MG,G,nonvar(M),X,L,LL) :-
hash_ref(L,X,[Vs,Ns,Gs],LL) -> hash_set_x(X,[Vs,Ns,[M|Gs]],LL) ;
hash_set_x(X,[[],[],[M]],LL).
add_nonvar(nonvar(M),X,L) :-
vhashq_ref(L,X,[Vs, Ns, Gs]) -> Ns=[M] ;
vhashq_cons(L,X,[Vs, [M], Gs]).
construct_when(MG,G,[]).
construct_when(MG,G,[[X|Data] | L]) :-
add_ground(nonvar(M),X,L) :-
vhashq_ref(L,X,[Vs, Ns, Gs]) -> Gs=[M] ;
vhashq_cons(L,X,[Vs, Ns, [M]]).
")
(compile-prolog-string
"
construct_when(O,MG,G,[]).
construct_when(O,MG,G,[[X|Data] | L]) :-
(
get_attr(X,whenId,L) ->
put_attr(X,whenId,[[MG,G | Data] | L]) ;
put_attr(X,whenId,[[MG,G | Data]]).
), construct_when(MG,G,L).
put_attr(X,whenId,[[G,MG,O | Data] | L]) ;
put_attr(X,whenId,[[G,MG,O | Data]])
),
construct_when(MG,G,L).
when(Cond,Goal) :-
process_when(Cond,MG,Data),
construct_when(MG,G,Data).
diff(X, Y) :-
do_when(X=Y, X\\== Y, [X], Id, diffId).
construct_when([false,O],MG,Goal,Data).
when(Cond,Goal,O) :-
process_when(Cond,MG,Data),
construct_when([true,O],MG,Goal,Data).
")
;; This will construct the datastructure and rewind the stack
;; It is a quite efficient process using vhashes and stack rewind.
(<define> (process_when condition MG Data)
(<gc-call> (cons MG Data)
(<lambda> ()
(<var> (L)
(make_vhash L)
(process_cond MG condition, L)
(vhash_to_assoc L Data)))))
......@@ -11,7 +11,7 @@
#:use-module (logic guile-log prolog goal-transformers)
#:use-module (logic guile-log)
#:export (make_vhash vhash vhashp vhash_ref vhashq_ref vhash_cons vhashq_cons
peek_vhash))
peek_vhash vhash_to_assoc))
(mk-sym vhash)
......@@ -128,3 +128,13 @@ it's old datastructure.
hash (number->string v 16))
(lp (- i 1)))))))
(format #t "<assoc>~%")))
(<define> (vhash_to_assoc h l)
(<let> ((h (<lookup> h)))
(cond
((<var?> h)
(instantiation_error))
((not (<vhash?> h))
(type_error vhash h))
(else
(<=> l (vhash->assoc (fluid-ref h)))))))
......@@ -10,7 +10,7 @@
let-with-lr-guard)
#:export (<or-i> <or-union> <and-i>
<//> <update> <update-val> <zip> <call>
<set!>))
<set!> <gc-call>))
(define-guile-log <or-i>
(syntax-rules ()
......@@ -298,6 +298,12 @@ and-interleave
(parse<> w
(call (</.> code ...) (list x ...) (list l ...))))))
(<define> (<gc-call> X Lam)
(<let> ((pr P))
(Lam)
(<let> ((res (<cp> X)))
(<code> (<unwind> pr))
(<=> X res))))
(define-syntax-rule (fcall-m nm)
(define (nm s p cc lam x l f)
......
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