% % A compiler for Meld programs % can understand aggregates. % :- module(meld_compiler, [ mcompile/1, input_graph/1, run/1 ]). :- use_module(meldi, [ push/1, first/2, min/3, max/3, sum/3 ]). :- use_module(library(meld)). :- use_module(library(terms), [ variable_in_term/2 ]). :- use_module(library(ordsets), [ ord_subset/2, ord_union/3 ]). :- dynamic meld_constants:const/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(const(T=V), _Program, Vars) :- ground_term(T, Vars), const_declaration(T, V), !. mcompile((Head :- Body), _, _Vars) :- rule(Head, Body). type_declaration(extensional(T), Program) :- !, functor(T, Na, Arity), functor(NT, Na, Arity), assert(meld_topdown:extensional(NT, Na, Arity)), type_declaration(T, Program). type_declaration(logical_neighbor(T), Program) :- !, type_declaration(T, Program). type_declaration(persistent(T), Program) :- !, type_declaration(T, Program). type_declaration(extern(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)). const_declaration(C,V) :- !, ( atom(C) -> true ; throw(type_error(atom,C),const(C=V))), ( number(V) -> true ; throw(type_error(number,V),const(C=V))), assert(meld_constants:const(C, V)). 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([sum(Type)|Args], I, [Type|Args], sum, 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 compiler % rule(Head, Body) :- bodytolist(Body, L0, []), builtins(L0, L, R), builtins([Head], RLH, []), join(RLH, NHead, R, []), compile_goals(L, [], NHead). builtins([]) --> []. builtins(G.Gs) --> builtin(G), builtins(Gs). builtin(Res = Op) --> !, process_constants(Op, Res). builtin(Goal) --> process_constants(Goal, NGoal), [ NGoal ]. process_constants(G, G) --> { var(G) }, !. process_constants(C, V) --> { meld_constants:const(C,V) }, !. process_constants(G, G) --> { atomic(G) }, !. process_constants(to_float(Arg1), NArg1) --> !, process_constants(Arg1, NArg1). process_constants(A, NA) --> { arithmetic(A, Op, Arg1, Arg2) }, !, process_constants(Arg1, NArg1), process_constants(Arg2, NArg2), { arithmetic(NExp, Op, NArg1, NArg2) }, [ NA is NExp ]. process_constants(A, NA) --> { arithmetic(A, Op, Arg1) }, !, process_constants(Arg1, NArg1), { arithmetic(NExp, Op, NArg1) }, [ NA is NExp ]. process_constants(G, NG) --> { G =.. [A|Args] }, process_args(Args, NArgs), { NG =.. [A|NArgs] }. process_args([], []) --> []. process_args(A.Args, NA.NArgs) --> process_constants(A, NA), process_args(Args, NArgs). join([H0], H0) --> !. join([H|T], H0) --> [H], join(T, H0). compile_goals([], _, _). compile_goals([Goal|Goals], Gs, Head) :- compile_goal(Goal, Goals, Gs, Head), compile_goals(Goals, [Goal|Gs], Head). compile_goal(BIP, _Goals, _Gs, _Head) :- meld_builtin(BIP, _, _), !. 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, []), % reorder builtins reorder_builtins(NG, BLF, BLF2), reorder_builtins(DelNG, DelBLF, DelBLF2), % create the body as a conjunction listtobody(BLF2, Body), listtobody(DelBLF2, DelBody), % done assert_static(meld_program:(run(NG) :- Body)), assert_static(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, []), % reorder builtins reorder_builtins(Goal, BLF, BLF2), reorder_builtins(DelGoal, DelBLF, DelBLF2), listtobody(BLF2, Body), listtobody(DelBLF2, DelBody), assert_static(meld_program:(run(Goal) :- Body)), assert_static(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_head(Head) --> { type(Head, _, _, aggregation(sum, Arg)), freshen(Head, Arg, VHead) }, [ meld_interpreter:sum(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)]. extra_delete(Head) --> { type(Head, _, _, aggregation(sum, Arg)), freshen(Head, Arg, VHead) }, [ meld_interpreter:delete_from_sum(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). reorder_builtins(Head, BLF, BLF2) :- term_variables(Head, Vs0), sort(Vs0, Vs), reorder_term(BLF, Vs, [], BLF2). % 4 arguments % list of input goals % queue of built-ins waiting for execution % list of current variables % output variables % reorder_term([], _, [], []). reorder_term(G.Gs, Vs0, Queue, NGs) :- meld_builtin(G, Is, Os), !, term_variables(Is, InpVs0), sort(InpVs0, InpVs), continue_reorder_term(Gs, G, InpVs, Vs0, Queue, Os, NGs). reorder_term(G.Gs, Vs0, Queue, G.NGs) :- term_variables(G, GVs0), sort(GVs0, GVs), ord_union(GVs, Vs0, Vs), wake_queue(Queue, NewQueue, Vs, Vs0, NewQueue, FVs, NGs, NGs0), reorder_term(Gs, FVs, NewQueue, NGs0). continue_reorder_term(Gs, G, InpVs, Vs0, Queue, Os, G.NGs) :- ord_subset(InpVs, Vs0), !, term_variables(Os, OutVs0), sort(OutVs0, OutVs), ord_union(OutVs, Vs0, Vs), wake_queue(Queue, NewQueue, Vs, Vs0, NewQueue, FVs, NGs, NGs0), reorder_term(Gs, FVs, NewQueue, NGs0). continue_reorder_term(Gs, G, InpVs, Vs0, Queue, Os, NGs) :- term_variables(Os, OutVs0), sort(OutVs0, OutVs), reorder_term(Gs, Vs0, q(InpVs, OutVs, G).Queue, NGs). wake_queue([], _, Vs, _, [], Vs) --> []. wake_queue(Q.Queue, _, Vs, Vs0, Q.Queue, Vs) --> { Vs == Vs0 }, !. wake_queue(q(InpVs,OutVs,G).Queue, NewQueue, Vs, Vs0, Queue, FVs) --> { ord_subset(InpVs, Vs) }, !, [G], { ord_union(OutVs, Vs, NVs) }, % restart from beginning wake_queue(NewQueue, NewNewQueue, NVs, Vs0, NewNewQueue, FVs). wake_queue(Q.Queue, NewQueue, NVs, Vs0, Q.NQueue, FVs) --> wake_queue(Queue, NewQueue, NVs, Vs0, NQueue, FVs). meld_builtin(O is I, I, O). meld_builtin(I1 =< I2, I1-I2, []). meld_builtin(I1 >= I2, I1-I2, []). meld_builtin(I1 =:= I2, I1-I2, []). arithmetic( A+B, (+), A, B). arithmetic( A-B, (-), A, B). arithmetic( A*B, (*), A, B). arithmetic( A/B, (/), A, B). arithmetic( sin(A), sin, A). arithmetic( cos(A), cos, A). arithmetic( tan(A), tan, A).