%------------------------------------------------------------ % File : chr2ar.pl % Author : Neng-Fa ZHOU & Tom Schrijvers % Version: 0.1 % Date : April 2006 % Purpose: A translator for converting CHR into AR in B-Prolog % Based on "Translating CHR into AR", by % Tom Schrijvers, Neng-Fa Zhou and Bart Demoen, CHR'06. %------------------------------------------------------------ /* Disclaimer: This implementation is very preliminary: It performs no optimization, and is unable to handle pragma declarations. Bugs are very likely. Top predicates: consult_chr(File): consult a CHR file named File. cl_chr(File): compile and load a CHR file named File. chr2ar(File): convert a CHR file named File into AR and display the output in stdout. chr2ar(File,OutFile): convert a CHR file named File into AR and store the output into OutFile. */ :- op(1050, xfy, ':'). :- op(1180, xfx, ==>). :- op(1180, xfx, <=>). :- op(1100, xfx, \). :- op(1150, fx, constraints). :- op(1200, xfx, @). % values from hProlog :- op(1190, xfx, pragma). % values from hProlog :- op( 500, yfx, #). % values from hProlog consult_chr(File):- chr2ar(File,'__$tmp.pl'), consult('__$tmp.pl'). cl_chr(File):- chr2ar(File,'__$tmp.pl'), cl('__$tmp.pl'). chr2ar(File):- chr2ar(File,user). chr2ar(File,OutFile):- check_chr_file(File,InFile), chr2ar_get_rules(InFile,Rules), global_set($temp_pred_num,0), % for generating new predicate symbols tell(OutFile), new_hashtable(TempPreds), reform_rules(Rules,Rules1,[],TempPreds,1), % initial rule id is 1 flatten_rules(Rules1,Rules2), % gather constraint symbols, and associate rules with them register_into_preds(Rules2,Preds), new_hashtable(MaxChTable), compute_max_channels(Preds,MaxChTable), generate_code_preds(Preds,Preds,TempPreds,MaxChTable), told. /************************************************************/ %% Read in rules into a list chr2ar_get_rules(InFile,Rules):- see(InFile), read_rule(InFile,Rule), chr2ar_get_rules(Rule,InFile,Rules), seen. chr2ar_get_rules(end_of_file,InFile,Rules):-!,Rules=[]. chr2ar_get_rules(Rule,InFile,[Rule|Rules]):- read_rule(InFile,NRule), chr2ar_get_rules(NRule,InFile,Rules). read_rule(InFile,Cl):- read_singleton_vars(Cl,SVars), % % in B-Prolog display_singleton_vars(InFile,SVars). % % in B-Prolog /************************************************************/ %% Transform all CHR rules into two-headed ones and divide them %% into predicates. A two-headed rule occurs in two predicates %% if the two constraint patterns in the head have different %% predicate symbols reform_rules([],NRules,NRules,TempPreds,RuleId). reform_rules([Rule|Rules],NRules,NRulesR,TempPreds,RuleId):- reform_rule(Rule,NRules,NRules1,TempPreds,RuleId,RuleId1), reform_rules(Rules,NRules1,NRulesR,TempPreds,RuleId1). reform_rule((ID@Rule),NRules,NRulesR,TempPreds,RuleId0,RuleId):-true : reform_rule(Rule,NRules,NRulesR,TempPreds,RuleId0,RuleId). reform_rule((H<=>RHS),NRules,NRulesR,TempPreds,RuleId0,RuleId):-true : reform_rule(simplification,H,RHS,NRules,NRulesR,TempPreds,RuleId0,RuleId). reform_rule((H==>RHS),NRules,NRulesR,TempPreds,RuleId0,RuleId):-true : reform_rule(propagation,H,RHS,NRules,NRulesR,TempPreds,RuleId0,RuleId). reform_rule(Cl,NRules,NRules,TempPreds,RuleId0,RuleId):- % copy Prolog clauses RuleId=RuleId0, my_portray_clause(Cl). reform_rule(Type,(H1\H2),RHS,NRules,NRulesR,TempPreds,RuleId0,RuleId):-true : Type1=simpagation, reform_rule_head(H1,NH1,NRules,NRules1,TempPreds,RuleId0,RuleId1), reform_rule_head(H2,NH2,NRules1,NRules2,TempPreds,RuleId1,RuleId2), Rule=rule(RuleId2,Type1,NH1,NH2,Guard,Body), RuleId is RuleId2+1, NRules2=[Rule|NRulesR], extract_chr_guard_body(RHS,Guard,Body). reform_rule(Type,(H1,H2,H3),RHS,NRules,NRulesR,TempPreds,RuleId0,RuleId):-true : % multi-headed reform_rule_head((H1,H2),H12,NRules,NRules1,TempPreds,RuleId0,RuleId1), reform_rule(Type,(H12,H3),RHS,NRules1,NRulesR,TempPreds,RuleId1,RuleId). reform_rule(Type,(H1,H2),RHS,NRules,NRulesR,TempPreds,RuleId0,RuleId):-true : % double-headed reform_rule_head(H1,NH1,NRules,NRules1,TempPreds,RuleId0,RuleId1), reform_rule_head(H2,NH2,NRules1,NRules2,TempPreds,RuleId1,RuleId2), functor(NH1,F1,N1), functor(NH2,F2,N2), Rule=rule(RuleId2,Type,NH1,NH2,Guard,Body), RuleId is RuleId2+1, NRules2=[Rule|NRulesR], extract_chr_guard_body(RHS,Guard,Body). reform_rule(Type,H,RHS,NRules,NRulesR,TempPreds,RuleId0,RuleId):- true : % single-headed functor(H,F,N), extract_chr_guard_body(RHS,Guard,Body), Rule=rule(RuleId0,Type,H,$dummy,Guard,Body), RuleId is RuleId0+1, NRules=[Rule|NRulesR]. reform_rule_head((H1,H2,H3),NH,NRules,NRulesR,TempPreds,RuleId0,RuleId):-true : reform_rule_head(H1,NH1,NRules,NRules1,TempPreds,RuleId0,RuleId1), reform_rule_head(H2,NH2,NRules1,NRules2,TempPreds,RuleId1,RuleId2), new_temp_pred_symbol(NewF), create_new_head(NH1,NH2,NewF,H12), hashtable_put(TempPreds,NewF,NewF), TempRule=rule(RuleId2,temp_rule,Head1,Head2,true,Head12), NRules2=[TempRule|NRules3], create_new_rule(NH1,NH2,NewF,Head1,Head2,Head12), % Head1,Head2 ==> Head12 RuleId3 is RuleId2+1, reform_rule_head((H12,H3),NH,NRules3,NRulesR,TempPreds,RuleId3,RuleId). reform_rule_head((H1,H2),NH,NRules,NRulesR,TempPreds,RuleId0,RuleId):-true : reform_rule_head(H1,NH1,NRules,NRules1,TempPreds,RuleId0,RuleId1), reform_rule_head(H2,NH2,NRules1,NRules2,TempPreds,RuleId1,RuleId2), new_temp_pred_symbol(NewF), hashtable_put(TempPreds,NewF,NewF), create_new_head(NH1,NH2,NewF,NH), TempRule=rule(RuleId2,temp_rule,Head1,Head2,true,Head12), RuleId is RuleId2+1, NRules2=[TempRule|NRulesR], create_new_rule(NH1,NH2,NewF,Head1,Head2,Head12). % Head1,Head2 ==> Head12 reform_rule_head(H,NH,NRules,NRulesR,TempPreds,RuleId0,RuleId):-true : NH=H,NRules=NRulesR,RuleId0=RuleId. create_new_head(H1,H2,NewF,H12):- functor(H1,F1,N1), H1=..[_|Args1], functor(H2,F2,N2), H2=..[_|Args2], append(Args1,Args2,Args), H12=..[NewF|Args]. % create a rule for a temporary constraint (Head1,Head2==>Head12) create_new_rule(H1,H2,NewF,Head1,Head2,Head12):- functor(H1,F1,N1),functor(H2,F2,N2), functor(Head1,F1,N1),Head1=..[_|Args1], functor(Head2,F2,N2),Head2=..[_|Args2], append(Args1,Args2,Args), Head12=..[NewF|Args]. /************************************************************/ %% Flatten the rules such that all matching operations are moved to %% the guard and all arguments of H1 and H2 are unique free variables. flatten_rules([],NRules):-NRules=[]. flatten_rules([rule(RuleId,Type,H1,H2,Guard,Body)|Rules],[NRule|NRules]):- NRule=rule(RuleId,Type,NH1,NH2,NGuard,Body), H1=..[F1|Args1], flatten_rule_head_args(Args1,NArgs1,[],Vars1,Tests,Tests1), NH1=..[F1|NArgs1], H2=..[F2|Args2], flatten_rule_head_args(Args2,NArgs2,Vars1,_Vars,Tests1,[]), NH2=..[F2|NArgs2], reform_guard(Guard,Guard1), merge_guard_tests(Guard1,Tests,NGuard), flatten_rules(Rules,NRules). flatten_rule_head_args([],NArgs,Vars0,Vars,Tests,TestsR):-NArgs=[],Vars=Vars0,Tests=TestsR. flatten_rule_head_args([Arg|Args],[NArg|NArgs],Vars0,Vars,Tests,TestsR):- var(Arg),!, (membchk(Arg,Vars0)-> % Arg occurred before Tests=[Arg==NArg|Tests1], Vars1=Vars0; NArg=Arg, Tests=Tests1, Vars1=[Arg|Vars0]), flatten_rule_head_args(Args,NArgs,Vars1,Vars,Tests1,TestsR). flatten_rule_head_args([Arg|Args],[NArg|NArgs],Vars0,Vars,Tests,TestsR):- atomic(Arg),!, Tests=[NArg==Arg|Tests1], flatten_rule_head_args(Args,NArgs,Vars0,Vars,Tests1,TestsR). flatten_rule_head_args([Arg|Args],[NArg|NArgs],Vars0,Vars,Tests,TestsR):- Tests=[nonvar(NArg),NArg=CompTerm|Tests1], Arg=..[F|Comps], flatten_rule_head_args(Comps,NComps,Vars0,Vars1,Tests1,Tests2), CompTerm=..[F|NComps], flatten_rule_head_args(Args,NArgs,Vars1,Vars,Tests2,TestsR). /************************************************************/ % A rule defines a predicate if the symbol occurs in the head. % Fill the hashtable preds with all constraint symbols, % with associated rules they appear in. register_into_preds([],Preds):-true : true. register_into_preds([Rule|Rules],Preds):-true : register_into_preds_aux(Rule,Preds), register_into_preds(Rules,Preds). register_into_preds_aux(Rule,Preds):- Rule=rule(RuleId,Type,H1,$dummy,Guard,Body) : functor(H1,F1,N1), $member1(pred(F1,N1,MaxChNo,SingleHeaded,RulesForH1),Preds), attach(rule(RuleId,Type,H1,ChNoH1,$dummy,_,Guard,Body),RulesForH1). register_into_preds_aux(Rule,Preds):- Rule=rule(RuleId,simpagation,H1,H2,Guard,Body) : functor(H1,F1,N1), functor(H2,F2,N2), $member1(pred(F2,N2,MaxChNo2,0,RulesForH2),Preds), attach(rule(RuleId,simpagation21,H2,ChNoH2,H1,ChNoH1,Guard,Body),RulesForH2), % try H2 before H1 $member1(pred(F1,N1,MaxChNo1,0,RulesForH1),Preds), %ChNoH: the number of the occurrence of H in its definition copy_term(Rule,RuleCP), RuleCP=rule(_,_,H1CP,H2CP,GuardCP,BodyCP), attach(rule(RuleId,simpagation,H1CP,ChNoH1,H2CP,ChNoH2,GuardCP,BodyCP),RulesForH1). register_into_preds_aux(Rule,Preds):- Rule=rule(RuleId,Type,H1,H2,Guard,Body) : functor(H1,F1,N1), functor(H2,F2,N2), $member1(pred(F1,N1,MaxChNo1,0,RulesForH1),Preds), % try H1 before H2 attach(rule(RuleId,Type,H1,ChNoH1,H2,ChNoH2,Guard,Body),RulesForH1), $member1(pred(F2,N2,MaxChNo2,0,RulesForH2),Preds), copy_term(Rule,RuleCP), RuleCP=rule(_,_,H1CP,H2CP,GuardCP,BodyCP), attach(rule(RuleId,Type,H2CP,ChNoH2,H1CP,ChNoH1,GuardCP,BodyCP),RulesForH2). /************************************************************/ % MaxChTable is a hashtable which tells the number of channels % for each predicate symbol % The tails of Preds and Rules are closed here as a side effect. compute_max_channels(Preds,MaxChTable):-var(Preds) : Preds=[]. compute_max_channels([pred(F,N,MaxChNo,_,Rules)|Preds],MaxChTable):-true : compute_max_channels('_$ttt$',Rules,0,0,MaxChNo), hashtable_put(MaxChTable,F/N,MaxChNo), compute_max_channels(Preds,MaxChTable). compute_max_channels(Prev,Rules,_OneNo,MaxChNo0,MaxChNo):-var(Rules) : Rules=[],MaxChNo0=MaxChNo. compute_max_channels(Prev,[Rule|Rules],OneNo0,MaxChNo0,MaxChNo):-true : Rule=rule(RuleId,Type,H1,ChNoH1,H2,ChNoH2,Guard,Body) : ( H2==$dummy %,Prev==$dummy -> MaxChNo1=MaxChNo0, OneNo1 is OneNo0 + 1, ChNoH1=OneNo1 ; MaxChNo1 is MaxChNo0+1, OneNo1 = OneNo0, ChNoH1=MaxChNo1 ), compute_max_channels(H2,Rules,OneNo1,MaxChNo1,MaxChNo). /************************************************************/ % Generate AR predicates for CHR predicates generate_code_preds([],AllPreds,TempPreds,MaxChTable):-true : true. generate_code_preds([pred(F,N,MaxChNo,SingleHeaded,Rules)|Preds],AllPreds,TempPreds,MaxChTable):- var(SingleHeaded) : generate_single_headed_pred(F,N,Rules), generate_code_preds(Preds,AllPreds,TempPreds,MaxChTable). generate_code_preds([pred(F,N,MaxChNo,SingleHeaded,Rules)|Preds],AllPreds,TempPreds,MaxChTable):-true : generate_double_headed_pred(F,N,MaxChNo,Rules,AllPreds,TempPreds,MaxChTable), generate_code_preds(Preds,AllPreds,TempPreds,MaxChTable). % For a predicate defined by only single-headed rules % p(X) Sep G1 | B1 % ... % p(X) Sep Gk | Bk % where Sep is <=> or ==>, the generated AR prorgam takes the following form % % p(X):-p(Flag,Prop1,Prop2,...,Propj,X). % % p(Flag,PropRi1,...,PropRik,X),var(Flag),{generated,ins(Flag),ins(X)} => % (G1->SS1,B1; % ... % Gk->SSk,Bk; % true). % p(Flag,PropR1,PropR2,...,PropRj,X) => true. % % where Propi denotes propagation history and SSi is Flag=1 if ri is a simplification rule and % PropRij=1 if it is a propagation rule. generate_single_headed_pred(F,N,Rules):- functor(Head,F,N),Head=..[_|Args], single_headed_rules_to_if_then_else(Head,Rules,_,Flag,PropFlags,Guards,IfThenElse), length(PropFlags,NumFlags), append([Flag|PropFlags],Args,BodyCallArgs), BodyCall=..[F|BodyCallArgs], DispatchClause=(Head:-BodyCall), my_portray_clause(DispatchClause), % c_VARS_SET_INTERSECT(Head,Guards,GuardVars), % vars in both Head and Guards vars_to_ins_patterns(GuardVars,InsPatterns), AR1=(BodyCall,var(Flag),{generated,ins(Flag),InsPatterns} => (IfThenElse)), my_portray_clause(AR1), % AR2=(BodyCall => true), my_portray_clause(AR2). single_headed_rules_to_if_then_else(Head,[Rule|Rules],RulesR,Flag,PropFlags,Guards,IfThenElse):- Rule=rule(RuleId,Type,H1,ChNo1,$dummy,ChNo2,Guard,Body) : % H2 is dummy H1=Head, % all rules share the same head (Type==propagation-> PropFlags=[PropFlag|PropFlagsR], IfThenElse=((var(PropFlag),Guard -> PropFlag=1,Body;true),IfThenElseR) ; PropFlags=PropFlagsR, IfThenElse=(Guard -> Flag=1,Body;IfThenElseR) ), Guards=[Guard|GuardsR], single_headed_rules_to_if_then_else(Head,Rules,RulesR,Flag,PropFlagsR,GuardsR,IfThenElseR). single_headed_rules_to_if_then_else(Head,Rules,RulesR,Flag,PropFlags,Guards,IfThenElse):-true: PropFlags=[], RulesR=Rules, Guards=[], IfThenElse=true. vars_to_ins_patterns([],InsPatterns):-true : InsPatterns=true. vars_to_ins_patterns([Var],InsPatterns):-true : InsPatterns=ins(Var). vars_to_ins_patterns([Var|Vars],InsPatterns):-true : InsPatterns=(ins(Var),InsPatternsR), vars_to_ins_patterns(Vars,InsPatternsR). % For a predicate defined by only double-headed rules % p(X),q1(Y1) Sep G1 | B1 % ... % p(X),qk(Yk) Sep Gk | Bk % % the following AR predicates are generated: % p(X):- % new_constr_num(ConstrNo), % Constr=p(ConstrNo,Flag,History,X) % Channels=chs(ChP1,...,ChPk) % get_channels(p,Channels), % % get_individual_channel(q1,r1,MaxChaQ1,ChQ1), % pr1(ConstrNo,ChQ1,Flag,History,X), % ... % get_individual_channel(qk,rk,MaxChaQk,ChQk), % prk(ConstrNo,ChQk,Flag,History,X), % % post_p(Flag,Constr,Channels,X). % % post_p(Flag,Constr,chs(ChP1,...,ChPk),X), % var(Flag), % {generated,ins(Flag),ins(X)}, % => % post_event(ChP1,Constr), % ... % post_event(ChPk,Constr). % post_p(Flag,Constr,Channels,X) => true. generate_double_headed_pred(F,N,MaxChNo,Rules,Preds,TempPreds,MaxChTable):- (hashtable_get(TempPreds,F,_)-> AllChannels = [Ch], TwoChannels = [Ch], OneChannels = [], MultiChannels = [] ; count_channels(Rules,AllChannels,TwoChannels,OneChannels,MultiChannels) ), f_n_str(F,N,FNStr), generate_dispatch_pred(F,N,FNStr,MaxChNo,AllChannels,TwoChannels,OneChannels,MultiChannels,Rules,Flag,TempPreds,MaxChTable), generate_double_headed_rules(FNStr,Preds,TempPreds,N,Rules,1,'_$ttt'). count_channels([],[],[],[],[]). count_channels([Rule|Rules],All,Two,One,Multi) :- Rule = rule(RuleId,temp_rule,H1,ChNo1,H2,ChNo2,CHRGuard,CHRBody) : All = [Ch,RelayCh|NAll], Two = [Ch|NTwo], Multi = [RelayCh|NMulti], One = NOne, count_channels(Rules,NAll,NTwo,NOne,NMulti). count_channels([Rule|Rules],All,Two,One,Multi) :- Rule = rule(RuleId,Type,H1,ChNo1,$dummy,ChNo2,CHRGuard,CHRBody) : All = [Ch|NAll], One = [Ch|NOne], Two = NTwo, Multi = NMulti, count_channels(Rules,NAll,NTwo,NOne,NMulti). count_channels([Rule|Rules],All,Two,One,Multi) :- Rule = rule(RuleId,Type,H1,ChNo1,H2,ChNo2,CHRGuard,CHRBody) : All = [Ch|NAll], One = NOne, Two = [Ch|NTwo], Multi = NMulti, count_channels(Rules,NAll,NTwo,NOne,NMulti). % A temporary predicate introduced in tranlating multi-headed rules into % double-headed ones carries its status variable. generate_dispatch_pred(F,N,FNStr,MaxChNo,AllChannels,TwoChannels,OneChannels,MultiChannels,Rules,Flag,TempPreds,MaxChTable):- % Main entry clause functor(Head,F,N), Head=..[_|HeadArgs], (hashtable_get(TempPreds,F,_)-> NHead=..[F,Flag|HeadArgs] ; NHead=Head ), append(MultiChannels,HeadArgs,EventTail), EventObj=..[F,ConstrNo,Flag,History|EventTail], atom_codes(FN,FNStr), ChRecord =.. [chs|AllChannels], % functor(ChRecord,chs,MaxChNo), ChRecord2 =.. [chs|TwoChannels], % functor(ChRecord2,chs,TwoChannels), ChRecord1 =.. [chs|OneChannels], % functor(ChRecord1,chs,OneChannels), ChRecordm =.. [chs|MultiChannels], % functor(ChRecord1,chs,OneChannels), Body= ( new_constr_num(ConstrNo), Constr = EventObj, PublicChannels = ChRecord2, PrivateChannels = ChRecord1, SyncChannels = ChRecordm, global_heap_get(FN,PublicChannels), Body1 ), Clause1=(NHead=>Body), generate_dispatch_calls(F,N,Head,FNStr,HeadArgs,ConstrNo,ChRecord1,ChRecord2,MultiChannels,Flag,History,Rules,MaxChTable,1,Body1,PostCall), atom_codes(PostF,[0'p,0'o,0's,0't,0'_|FNStr]), PostCall=..[PostF,Flag,Constr,PrivateChannels,PublicChannels,SyncChannels|HeadArgs], my_portray_clause(Clause1), % Head2=..[PostF,Flag,Constr,ChRecord1,ChRecord2,ChRecordm|HeadArgs], generate_post_events(AllChannels,Constr,Body2), (hashtable_get(TempPreds,F,_)-> ARRule1=(Head2,var(Flag),{generated,ins(Flag),event(Flag,_)} => Body2) ;MultiChannels \== [] -> vars_to_ins_patterns(HeadArgs,InsPatterns), ARRule1=(Head2,var(Flag),{generated,ins(Flag),InsPatterns} => Body2) ; collect_guards(Rules,Head,Guards), c_VARS_SET_INTERSECT(Head,Guards,GuardVars), % vars in both Head and Guards vars_to_ins_patterns(GuardVars,InsPatterns), ARRule1=(Head2,var(Flag),{generated,ins(Flag),InsPatterns} => Body2) ), my_portray_clause(ARRule1), ARRule2=(Head2 => true), my_portray_clause(ARRule2). collect_guards([],Head,Guards):-true : true. collect_guards([Rule|Rules],Head,Guards):- Rule=rule(RuleId,Type,H1,ChNo1,H2,ChNo2,Guard,Body) : Head=H1,Guards=[Guard|GuardsR], collect_guards(Rules,Head,GuardsR). generate_post_events([],_,Body):-true : Body = true. generate_post_events([Ch|Chs],Constr,Body):-true : Body=(post_event(Ch,Constr),BodyR), generate_post_events(Chs,Constr,BodyR). generate_dispatch_calls(F,N,Head,_FNStr,_HeadArgs,ConstrNo,_ChRecord1,_ChRecord2,_MultiChannels,_Flag,History,[],MaxChTable,_I,Calls,CallsR):-true : Calls=CallsR. generate_dispatch_calls(F,N,Head,FNStr,HeadArgs,ConstrNo,ChRecord1,ChRecord2,MultiChannels,Flag,History,[Rule|Rules],MaxChTable,I,Calls,CallsR):- Rule=rule(RuleId,Type,H1,ChNo1,H2,ChNo2,CHRGuard,CHRBody), new_predicate_symbol(FNStr,I,Fi), % new predicate generated from the Ith rule for F/N (H2==$dummy-> single_headed_rules_to_if_then_else(Head,[Rule|Rules],RulesRest,Flag,PropFlags,Guards,IfThenElse), length(PropFlags,NumFlags), arg(ChNo1,ChRecord1,Ch), append(PropFlags,HeadArgs,CallArgsRest), Call=..[Fi,Ch,Flag|CallArgsRest], DispatchClause=(Call,var(Flag),{ins(Flag),event(Ch)} => IfThenElse), my_portray_clause(DispatchClause), Calls=(Call,Calls1), DispatchClause2=(Call => true), my_portray_clause(DispatchClause2), NMultiChannels = MultiChannels ; functor(H2,F2,N2), ( Type == temp_rule, MultiChannels \== [] -> MultiChannels = [SyncChannel|NMultiChannels], Call=..[Fi,ConstrNo,ChQ,Flag,History,SyncChannel|HeadArgs] ; Call=..[Fi,ConstrNo,ChQ,Flag,History|HeadArgs] ), (F==F2,N==N2-> % no need to call get_channels if the partner pattern has the same symbol arg(ChNo2,ChRecord2,ChQ), Calls=(Call,Calls1) ; f_n_str(F2,N2,FNstr2), atom_codes(FN2,FNstr2), hashtable_get(MaxChTable,F2/N2,MaxChNo2), Calls=(get_individual_channel(FN2,ChNo2,MaxChNo2,ChQ),Call,Calls1) ), RulesRest=Rules ), I1 is I+1, generate_dispatch_calls(F,N,Head,FNStr,HeadArgs,ConstrNo,ChRecord1,ChRecord2,NMultiChannels,Flag,History,RulesRest,MaxChTable,I1,Calls1,CallsR). generate_double_headed_rules(_FNStr,_Preds,_TempPreds,_N,[],_I,PrevH2):-true : true. generate_double_headed_rules(FNStr,Preds,TempPreds,N,[Rule|Rules],I,PrevH2):- Rule=rule(RuleId,Type,H1,ChNo1,$dummy,ChNo2,CHRGuard,CHRBody) : (PrevH2==$dummy->I1 is I;I1 is I+1), generate_double_headed_rules(FNStr,Preds,TempPreds,N,Rules,I1,$dummy). generate_double_headed_rules(FNStr,Preds,TempPreds,N,[Rule|Rules],I,PrevH2):- Rule=rule(RuleId,Type,H1,ChNo1,H2,ChNo2,CHRGuard,CHRBody) : generate_double_headed_rule(FNStr,Preds,TempPreds,N,Rule,I), I1 is I+1, generate_double_headed_rules(FNStr,Preds,TempPreds,N,Rules,I1,H2). % For p(X),q(Y) ==> G | B. % % p_i(ConstrNo,Ch,Flag,History,X) % var(Flag), % {event(ChQ,Q),ins(Flag)} % => % Q=q_i(ConstrNoQ,FlagQ,HistoryQ,Y), % (var(FlagQ)-> % (not_in_history(ConstrNoQ,History),not_in_history(ConstrNo,HistoryQ),Gi-> % add_into_history(ConstrNoQ,History),add_into_history(ConstrNo,HistoryQ),Bi;true) % ;true). % p_i(ConstrNo,ChQ,Flag,History,X)=>true. generate_double_headed_rule(FNStr,Preds,TempPreds,N,Rule,I):- Rule=rule(RuleId,Type,H1,ChNo1,H2,ChNo2,CHRGuard,CHRBody) : new_predicate_symbol(FNStr,I,Fi), H1=..[F|Args], (Type == temp_rule, \+ hashtable_get(TempPreds,F,_)-> ARHead=..[Fi,ConstrNo,ChQ,Flag,History,RelayCh|Args] ; ARHead=..[Fi,ConstrNo,ChQ,Flag,History|Args] ), H2=..[F2|H2Args],functor(H2,_,N2), multi_sync_channels(Preds,TempPreds,F2,N2,RuleID,SyncChannels,RelayChQ), append(SyncChannels,H2Args,EventQTail), EventQ=..[F2,ConstrNoQ,FlagQ,HistoryQ|EventQTail], ARRule1=(ARHead,var(Flag),{event(ChQ,Q),ins(Flag)} => (Q=EventQ,(var(FlagQ),ConstrNo\==ConstrNoQ->ARBody;true))), (Type==simplification-> ARBody=(CHRGuard->Flag=1,FlagQ=1,CHRBody;true); Type==simpagation-> ARBody=(CHRGuard->FlagQ=1,CHRBody;true); Type==simpagation21-> ARBody=(CHRGuard->Flag=1,CHRBody;true) ; /* propagation or temp_rule */ (Type==temp_rule-> CHRBody=..[TempF|TempArgs], TempConstr=..[TempF,FlagPQ|TempArgs], ARBodyCalls= ( maintain_flags_pq(Flag,FlagQ,FlagPQ), relay_event(FlagPQ,RelayCh), relay_event(FlagPQ,RelayChQ), TempConstr ) ; ARBodyCalls=CHRBody ), (F==F2,N==N2->HisQ=(ConstrNoQ,I),His=(ConstrNo,I); % p,p' and p,p'' have different ids HisQ=(ConstrNoQ,RuleId),His=(ConstrNo,RuleId)), ARBody=(not_in_history(HisQ,History),not_in_history(His,HistoryQ),CHRGuard-> add_into_history(HisQ,History),add_into_history(His,HistoryQ),ARBodyCalls;true) ), my_portray_clause(ARRule1), ARRule2=(ARHead => true), my_portray_clause(ARRule2). multi_sync_channels(Preds,TempPreds,F,N,RuleID,SyncChannels,SyncChannel) :- ( hashtable_get(TempPreds,F,_) -> SyncChannels = [], SyncChannel = _ ; $member(pred(F,N,_MaxChNo,_SingleHeaded,Rules),Preds), multi_sync_channels(Rules,RuleID,SyncChannels,SyncChannel) ). multi_sync_channels([],_RuleID,[],_SyncChannel). multi_sync_channels([Rule|Rules],SyncRuleID,SyncChannels,SyncChannel) :- Rule = rule(RuleId,Type,_,_,_,_,_,_), ( Type = temp_rule -> SyncChannels = [Ch|NSyncChannels], ( RuleId = SyncRuleID -> SyncChannel = Ch ; true ) ; SyncChannels = NSyncChannels ), multi_sync_channels(Rules,SyncRuleID,NSyncChannels,SyncChannel). /************************************************************/ %% UTILITIES check_chr_file(File,File1):- atom(File), plus_ext(File,chr,File2), % in B-Prolog exists(File2),!, File1=File2. check_chr_file(File,File1):- atom(File), exists(File),!, File1=File. check_chr_file(File,File1):- handle_exception(file_not_found,chr2ar(File)). % create a new predicate symbol new_temp_pred_symbol(NewF):- global_get($temp_pred_num,N), number_codes(N,NStr), append("$temp_",NStr,NewFStr), atom_codes(NewF,NewFStr), N1 is N+1, global_set($temp_pred_num,N1). extract_chr_guard_body((G | B),Guard,Body):-!, Guard=G, Body=B. extract_chr_guard_body(B,Guard,Body):-Guard=true,Body=B. % change X=Y to X?=Y,X=Y reform_guard((G1,G2),NewG):-true : NewG=(NewG1,NewG2), reform_guard(G1,NewG1), reform_guard(G2,NewG2). reform_guard(X=Y,NewG):-true : (var(X),var(Y)-> NewG=(X==Y); NewG=(X?=Y,X=Y)). reform_guard(G,NewG):-true : NewG=G. % merge Tests with Guard to form a new guard merge_guard_tests(Guard,[],NGuard):-true :NGuard=Guard. merge_guard_tests(Guard,[T|Ts],NGuard):-true : NGuard=(T,NGuard1), merge_guard_tests(Guard,Ts,NGuard1). f_n_str(F,N,FNStr):- atom_codes(F,FStr), number_codes(N,NStr), append(FStr,[0'_|NStr],FNStr). % make a new predicate name with the prefix Pre new_predicate_symbol(PrefixStr,I,NewPredSym):- number_codes(I,IStr), append(PrefixStr,[0'_|IStr],PredStr), atom_codes(NewPredSym,PredStr). % to run SWI CHR programs % ignore module declarations use_module(X). use_module(X,Y). chr_option(_,_). % ignore constraint declarations constraint(X). chr_constraint(X). chr_constraints(X). constraints(X). % P,Q ==> PQ % Maintain the statuses of newly introduced constraint and its original constraints % When both P and Q are removed, so is PQ % When PQ is removed, both P and Q are removed. maintain_flags_pq(FlagP,FlagQ,FlagPQ),n_vars_gt(3,2), % two of the three are variables {ins(FlagP),ins(FlagQ),ins(FlagPQ)} => true. maintain_flags_pq(FlagP,FlagQ,FlagPQ), FlagP==1,FlagQ==1 => FlagPQ=1. maintain_flags_pq(FlagP,FlagQ,FlagPQ) => FlagP=1,FlagP=1. relay_event(Ch,Ch1), var(Ch), {ins(Ch), event(Ch1,Event)} => post_event(Ch,Event). relay_event(_,_) => true. % make a copy of Term, switching vars in H1 with vars in H2 substitute_switch_vars(Term,TermCP,H1,H2,Arity):-var(Term),!, switch_var(Term,TermCP,H1,H2,Arity). substitute_switch_vars(Term,TermCP,H1,H2,Arity):-atomic(Term),!,TermCP=Term. substitute_switch_vars(Term,TermCP,H1,H2,Arity):- functor(Term,F,N), functor(TermCP,F,N), substitute_switch_vars(N,Term,TermCP,H1,H2,Arity). substitute_switch_vars(I,Term,TermCP,H1,H2,Arity):-I=:=0,!. substitute_switch_vars(I,Term,TermCP,H1,H2,Arity):- arg(I,Term,Arg), substitute_switch_vars(Arg,ArgCP,H1,H2,Arity), arg(I,TermCP,ArgCP), I1 is I-1, substitute_switch_vars(I1,Term,TermCP,H1,H2,Arity). switch_var(Var,VarCP,H1,H2,I):-I=:=0,!,VarCP=Var. switch_var(Var,VarCP,H1,H2,I):- arg(I,H1,Arg1), Var==Arg1,!, arg(I,H2,VarCP). switch_var(Var,VarCP,H1,H2,I):- arg(I,H2,Arg2), Var==Arg2,!, arg(I,H1,VarCP). switch_var(Var,VarCP,H1,H2,I):- I1 is I-1, switch_var(Var,VarCP,H1,H2,I1). alive_agents([],AliveL):-AliveL=L. alive_agents([A|As],AliveL):- (A=..[F,_,Flag|_],var(Flag) -> AliveL=[A|AliveL1];AliveL=AliveL1), alive_agents(As,AliveL1). my_portray_clause(Cl):- not(not((copy_term(Cl,ClCP), portray_clause(ClCP)))),nl. %------------------------------------------------------------ % File : chr_lib.pl % Author : Neng-Fa ZHOU % Date : April 2006 % Purpose: A library of predicates needed to run CHR programs % translated into Action Rules. %------------------------------------------------------------ /************************************************************************************************* Get the communication channels for a constraint having the name ConstrName and the term Term. ConstrName and Term are used as the key of a mapping table. All constraints with the same name and the same term share the same channels. If Term is a variable, channels are attached to the variable as attributes. Otherwise, the mapping table is stored in the global heap variable named ConstrName and linear search is used to find the channels for Term. **************************************************************************************************/ get_channels(ConstrName,Channels):- global_heap_get(ConstrName,Channels). get_channel(ConstrName,Term,Channels):- get_channels(ConstrName,Term,Channels). get_channels(ConstrName,Term,Channels):- get_attr(Term,$channels,NameVarChannels), NameVarChannels\==[],!, lookup_register_channels(ConstrName,Term,NameVarChannels,Channels). get_channels(ConstrName,Term,Channels):- var(Term),!, NameVarChannels=[channels(ConstrName,Term,Channels)|_], put_attr_no_hook(Term,$channels,NameVarChannels). get_channels(ConstrName,Term,Channels):-true : (ground(Term)-> global_heap_get((ConstrName,Term),Channels); global_heap_get(ConstrName,NameVarChannels), lookup_register_channels(ConstrName,Term,NameVarChannels,Channels)). /* linear search */ lookup_register_channels(ConstrName,Term,NameVarChannels,Channels):-var(NameVarChannels) : NameVarChannels=[channels(ConstrName,Term,Channels)|_]. lookup_register_channels(ConstrName,Term,[channels(ConstrName,Term,Channels)|_],Channels1):-true : Channels1=Channels. lookup_register_channels(ConstrName,Term,[_|NameVarChannels],Channels):-true : lookup_register_channels(ConstrName,Term,NameVarChannels,Channels). /*********************************************************************/ new_constr_num(NewN):- global_heap_get($constr_num,N), (var(N)->N=0;true), NewN is N+1, global_heap_set($constr_num,NewN). get_individual_channel(Name,ChNo,MaxChNo,Ch):- global_heap_get(Name,ChRecord), (var(ChRecord)->functor(ChRecord,chs,MaxChNo);true), arg(ChNo,ChRecord,Ch). not_in_history(ConstrNo,History):-var(History) : true. not_in_history(ConstrNo,History):-hashtable_get(History,ConstrNo,_) : fail. not_in_history(ConstrNo,History):-true : true. add_into_history(ConstrNo,History):- (var(History)-> new_hashtable(History); true), hashtable_put(History,ConstrNo,1).