diff --git a/C/dbase.c b/C/dbase.c index b0af26266..33a4e6352 100755 --- a/C/dbase.c +++ b/C/dbase.c @@ -4394,6 +4394,73 @@ p_erase(void) return TRUE; } +/* increase_reference_counter(+Ref) */ +static Int +p_increase_reference_counter(void) +{ + Term t1 = Deref(ARG1); + LogUpdClause *cl; + + if (IsVarTerm(t1)) { + Yap_Error(INSTANTIATION_ERROR, t1, "increase_reference_counter/1"); + return FALSE; + } + if (!IsDBRefTerm(t1)) { + Yap_Error(TYPE_ERROR_DBREF, t1, "increase_reference_counter"); + return FALSE; + } + cl = (LogUpdClause *)DBRefOfTerm(t1); + PELOCK(67,cl->ClPred); + cl->ClRefCount++; + UNLOCK(cl->ClPred); + return TRUE; +} + +/* increase_reference_counter(+Ref) */ +static Int +p_decrease_reference_counter(void) +{ + Term t1 = Deref(ARG1); + LogUpdClause *cl; + + if (IsVarTerm(t1)) { + Yap_Error(INSTANTIATION_ERROR, t1, "increase_reference_counter/1"); + return FALSE; + } + if (!IsDBRefTerm(t1)) { + Yap_Error(TYPE_ERROR_DBREF, t1, "increase_reference_counter"); + return FALSE; + } + cl = (LogUpdClause *)DBRefOfTerm(t1); + PELOCK(67,cl->ClPred); + if (cl->ClRefCount) { + cl->ClRefCount--; + UNLOCK(cl->ClPred); + return TRUE; + } + UNLOCK(cl->ClPred); + return FALSE; +} + +/* erase(+Ref) */ +static Int +p_current_reference_counter(void) +{ + Term t1 = Deref(ARG1); + LogUpdClause *cl; + + if (IsVarTerm(t1)) { + Yap_Error(INSTANTIATION_ERROR, t1, "increase_reference_counter/1"); + return FALSE; + } + if (!IsDBRefTerm(t1)) { + Yap_Error(TYPE_ERROR_DBREF, t1, "increase_reference_counter"); + return FALSE; + } + cl = (LogUpdClause *)DBRefOfTerm(t1); + return Yap_unify(ARG2, MkIntegerTerm(cl->ClRefCount)); +} + static Int p_erase_clause(void) { @@ -5443,6 +5510,9 @@ Yap_InitDBPreds(void) Yap_InitCPred("$recordzp", 4, p_drcdzp, SyncPredFlag|HiddenPredFlag); Yap_InitCPred("erase", 1, p_erase, SafePredFlag|SyncPredFlag); Yap_InitCPred("$erase_clause", 2, p_erase_clause, SafePredFlag|SyncPredFlag|HiddenPredFlag); + Yap_InitCPred("increase_reference_count", 1, p_increase_reference_counter, SafePredFlag|SyncPredFlag); + Yap_InitCPred("decrease_reference_count", 1, p_decrease_reference_counter, SafePredFlag|SyncPredFlag); + Yap_InitCPred("current_reference_count", 2, p_current_reference_counter, SafePredFlag|SyncPredFlag); Yap_InitCPred("erased", 1, p_erased, TestPredFlag | SafePredFlag|SyncPredFlag); Yap_InitCPred("instance", 2, p_instance, SyncPredFlag); Yap_InitCPred("$instance_module", 2, p_instance_module, SyncPredFlag|HiddenPredFlag); diff --git a/packages/meld/graph0.meld b/packages/meld/graph0.meld new file mode 100644 index 000000000..b3897027e --- /dev/null +++ b/packages/meld/graph0.meld @@ -0,0 +1,10 @@ +root(a). + +neighbor(a,b). +neighbor(b,a). +neighbor(a,c). +neighbor(c,a). + +temperature(a, 10). +temperature(b, 12). +temperature(c, 15). diff --git a/packages/meld/graph1.meld b/packages/meld/graph1.meld new file mode 100644 index 000000000..48625bccb --- /dev/null +++ b/packages/meld/graph1.meld @@ -0,0 +1,10 @@ +root(a). + +neighbor(a,b). +neighbor(b,a). +neighbor(a,c). +neighbor(c,a). + +temperature(a, 20). +temperature(b, 12). +temperature(c, 15). diff --git a/packages/meld/graph2.meld b/packages/meld/graph2.meld new file mode 100644 index 000000000..ebad562bd --- /dev/null +++ b/packages/meld/graph2.meld @@ -0,0 +1,15 @@ +root(a). + +neighbor(a,b). +neighbor(b,a). +neighbor(a,c). +neighbor(c,a). +neighbor(d,b). +neighbor(b,d). +neighbor(d,c). +neighbor(c,d). + +temperature(a, 10). +temperature(b, 12). +temperature(c, 15). +temperature(d, 20). diff --git a/packages/meld/graph3.meld b/packages/meld/graph3.meld new file mode 100644 index 000000000..1cc1c72d3 --- /dev/null +++ b/packages/meld/graph3.meld @@ -0,0 +1,6 @@ +root(a). + +neighbor(a,b). +neighbor(b,a). + +temperature(a, 10). diff --git a/packages/meld/maxtemp.meld b/packages/meld/maxtemp.meld new file mode 100644 index 000000000..51f3a63cc --- /dev/null +++ b/packages/meld/maxtemp.meld @@ -0,0 +1,34 @@ + +%:- ensure_loaded(l + +type logical_neighbor parent(module, first module). +type maxTemp(module, max float). + +parent(A, A) :- root(A). +parent(A, B) :- + neighbor(A, B), + parent(B, _). + +maxTemp(A, T) :- + temperature(A, T). +maxTemp(B, T) :- + parent(A, B), + maxTemp(A, T). + +type globalMax(module, max float). + +globalMax(A, T) :- + maxTemp(A, T), + root(A). +globalMax(B, T) :- + neighbor(A, B), + globalMax(A, T). + +type localMax(module). +localMax(A) :- + temperature(A,T), + forall + neighbor(A, B) + then + ( temperature(B, TT), T > TT ). + diff --git a/packages/meld/meld.yap b/packages/meld/meld.yap new file mode 100644 index 000000000..6917b93d1 --- /dev/null +++ b/packages/meld/meld.yap @@ -0,0 +1,22 @@ +:- module(meld_core, + [simulate/1, + op(1200, fy, (type)), + op(1150, fy, (logical_neighbor)), + op( 500, fy, (first)), + op( 500, fy, (max)), + op( 950, fy, (forall)), + op( 900, xfy, (then)) + ]). + +:- style_check(all). + +:- reexport(meldi). + +:- reexport(meldc). + +simulate(G) :- + input_graph(G), + live. + + + diff --git a/packages/meld/meldc.yap b/packages/meld/meldc.yap new file mode 100644 index 000000000..389eaef4a --- /dev/null +++ b/packages/meld/meldc.yap @@ -0,0 +1,213 @@ +:- style_check(all). + +:- yap_flag(unknown,error). + +:- module(meld_compiler, + [ + mcompile/1, + input_graph/1, + run/1 + ]). + +:- use_module(meldi, + [ + push/1, + first/2, + min/3, + max/3 + ]). + +:- use_module(meld). + +:- use_module(library(terms), [ + variable_in_term/2 + ]). + +mcompile(Program) :- + open(Program, read, P), + init_mcompile(Program), + repeat, + read_term(P, Term, [variable_names(Vars), module(meld_compiler)]), + ( + Term == end_of_file + -> + !, + close(P) + ; + mcompile(Term, Program, Vars), + fail + ). + +init_mcompile(Program) :- + retractall(type(_, _, Program, _)). + +mcompile(type(T), Program, Vars) :- + ground_term(T, Vars), + type_declaration(T, Program), !. +mcompile((Head :- Body), _, _Vars) :- + rule(Head, Body). + +type_declaration(logical_neighbor(T), Program) :- !, + type_declaration(T, Program). +type_declaration(T, _) :- + functor(T, N, A), + dynamic(meld_program:N/A), + fail. +type_declaration(T, Program) :- + T =.. [P|Args], + check_aggregate(Args, 1, NewArgs, Aggregation, Arg), + !, + NT =.. [P|NewArgs], + assert_type(NT, Program, aggregation(Aggregation, Arg)). +type_declaration(T, Program) :- + assert_type(T, Program, horn). + +assert_type(NT, Program, Agg) :- + functor(NT, Na, Ar), + functor(Spec, Na, Ar), + assert(type(Spec, NT, Program, Agg)). + +check_aggregate([first(Type)|Args], I, [Type|Args], first, I) :- !. +check_aggregate([max(Type)|Args], I, [Type|Args], max, I) :- !. +check_aggregate([min(Type)|Args], I, [Type|Args], min, I) :- !. +check_aggregate([Type|Args], I, [Type|NewArgs], Agg, Arg) :- + atom(Type), + I1 is I+1, + check_aggregate(Args, I1, NewArgs, Agg, Arg). + +ground_term(_, []). + +rule(Head, Body) :- + bodytolist(Body, L, []), + compile_goals(L, [], Head). + +compile_goals([], _, _). +compile_goals([Goal|Goals], Gs, Head) :- + compile_goal(Goal, Goals, Gs, Head), + compile_goals(Goals, [Goal|Gs], Head). + +compile_goal((forall G then Do), Goals, Gs, Head) :- !, + % make sure quantified variables are not seen outside + quantified_vars(G,Gs+Goals,NG), + % + % just collect the body into a number of goals + % + collect_body(Gs, [(forall G then Do)|Goals], BLF, BL1), + % make a backup copy for deletion + copy_term(h(Head,BLF,BL1,NG), h(Head,DelBLF,DelBL1,DelNG)), + % add the operation, usually push + extra_head(Head, BL1, []), + % add the delete operation + extra_delete(Head, DelBL1, []), + % create the body as a conjunction + listtobody(BLF, Body), + listtobody(DelBLF, DelBody), + % done + assert(meld_program:(run(NG) :- Body)), + assert(meld_program:(run(delete(DelNG)) :- DelBody)). +compile_goal(Goal, Goals, Gs, Head) :- + collect_body(Gs, Goals, BLF, BL1), + copy_term(h(Head,BLF,BL1,Goal), h(Head,DelBLF,DelBL1,DelGoal)), + extra_head(Head, BL1, []), + extra_delete(Head, DelBL1, []), + listtobody(BLF, Body), + listtobody(DelBLF, DelBody), + assert(meld_program:(run(Goal) :- Body)), + assert(meld_program:(run(deleted(DelGoal)) :- DelBody)). + +% quantified variables should not leave the scope of the forall. +quantified_vars(G,Extern,NG) :- + term_variables(G, TVs), + copy_term(G+TVs,NG+NTVs), + bind_external(TVs, NTVs, Extern). + +bind_external([], [], _). +bind_external(V.TVs, NV.NTVs, Extern) :- + variable_in_term(Extern, V), !, + V = NV, + bind_external(TVs, NTVs, Extern). +bind_external(_.TVs, _.NTVs, Extern) :- + bind_external(TVs, NTVs, Extern). + +% a very simple version +% +collect_body([], []) --> []. +collect_body([G|Gs], MGs) --> + process_goal(G), + collect_body(Gs, MGs). +collect_body([], [G|Gs]) --> + process_goal(G), + collect_body([], Gs). + +process_goal((forall Goal then Conj)) --> !, + [(Goal, \+ Conj -> fail ; true)]. +process_goal( G ) --> + [G]. + + + +extra_head(Head) --> + { type(Head, _, _, horn) }, + [push(Head)]. +extra_head(Head) --> + { type(Head, _, _, aggregation(first, Arg)), freshen(Head, Arg, VHead) }, + [ meld_interpreter:first(VHead, Head)]. +extra_head(Head) --> + { type(Head, _, _, aggregation(max, Arg)), freshen(Head, Arg, VHead) }, + [ meld_interpreter:max(VHead, Arg, Head)]. +extra_head(Head) --> + { type(Head, _, _, aggregation(min, Arg)), freshen(Head, Arg, VHead) }, + [ meld_interpreter:min(VHead, Arg, Head)]. + +extra_delete(Head) --> + { type(Head, _, _, horn) }, + [meld_interpreter:deleted(Head)]. +extra_delete(Head) --> + { type(Head, _, _, aggregation(first, Arg)), freshen(Head, Arg, VHead) }, + [ meld_interpreter:delete_from_first(VHead, Head)]. +extra_delete(Head) --> + { type(Head, _, _, aggregation(max, Arg)), freshen(Head, Arg, VHead) }, + [ meld_interpreter:delete_from_max(VHead, Arg, Head)]. +extra_delete(Head) --> + { type(Head, _, _, aggregation(min, Arg)), freshen(Head, Arg, VHead) }, + [ meld_interpreter:delete_from_min(VHead, Arg, Head)]. + +freshen(Head, Arg, VHead) :- + Head =.. [N|Args], + freshen_arg(Arg, Args, VArgs), + VHead =.. [N|VArgs]. + +freshen_arg(1, [_|Args], [_|Args]) :- !. +freshen_arg(N, A.Args, A.VArgs) :- + N1 is N-1, + freshen_arg(N1, Args, VArgs). + +input_graph(Program) :- + open(Program, read, P), + repeat, + read_term(P, Term, [variable_names(_Vars), module(meld_compiler)]), + ( + Term == end_of_file + -> + !, + close(P) + ; + add_graph_fact(Term), + fail + ). + +add_graph_fact(Term) :- + push(Term). + +bodytolist((G1,G2)) --> + !, + bodytolist(G1), + bodytolist(G2). +bodytolist(G) --> + [G]. + +listtobody([G], G) :- !. +listtobody([G|GL], (G,Gs)) :- + listtobody(GL, Gs). + + diff --git a/packages/meld/meldi.yap b/packages/meld/meldi.yap new file mode 100644 index 000000000..fae101f32 --- /dev/null +++ b/packages/meld/meldi.yap @@ -0,0 +1,231 @@ + +:- module(meld_interpreter, + [ + live/0, + delete/1, + push/1, + first/2, + min/3, + max/3 + ]). + + +:- use_module(meldp, + [ + run/1 + ]). + + +:- use_module(library(nb), + [ + nb_queue/1, + nb_queue_enqueue/2, + nb_queue_dequeue/2 + ]). + + +:- initialization + init_meld_queue. + +live :- + repeat, + ( pop(Goal) -> + format('-~w~n',[Goal]), + run(Goal), + fail + ; + !, + done + ). + +done :- + current_predicate(meld_program:P), + P \= run/1, +% P \= neighbor/2, +% P \= root/1, + listing(meld_program:P), + fail. +done. + + +delete(Fact) :- + nb_getval(meld_queue, Queue), + retract(meld_program:Fact), +nb_queue_enqueue(Queue, deleted(Fact)), + live. + +pop(Goal) :- + nb_getval(meld_queue, Queue), + nb_queue_dequeue(Queue, Goal). + +push(Goal) :- + clause(meld_program:Goal,_,Ref), + !, + writeln(Goal+ref), + increase_reference_count(Ref), + fail. +push(Goal) :- +% format('+~w~n',[Goal]), + writeln(Goal+0), + nb_getval(meld_queue, Queue), !, + assert(meld_program:Goal), + nb_queue_enqueue(Queue, Goal). + + +% create a queue +init_meld_queue :- + nb_queue(Queue), + nb_setval(meld_queue, Queue). + +first(Skel,Goal) :- + meld_program:Skel, !, + cache(Goal). +first(_,Goal) :- + cache(Goal), + push(Goal). + +max(Skel,Arg,Goal) :- + meld_program:Skel, + arg(Arg, Skel, A0), + arg(Arg, Goal, AN), + AN =< A0, !, + cache(Goal). +max(Skel,_,Goal) :- + clean(Skel), + cache(Goal), + push(Goal). + +min(Skel,Arg,Goal) :- + meld_program:Skel, + arg(Arg, Skel, A0), + arg(Arg, Goal, AN), + AN >= A0, !, + cache(Goal). +min(Skel,_,Goal) :- + clean(Skel), + cache(Goal), + push(Goal). + +clean(Skel) :- +% format('D~w~n',[Skel]), + retractall(meld_program:Skel). + +cache(Goal) :- + writeln(cache(Goal)),fail. +cache(Goal) :- + clause(meld_cache:Goal,_,Ref), + !, + increase_reference_count(Ref). +cache(Goal) :- + assert(meld_cache:Goal). + + +deleted(Goal) :- + clause(meld_program:Goal,_,Ref), + decrease_reference_count(Ref), + !, + fail. +deleted(Goal) :- +% format('-~w~n',[Goal]), + nb_getval(meld_queue, Queue), !, + retract(meld_program:Goal), + nb_queue_enqueue(Queue, deleted(Goal)). + + + +% +% first, cleanup cache +% +delete_from_first(_,Goal) :- + clause(meld_cache:Goal,_,Ref), + ( + decrease_reference_count(Ref) + -> + fail + ; + erase(Ref), + fail + ). +delete_from_first(_,Goal) :- + clause(meld_program:Goal,_,Ref), + decrease_reference_count(Ref), + !, + fail. +delete_from_first(VGoal,Goal) :- + retract(meld_program:Goal), + push(deleted(Goal)), + once(meld_cache:VGoal), + push(VGoal). + + +delete_from_max(VGoal,Arg,Goal) :- + clause(meld_cache:Goal,_,Ref), + ( + decrease_reference_count(Ref) + -> + clause(meld_program:Goal,_,CRef), + decrease_reference_count(CRef), + fail + ; + erase(Ref), + new_max(VGoal, Arg, Goal) + ). + +new_max(VGoal,Arg,Goal) :- +% format('-~w~n',[Goal]), + retract(meld_program:Goal), + push(deleted(Goal)), + writeln(delete_from_max(VGoal,Arg,Goal)), + maxval(Arg, meld_cache:VGoal, VGoal), + push(VGoal). + +delete_from_min(VGoal,Arg,Goal) :- + clause(meld_cache:Goal,_,Ref), + ( + decrease_reference_count(Ref) + -> + clause(meld_program:Goal,_,CRef), + decrease_reference_count(CRef), + fail + ; + erase(Ref), + new_min(VGoal, Arg, Goal) + ). + +new_min(VGoal,Arg,Goal) :- +% format('-~w~n',[Goal]), + retract(meld_program:Goal), + push(deleted(Goal)), + writeln(delete_from_min(VGoal,Arg,Goal)), + minval(Arg, meld_cache:VGoal, VGoal), + push(VGoal). + +minval(_,_,_) :- + nb_setval(min, +inf), + nb_setval(min_arg, '$none'), + fail. +minval(V,G,GMax) :- + call(G), + nb_getval(min, V0), + V < V0, + nb_setval(min, V), + nb_setval(min_arg, V.GMax), + fail. +minval(V,_,GMax) :- + nb_getval(min_arg, V.GMax). + + +maxval(_,_,_) :- + nb_setval(max, -inf), + nb_setval(max_arg, '$none'), + fail. +maxval(V,G,GMax) :- + call(G), + nb_getval(max, V0), + V > V0, + nb_setval(max, V), + nb_setval(max_arg, V.GMax), + fail. +maxval(V,_,GMax) :- + nb_getval(max_arg, V.GMax). + diff --git a/packages/meld/meldp.yap b/packages/meld/meldp.yap new file mode 100644 index 000000000..1dc4ba72f --- /dev/null +++ b/packages/meld/meldp.yap @@ -0,0 +1,23 @@ +:- module(meld_program, + [ + run/1 + ]). + + +:- use_module(meldi, + [ + push/1, + first/2, + min/3, + max/3 + ]). + + +% built-ins. +:- dynamic root/1, neighbor/2, temperature/2. + +trace(A,B) :- !, + writeln((A:-B)), + trace. + +