%------------------------------------------------------------
% 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(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).