coroutines starts to work

parent 14df6d09
......@@ -59,6 +59,7 @@ SOURCES = \
logic/guile-log/prolog/order.scm \
logic/guile-log/prolog/goal-transformers.scm \
logic/guile-log/prolog/base.scm \
logic/guile-log/guile-prolog/attribute.scm \
logic/guile-log/prolog/io.scm \
logic/guile-log/prolog/char-conversion.scm \
logic/guile-log/prolog/load.scm \
......@@ -77,6 +78,7 @@ SOURCES = \
logic/guile-log/guile-prolog/interpreter.scm \
logic/guile-log/guile-prolog/state.scm \
logic/guile-log/guile-prolog/postpone.scm \
logic/guile-log/guile-prolog/coroutine.scm \
language/prolog/spec.scm
AM_MAKEINFOFLAGS=--force
......
......@@ -289,6 +289,6 @@
(gp-set-attribute-trampoline (lambda (lam val var x y s)
(lam s (lambda () #f) (lambda (s .l) s)
(lam s (lambda () #f) (lambda (s . l) s)
val var x y)))
(define-module (logic guile-log guile-prolog attribute)
#:use-module (logic guile-log)
#:use-module (logic guile-log prolog error)
#:use-module (#:select (logic guile-log prolog names)
(atom))
#:use-module (logic guile-log prolog names)
#:export (attvar put_attr get_attr del_attr construct_attr))
(<define> (attvar X) (<attvar?> X))
(<define> (put_attr Var Mod Val)
(<if> (<attvar?> Var)
(<if> (atom Mod)
(<put-attr> Var Mod Val)
(type_error Mod atom))
(representation_error Var)))
(<let> ((Mod (<lookup> Mod))
(Var (<lookup> Var)))
(<if> (<attvar?> Var)
(<if> (atom CUT Mod)
(<put-attr> Var Mod Val)
(type_error Mod atom))
(representation_error Var))))
(<define> (get_attr Var Mod Val)
(<if> (atom Mod)
(<get-attr> Var Mod)
(type_error Mod atom)))
(<let> ((Mod (<lookup> Mod))
(Var (<lookup> Var)))
(<if> (atom CUT Mod)
(<get-attr> Var Mod Val)
(type_error Mod atom))))
(<define> (del_attr Var Mod)
(<if> (atom Mod)
(<del-attr> Var Mod)
(type_error Mod atom)))
(<let> ((Mod (<lookup> Mod)))
(<if> (atom CUT Mod)
(<del-attr> Var Mod)
(type_error Mod atom))))
(<define> (construct_attr Y L)
(<recur> lp ((L L))
......@@ -32,4 +36,4 @@
(lp L)))
(()
(<cut> <cc>)))))
\ No newline at end of file
(<cut> <cc>)))))
(define-module (logic guile-log guile-prolog attribute)
(define-module (logic guile-log guile-prolog coroutine)
#:use-module (logic guile-log iso-prolog)
#:use-module (logic guile-log guile-prolog attribute)
#:export (feeeze frozen when dif))
#:use-module (logic guile-log umatch)
#:export (freeze frozen when dif))
(define doWhen (gp-make-var))
(define do_all_atts #f)
(define freezeId #f)
(define combine_atts #f)
(define do_all_atts_when #f)
(define whenId #f)
(define process_cond #f)
(define do_when #f)
(define diffId #f)
(define mk_cond #f)
(define membereq #f)
(compile-prolog-string
"
......@@ -10,99 +22,114 @@ do_all_atts([G|L]) :- call(G),!, do_all_atts(L).
do_all_atts([]).
% The unification algorithm
freezeId(Val, Var) :-
freezeId(Val, Var, _, _) :-
var(Val);attvar(Val);
(
get_attr(Var,freezeId, Atts),
write(Atts),nl,
do_all_atts(Atts),
del_attr(Var, freezeId),
Var = Val;
Var = Val
).
freeze(Var,Goal) :-
(var(Var),
( get_attr(Var, freezeId, Att),!,
(
get_attr(Var, freezeId, Att),!,
Att2 = [Goal|Att],
put_attr(Var, freezeId, Att2)
);
put_attr(Var, freezeId, [Att|NewVar]));
(
put_attr(Var, freezeId, [Goal])
)
);
call(Goal).
combine_atts([G,U |L], (G;GL)) :- combine_atts([U|L], GL),!.
combine_atts([G], G).
combine_atts([],true).
frozen(Var,Goal)
frozen(Var,Goal) :-
(
get_attr(Var, freezeId, Atts),!,
combine_atts(Atts,Goal)
) ;
Goal = true.
whenId(Val,Var)
%when(Condition, Goal)
do_all_atts_when(Val, [Id, G | L]) :-
call(G) -> (!,do_all_atts_when(Val, L)) ; (!,do_all_atts_when(Val, L)).
do_all_atts_when(Val, []).
whenId(Val, Var)
var(Val);attvar(Val);
(
get_attr(Var,whenId, Atts),
del_attr(Var, whenId),
Var = Val;
do_all_atts_when(Atts),
).
difId(Val, Var)
whenId(Val,Var) :-
(
var(Val);attvar(Val);
(var(scm[doWhen]) ->
(
get_attr(Var,whenId,Atts),!,
del_attr(Var, whenId),
Var = Val;
do_all_atts_when(Atts)
);
(
get_attr(Var,whenId,[VV|_]), VV=Val,!,
)
),!,
difId(Val, Var) :-
var(Val);attvar(Val);
(
get_attr(Var,whenId, Atts),
del_attr(Var, whenId),
Var = Val;
do_all_atts_when(Atts),
Var = Val,
do_all_atts_when(Atts)
).
process_goal((X,Y), Vars) :- !,
process_cond((X,Y), Vars) :- !,
process_cond(X,Vars1),
process_cond(Y,Vars2),
append(Vars1,Vars2,Vars).
process_goal((X;Y), Vars) :- !,
process_cond((X;Y), Vars) :- !,
process_cond(X,Vars1),
process_cond(Y,Vars2),
append(Vars1,Vars2,Vars).
process_cond(X=Y, [X]) :- !.
process_cond(nonvar(X), [X]) :- !.
%process_cond(ground(X), [X]) :- !.
% This is very non multithreading, let doWhen be a kanren style variable and
% we are golden.
process_cond(X=Y, [X], (\\+(scm[doWhen] = true, X=Y) -> false ; true)) :- !.
process_cond(nonvar(X), [X], nonvar(X)) :- !.
%process_cond(ground(X), [X], ground(X)) :- !.
mk_cond(V, Cond, Goal, Res) :- Res = (\\+Cond -> fail ; Goal).
mk_cond(V, Cond, Goal, Res) :- Res = Cond.
membereq(X, [A|B]) :- (X==A,!) ; membereq(X,B).
do_when(Cond, Goal, [V|Vs], Id, Did) :-
(
(get_attr(V, Did, Attr)
(get_attr(V, Did, [U|Attr]),
( membereq(Id, Attr) ->
fail ;
true ;
(
mk_cond(V,Cond,Goal,M),
put_attr(V, Did, [Id,M|Attr]
put_attr(V, Did, [U,Id,M|Attr])
)
)
);
mk_cond(V,Cond,Goal,M), put_attr(V, Did, [Id, M])
(
mk_cond(V,Cond,Goal,M),
put_attr(V, Did, [U, Id, M])
)
),
do_when(Cond, Goal, Vs, Did).
when(Cond, Goal) :-
process_cons(Cond,Vars), do_when(Cond, Goal, Vars, Id, whenId).
process_cond(Cond,Vars,Cond2), do_when(Cond2, Goal, Vars, Id, whenId).
diff(X, Y) :-
do_when(X=Y, X\\== Y, [X], Id, diffId).
")
\ No newline at end of file
")
......@@ -33,7 +33,7 @@
<define-guile-log-rule>
<get-fixed> <cp> <lookup> <wrap>
<with-bind>
<attvar?> <put_attr> <get_attr> <del_attr>
<attvar?> <put-attr> <get-attr> <del-attr>
))
......@@ -1080,7 +1080,8 @@ MAKE SURE TO REVISIT THIS IDEA LATER
(<with-guile-log> w code ...)))))
(<define> (<attvar?> x) (if (gp-attvar? x S) <cc> <fail>))
(<define> (<put-attr> x m v) (<with-s> (gp-put-attr x m v S) <cc>))
(<define> (<put-attr> x m v) (<let> ((s (gp-put-attr x m v S)))
(<with-s> s <cc>)))
(<define> (<get-attr> x m v)
(<let> ((ret (gp-get-attr x m S)))
(when ret (<=> v ret))))
......
......@@ -316,7 +316,7 @@
(cons x (lp l)))
(() '())))))
(pp 'res #`(begin
(ppp 'res #`(begin
(add-non-defined
(quote #,(datum->syntax stx (get-syms))))
lam-def ... #,@l #,@evl)))))))))
......
......@@ -296,19 +296,19 @@
(begin
(local-variable! v)
#`(<code>
(set! #,(datum->syntax stx v) (*var* stx y))))
(set! #,(datum->syntax stx v) `#,(*var* stx y))))
#`(<r=> #,(*var* stx x) #,(*var* stx y))))
(_
(match y
((#:variable v id nn mm)
(if (and (first-variable? v id) v
(variable-not-included? v x))
(begin
(local-variable! v)
#`(<code> (set! #,(datum->syntax stx v) (*var* stx x))))
#`(<r=> #,(*var* stx x) #,(*var* stx y))))
(_
#`(<r=> #,(*var* stx x) #,(*var* stx y))))))))
(_
(match y
((#:variable v id nn mm)
(if (and (first-variable? v id) v
(variable-not-included? v x))
(begin
(local-variable! v)
#`(<code> (set! #,(datum->syntax stx v) `#,(*var* stx y))))
#`(<r=> #,(*var* stx x) #,(*var* stx y))))
(_
#`(<r=> #,(*var* stx x) #,(*var* stx y))))))))
(mk-prolog-biop 'xfx "==" ident-tr identical <==> v v)
(mk-prolog-biop-not 'xfx "\\=" not-unify-tr not-unify <=> v v)
......
(define-module (logic guile-log prolog io)
#:use-module (logic guile-log)
#:use-module (logic guile-log attributed)
#:use-module (logic guile-log guile-prolog attribute)
#:use-module ((logic guile-log umatch)
#:select (gp-var? gp-lookup gp->scm))
#:use-module (logic guile-log guile-prolog closure)
......@@ -560,13 +561,13 @@
(cons x (cdr l))))
'())))))
((gp-attr-raw? a s)
((gp-attvar-raw? a s)
(let ((r (hashq-ref *variables* a #f)))
(if r
r
(let ((n (next-q)))
(hashq-set! *variables* a n)
(lp (vector (list construct_attr n (gp-att-data a))))))))
(lp (vector (list construct_attr n (gp-att-data a s))))))))
((gp-var? a s)
(let ((r (hashq-ref *variables* a #f)))
......
......@@ -6,7 +6,7 @@ SCM_DEFINE(gp_attvar, "gp-attvar?", 2, 0, 0, (SCM x, SCM s),
UNPACK_S0(l,s,"cannot unpack s in gp_ref_set");
SCM *ref;
if(GP(x));
if(GP(x))
{
ref = gp_lookup2(GP_GETREF(x), l);
if(GP(x) && (GP_ATTR(ref) || GP_UNBOUND(ref)))
......@@ -26,7 +26,7 @@ SCM_DEFINE(gp_attdata, "gp-att-data", 2, 0, 0, (SCM x, SCM s),
UNPACK_S0(l,s,"cannot unpack s in gp_ref_set");
SCM *ref;
if(GP(x));
if(GP(x))
{
ref = gp_lookup2(GP_GETREF(x), l);
if(GP(x) && GP_ATTR(ref))
......@@ -46,7 +46,7 @@ SCM_DEFINE(gp_put_attdata, "gp-att-put-data", 3, 0, 0, (SCM x, SCM v, SCM s),
UNPACK_S0(l,s,"cannot unpack s in gp_ref_set");
SCM *ref;
if(GP(x));
if(GP(x))
{
ref = gp_lookup2(GP_GETREF(x), l);
if(GP(x) && GP_UNBOUND(ref))
......@@ -64,6 +64,7 @@ SCM_DEFINE(gp_put_attdata, "gp-att-put-data", 3, 0, 0, (SCM x, SCM v, SCM s),
}
#undef FUNC_NAME
//#define DB(X) X
SCM_DEFINE(gp_attvar_raw, "gp-attvar-raw?", 2, 0, 0, (SCM x, SCM s),
"check to see if variable is an raw attributed variable")
#define FUNC_NAME s_gp_attvar_raw
......@@ -72,10 +73,11 @@ SCM_DEFINE(gp_attvar_raw, "gp-attvar-raw?", 2, 0, 0, (SCM x, SCM s),
UNPACK_S0(l,s,"cannot unpack s in gp_ref_set");
SCM *ref;
if(GP(x));
if(GP(x))
{
ref = gp_lookup2(GP_GETREF(x), l);
if(GP(x) && (GP_ATTR(ref)))
if(GP(GP_UNREF(ref)) && (GP_ATTR(ref)))
{
return SCM_BOOL_T;
}
......@@ -84,6 +86,7 @@ SCM_DEFINE(gp_attvar_raw, "gp-attvar-raw?", 2, 0, 0, (SCM x, SCM s),
}
#undef FUNC_NAME
//#define DB(X)
SCM_DEFINE(gp_put_attr, "gp-put-attr", 4, 0, 0,
(SCM x, SCM lam, SCM val, SCM s),
......
......@@ -1418,7 +1418,8 @@ static SCM gp_unify(SCM *id1, SCM *id2, int raw, int gp_plus_unify, SCM *l, stru
if(SCM_CONSP(SCM_CAR(xl)))
{
s =
scm_call_5(trampoline, GP_UNREF(id2), GP_UNREF(id1),
scm_call_6(trampoline, SCM_CAAR(xl),
GP_UNREF(id2), GP_UNREF(id1),
scm_raw,
scm_plus, 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