diogo/yap-6.3
Archived
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

B-Prolog suppoty.

Browse Source
This commit is contained in:
Vítor Santos Costa 2011-10-24 22:47:42 +01:00
parent 384ddd84ad
commit 73dd81478f
6 changed files with 1451 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
library/dialect/bprolog.yap Normal file
View File

@ -0,0 +1,7 @@
:- ensure_loaded(bprolog/arrays).
:- ensure_loaded(bprolog/hashtable).
%:- ensure_loaded(bprolog/actionrules).
:- ensure_loaded(bprolog/foreach).
%:- ensure_loaded(bprolog/compile_foreach).

440
library/dialect/bprolog/actionrules.pl Normal file
View File

@ -0,0 +1,440 @@
/*
Author: Bart Demoen, Phuong-Lan Nguyen
E-mail: Bart.Demoen@cs.kuleuven.be, nguyen@uco.fr
WWW: http://www.swi-prolog.org
Copyright (C): 2006, K.U. Leuven
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
/* What is this module for ... see bottom of the file */
:- module(actionrules,[op(1200,xfx,=>),
op(1200,xfx,?=>),
op(1000,xfy,:::),
post/1,
post_event/2,
post_event_df/2,
post_event_df/3,
register_event/2
]).
:- use_module(library(lists)).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% the built-ins and the preds needed in the transformation %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
register_event(event(X,_),G) :- add_attr(X,'$$event',G).
register_event(ins(X),G) :- add_attr(X,'$$ins',G).
register_event(generated,_). % ignore
add_attr(X,Mod,A) :-
(get_attr(X,Mod,Old) ->
New = [A|Old]
;
New = [A]
),
put_attr(X,Mod,New).
post(event(X,Mes)) :- !,
(get_attr(X,'$$event',Gs) ->
activate_agents_rev(Gs,Mes)
;
(var(X) ->
true
;
throw(actionrule(event/2,illegalfirstargument))
)
).
post(ins(X)) :- !,
(get_attr(X,'$$ins',Gs) ->
call_list_rev(Gs)
;
(var(X) ->
true
;
throw(actionrule(ins/1,illegalfirstargument))
)
).
post(Event) :-
throw(actionrule(Event,illegalpost)).
post_event(X,Mes) :-
get_attr(X,'$$event',Gs), !, activate_agents_rev(Gs,Mes).
post_event(X,_) :-
(var(X) ->
true
;
throw(actionrule(post_event/2,illegalfirstargument))
).
post_event_df(X,Mes) :-
get_attr(X,'$$event',Gs), !, activate_agents1(Gs,Mes).
post_event_df(_,_).
post_event_df(X,Alive,Mes) :-
get_attr(X,'$$event',Gs), !, activate_agents(Gs,Alive,Mes).
post_event_df(_,_,_).
'$$ins':attr_unify_hook(AttrX,Y) :-
(var(Y) ->
(get_attr(Y,'$$ins',AttrY) ->
append(AttrX,AttrY,NewAttr)
;
NewAttr = AttrX
),
put_attr(Y,ins,NewAttr)
;
true
),
call_list_rev(AttrX).
'$$event':attr_unify_hook(_,_).
call_list_rev(Goals) :-
reverse(Goals,Gs),
call_list(Gs).
call_list([]).
call_list([G|Gs]) :-
call(G),
call_list(Gs).
activate_agents_rev(Goals,M) :-
reverse(Goals,Gs),
activate_agents(Gs,M).
activate_agents([],_).
activate_agents([G|Gs],Mes) :-
G =.. [N,_|R],
NewG =.. [N,Mes|R],
call(NewG),
activate_agents(Gs,Mes).
activate_agents([],_,_).
activate_agents([G|Gs],Alive,Mes) :-
(var(Alive) ->
G =.. [N,_|R],
NewG =.. [N,Mes|R],
call(NewG),
activate_agents(Gs,Alive,Mes)
;
true
).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% ar_translate and helper predicates %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
ars2p(ARs,Det,Head,Program,Errors,TailProgram,TailErrors) :-
copyskel(Head,Skel),
cleanheads(ARs,NewARs,Skel),
Skel =.. [N|Args],
makeagentname(N,AgentName),
NewSkel =.. [AgentName,Mes,Alive|Args],
findmess(NewARs,Mes),
genfirstclause(NewARs,Det,NewSkel,Skel,Program,Errors,TailProgram1,TailErrors1),
gensecondclause(NewARs,Det,NewSkel,Alive,TailProgram1,TailErrors1,TailProgram,TailErrors).
genfirstclause(NewARs,Det,NewSkel,Skel,Program,Errors,TailProgram,TailErrors) :-
Clause = (Skel :- (Closure = NewSkel), Body),
makefirstbody(NewARs,Det,Closure,Body,Errors,TailErrors),
Program = [Clause | TailProgram].
build_conditional(det, Guard, B, (Guard -> B)).
build_conditional(nondet, Guard, B, (Guard, B)).
makefirstbody([ar(Head,Guard,Events,B)|R],Det,Closure,Bodys,Errors,TailErrors) :-
(Events == [] ->
build_conditional(Det, Guard, B, Body),
Errors = Errors1
;
check_events(Events,Head,Errors,Errors1),
mkregistergoals(Events,Register,Closure),
(member(generated,Events) ->
build_conditional(Det, Guard, (Register,B), Body)
;
build_conditional(Det, Guard, Register, Body)
)
),
(R == [] ->
Bodys = Body,
Errors1 = TailErrors
;
Bodys = (Body ; MoreBody),
makefirstbody(R,Det,Closure,MoreBody,Errors1,TailErrors)
).
gensecondclause(NewARs,Det,NewSkel,Alive,Program,Errors,TailProgram,Errors) :-
Clause = (NewSkel :- (var(Alive) -> Body ; true)),
makesecondbody(NewARs,Det,NewSkel,Body,Alive),
Program = [Clause | TailProgram].
makesecondbody([ar(_,Guard,Events,B)|R],Det,NewSkel,Bodys,Alive) :-
(Events == [] ->
build_conditional(Det, Guard, (Alive = no, B), Body)
;
build_conditional(Det, Guard, B, Body)
),
(R == [] ->
Bodys = Body
;
Bodys = (Body ; MoreBody),
makesecondbody(R,Det,NewSkel,MoreBody,Alive)
).
check_events([],_,E,E).
check_events([Event|R],S,E,TailE) :-
(nonvar(Event), okevent(Event) ->
E = E1
;
E = [illegalevent(Event,S)|E1]
),
check_events(R,S,E1,TailE).
okevent(ins(X)) :- !, var(X).
okevent(event(X,M)) :- !, var(X), var(M).
okevent(generated).
findmess([],_).
findmess([ar(_,_,Events,_)|R],Mes) :-
findmess2(Events,Mes),
findmess(R,Mes).
findmess2([],_).
findmess2([A|R],Mes) :-
(A = event(_,Mes) ->
true
;
true
),
findmess2(R,Mes).
copyskel(T1,T2) :-
functor(T1,N,A),
functor(T2,N,A).
cleanheads([],[],_).
cleanheads([ar(Head,Conds,Events,Body)|R],[ar(NewHead,NewConds,Events,Body)|S],Skel) :-
makenewhead(Head,NewHead,Unies),
Skel = NewHead,
append(Unies,Conds,LNewConds),
conds_to_goals(LNewConds, NewConds0),
removetrue(NewConds0, NewConds),
cleanheads(R,S,Skel).
conds_to_goals([], true) :- !.
conds_to_goals(C.LNewConds, (C,NewConds0)) :- !,
conds_to_goals(LNewConds, NewConds0).
conds_to_goals(C,C).
makenewhead(Head,NewHead,Unies) :-
Head =.. [_|Args],
functor(Head,N,A),
functor(NewHead,N,A),
NewHead =.. [_|NewArgs],
makeunies(Args,NewArgs,Unies).
makeunies([],_,[]).
makeunies([X|R],[Y|S],Us) :-
(var(X) ->
X = Y,
Us = Us2
;
Us = [X=Y|Us2] % this should be matching instead of unification
),
makeunies(R,S,Us2).
get_arinfo(AR,ARInfo,Head) :-
AR = (Something => Body),
(Something = (Head,Rest) ->
findcondevents(Rest,Conds,Events)
;
Something = Head, Conds = true, Events = []
),
ARInfo = ar(Head,Conds,Events,Body).
get_arinfo(AR,ARInfo,Head) :-
AR = (Something ?=> Body),
(Something = (Head,Rest) ->
findcondevents(Rest,Conds,Events)
;
Something = Head, Conds = true, Events = []
),
ARInfo = ar(Head,Conds,Events,Body).
get_arinfo(AR,ARInfo,Head) :-
AR = (Head :- Rest ::: Body),
Conds = Rest, Events = [],
ARInfo = ar(Head,Conds,Events,Body).
findcondevents((A,B),(A,As),Ts) :- !,
findcondevents(B,As,Ts).
findcondevents({Trs},true,Ts) :- !,
makeevents(Trs,Ts).
findcondevents(A,A,[]).
makeevents((A,B),[A|R]) :- !, makeevents(B,R).
makeevents(A,[A]).
samehead(A,B) :-
functor(A,X,Y),
functor(B,X,Y).
makeagentname(N,Out) :-
name(N,NL),
name('$$suspended_',A),
append(A,NL,ANL),
name(Out,ANL).
mkregistergoals([],true,_).
mkregistergoals([X|R],Register,Skel) :-
(X == generated ->
mkregistergoals(R,Register,Skel)
;
Register = (register_event(X,Skel),S),
mkregistergoals(R,S,Skel)
).
removetrue(true,true) :- !.
removetrue((true,A),AA) :- !, removetrue(A,AA).
removetrue((A,true),AA) :- !, removetrue(A,AA).
removetrue((A,B),(AA,BB)) :- !, removetrue(A,AA), removetrue(B,BB).
removetrue((A->B),(AA->BB)) :- !, removetrue(A,AA), removetrue(B,BB).
removetrue((A;B),(AA;BB)) :- !, removetrue(A,AA), removetrue(B,BB).
removetrue(X,X).
ar_translate([],_,[],[]).
ar_translate([AR|ARs],Module,Program,Errors) :-
get_head(AR,ARHead),
collect_ars_same_head(ARs,ARHead,ActionPredRest,RestARs),
ars2p([AR|ActionPredRest],det,ARHead,Program,Errors,TailProgram,TailErrors),
ar_translate(RestARs,Module,TailProgram,TailErrors).
nondet_ar_translate([],_,Program,Program,[]).
nondet_ar_translate([AR|ARs],Module,Program,EndProgram,Errors) :-
get_head(AR,ARHead),
collect_ars_same_head(ARs,ARHead,ActionPredRest,RestARs),
ars2p([AR|ActionPredRest],nondet,ARHead,Program,Errors,TailProgram,TailErrors),
nondet_ar_translate(RestARs,Module,TailProgram, EndProgram,TailErrors).
collect_ars_same_head([],_,[],[]).
collect_ars_same_head([AR1|ARs],Head,SameHeadARs,RestARs) :-
get_head(AR1,Head1),
(same_head(Head1,Head) ->
SameHeadARs = [AR1|SameHeadARsRest],
collect_ars_same_head(ARs,Head,SameHeadARsRest,RestARs)
;
RestARs = [AR1|RestARsRest],
collect_ars_same_head(ARs,Head,SameHeadARs,RestARsRest)
).
get_head(ar(Head,_Conds,_Events,_Body),Head).
same_head(T1,T2) :-
functor(T1,N,A),
functor(T2,N,A).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
ar_expand(Term, []) :-
Term = (_ => _), !,
prolog_load_context(file,File),
get_arinfo(Term,ARInfo,_),
assert(ar_term(File,ARInfo)).
ar_expand(Term, []) :-
Term = (_ :- _ ::: _), !,
prolog_load_context(file,File),
get_arinfo(Term,ARInfo,_),
assert(ar_term(File,ARInfo)).
ar_expand(Term, []) :-
Term = (_ ?=> _ ), !,
prolog_load_context(file,File),
get_arinfo(Term,ARInfo,_),
assert(nondet_ar_term(File,ARInfo)).
ar_expand(end_of_file, FinalProgram) :-
prolog_load_context(file,File),
compile_ar(File, DetProgram),
compile_nondet_ar(File, FinalProgram, DetProgram).
compile_ar(File, FinalProgram) :-
findall(T, retract(ar_term(File,T)), ARs),
ARs \== [],
prolog_load_context(module, Module),
ar_translate(ARs, Module, FinalProgram, Errors),
!, % just to make sure there are no choice points left
(Errors == [] ->
true
;
report_errors(Errors)
).
compile_nondet_ar(File, FinalProgram, StartProgram) :-
findall(T, retract(nondet_ar_term(File,T)), ARs),
ARs \== [],
prolog_load_context(module, Module),
nondet_ar_translate(ARs, Module, FinalProgram, StartProgram, Errors),
!, % just to make sure there are no choice points left
(Errors == [] ->
true
;
report_errors(Errors)
).
report_errors(Errors) :- throw(action_rule_error(Errors)). % for now
/*******************************
* MUST BE LAST! *
*******************************/
:- multifile user:term_expansion/2.
:- dynamic user:term_expansion/2.
user:term_expansion(In, Out) :-
ar_expand(In, Out).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% What this file is for .... %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
/*
Action Rules were defined and implemented first in the context of
B-Prolog and the TOAM by Neng-Fa Zhou - see http://www.probp.com/
See http://www.cs.kuleuven.be/publicaties/rapporten/cw/CW456.abs.html
for an explanation what this file is based on.
Use_module-ing this file will give you an implementation of Action Rules
functionality related to the event patterns ins/1, generated/0 and
event/2.
It is not a fast implementation in SWI-Prolog, because there isn't any
low-level support.
If you need more functionality, please contact the authors.
*/

35
library/dialect/bprolog/arrays.yap Normal file
View File

@ -0,0 +1,35 @@
:- module(bparrays, [new_array/2, a2_new/3, a3_new/4. is_array/1, '$aget'/3]).
:- use_module(library(lists), [flatten/2]).
new_array(X, Dim.Dims) :-
functor(X, '[]', Dim),
recurse_new_array(0, Dim, Dims, X).
recurse_new_array(_, _, [], _X) :- !.
recurse_new_array(Dim, Dim, _Dims, _X) :- !.
recurse_new_array(I0, Dim, Dims, X) :-
I is I0+1,
arg(I, X, A),
new_array(A, Dims),
recurse_new_array(0, Dim, Dims, X).
a2_new(X, Dim1, Dim2) :-
functor(X, '[]', Dim1),
recurse_new_array(0, Dim1, [Dim2], X).
a2_new(X, Dim1, Dim2, Dim3) :-
functor(X, '.', Dim1),
recurse_new_array(0, Dim1, [Dim2,Dim3], X).
is_array(X) :-
functor(X, '[]', _Dim).
'$aget'(A,[],A).
'$aget'(A,I.Is,A) :-
arg(I, A, X),
'$aget'(X,Is,A).
array_to_list(A, List) :-
flatten(A, List).

514
library/dialect/bprolog/compile_foreach.pl Normal file
View File

@ -0,0 +1,514 @@
s% File : compile_foreach.pl
% Author : Neng-Fa Zhou
% Updated: June 2009, updated Dec. 2009, updated Sep. 2010
% Purpose: compile away foreach
/* compile_foreach(Cls,NCls): NCls is a list of clauses obtained by
compiling away foreach calls in Cls. The new predicate introduced
for a foreach is named p_#_i where p is the name of the predicate
in which the foreach occurs and i is a unique integer.
*/
:- yap_flag(unknown,error).
:- ensure_loaded(actionrules).
:- op(560,xfx,[..,to,downto]).
:- op(700,xfx,[subset,notin,in,@=]).
/*
test:-
Cl1=(test1(L):-foreach(I in L, write(I))),
Cl2=(test2(L):-foreach(I in L, ac(S,0), S^1 is S^0+I)),
Cl3=(test3(T):-functor(T,_,N),foreach(I in 1..N, [Ti],ac(S,0), (arg(I,T,Ti),S^1 is S^0+Ti))),
Cl4=(test4(L):-foreach(I in L, ac1(C,[]), C^0=[I|C^1])),
Cl5=(test5:-foreach(I in [1,2], J in [a,b], ac(L,[]),L^1=[(I,J)|L^0]),writeln(L),fail),
Cl6=(test6:-foreach(I in [1,2], J in [a,b], ac1(L,[]),L^0=[(I,J)|L^1]),writeln(L),fail),
Cl7=(test7(L1,L2):-foreach(X in L1, (write(X),foreach(Y in L2, writeln((X,Y)))))),
Cl8=(p(D1,D3,IN,OUT):-
foreach(E in D3,
[INi,OUTi],
(asp_lib_clone_rel(IN,OUT,INi,OUTi),
(foreach(X in D1, Y in D1,(not diagY(X,Y,E)->asp_lib_add_tuples(OUTi,X,Y);true)),
asp_lib_card_unique(2,INi,OUTi))))),
compile_foreach([Cl1,Cl2,Cl3,Cl4,Cl5,Cl6,Cl7,Cl8],NCls),
(member(NCl,NCls), portray_clause(NCl),fail;true).
*/
compile_foreach(File):-
$getclauses_read_file(File,'$t.t.t$',0,_Singleton,_Redef,Cls,[]),
compile_foreach(Cls,NCls),
foreach(NCl in NCls, portray_clause(NCl)).
compile_foreach(Cls,NCls):-
new_hashtable(ProgTab),
compile_foreach(Cls,NCls,NCls1,ProgTab,0),
hashtable_values_to_list(ProgTab,Prog),
retrieve_new_cls(Prog,NCls1).
retrieve_new_cls([],[]).
retrieve_new_cls([pred(_,_,_,_,_,Cls)|Preds],NCls):-
append_diff(Cls,NCls,NCls1),
retrieve_new_cls(Preds,NCls1).
compile_foreach([],NCls,NClsR,_ProgTab,_DumNo) => NCls=NClsR.
compile_foreach([Cl|Cls],NCls,NClsR,ProgTab,DumNo) =>
NCls=[NCl|NCls1],
expand_constr(Cl,NCl,ProgTab,DumNo,DumNo1),
compile_foreach(Cls,NCls1,NClsR,ProgTab,DumNo1).
cl_contains_foreach((delay (_H:-(_G : B)))) =>
goal_contains_foreach(B,Flag),nonvar(Flag).
cl_contains_foreach((_H:-_G : B)) =>
goal_contains_foreach(B,Flag),nonvar(Flag).
cl_contains_foreach((_H:-_G ? B)) =>
goal_contains_foreach(B,Flag),nonvar(Flag).
cl_contains_foreach((_H:-B)) =>
goal_contains_foreach(B,Flag),nonvar(Flag).
goal_contains_foreach(G):-
goal_contains_foreach(G,Flag),
nonvar(Flag).
goal_contains_foreach(_G,Flag), nonvar(Flag) => true.
goal_contains_foreach(G,_Flag), var(G) => true.
goal_contains_foreach((_G : B),Flag) =>
goal_contains_foreach(B,Flag).
goal_contains_foreach((_G ? B),Flag) =>
goal_contains_foreach(B,Flag).
goal_contains_foreach((A,B),Flag) =>
goal_contains_foreach(A,Flag),
goal_contains_foreach(B,Flag).
goal_contains_foreach((A -> B ; C),Flag) =>
goal_contains_foreach(A,Flag),
goal_contains_foreach(B,Flag),
goal_contains_foreach(C,Flag).
goal_contains_foreach((A;B),Flag) =>
goal_contains_foreach(A,Flag),
goal_contains_foreach(B,Flag).
goal_contains_foreach(not(A),Flag) =>
goal_contains_foreach(A,Flag).
goal_contains_foreach(\+(A),Flag) =>
goal_contains_foreach(A,Flag).
goal_contains_foreach(Lhs @= Rhs,Flag) =>
exp_contains_list_comp(Lhs,Flag),
exp_contains_list_comp(Rhs,Flag).
goal_contains_foreach(E1#=E2,Flag) =>
exp_contains_list_comp(E1,Flag),
exp_contains_list_comp(E2,Flag).
goal_contains_foreach(E1#\=E2,Flag) =>
exp_contains_list_comp(E1,Flag),
exp_contains_list_comp(E2,Flag).
goal_contains_foreach(E1#<E2,Flag) =>
exp_contains_list_comp(E1,Flag),
exp_contains_list_comp(E2,Flag).
goal_contains_foreach(E1#=<E2,Flag) =>
exp_contains_list_comp(E1,Flag),
exp_contains_list_comp(E2,Flag).
goal_contains_foreach(E1#>E2,Flag) =>
exp_contains_list_comp(E1,Flag),
exp_contains_list_comp(E2,Flag).
goal_contains_foreach(E1#>=E2,Flag) =>
exp_contains_list_comp(E1,Flag),
exp_contains_list_comp(E2,Flag).
goal_contains_foreach(G,Flag), functor(G,foreach,_) => Flag=1.
goal_contains_foreach(_G,_Flag) => true.
exp_contains_list_comp(_,Flag), nonvar(Flag) => true.
exp_contains_list_comp([(_ : _)|_],Flag) => Flag=1.
exp_contains_list_comp(E1+E2,Flag) =>
exp_contains_list_comp(E1,Flag),
exp_contains_list_comp(E2,Flag).
exp_contains_list_comp(E1-E2,Flag) =>
exp_contains_list_comp(E1,Flag),
exp_contains_list_comp(E2,Flag).
exp_contains_list_comp(E1*E2,Flag) =>
exp_contains_list_comp(E1,Flag),
exp_contains_list_comp(E2,Flag).
exp_contains_list_comp(E1/E2,Flag) =>
exp_contains_list_comp(E1,Flag),
exp_contains_list_comp(E2,Flag).
exp_contains_list_comp(E1//E2,Flag) =>
exp_contains_list_comp(E1,Flag),
exp_contains_list_comp(E2,Flag).
exp_contains_list_comp(-E,Flag) =>
exp_contains_list_comp(E,Flag).
exp_contains_list_comp(abs(E),Flag) =>
exp_contains_list_comp(E,Flag).
exp_contains_list_comp(sum([(_ : _)|_]),Flag) => Flag=1.
exp_contains_list_comp(min([(_ : _)|_]),Flag) => Flag=1.
exp_contains_list_comp(max([(_ : _)|_]),Flag) => Flag=1.
exp_contains_list_comp(_,_) => true.
%%
$change_list_comprehension_to_foreach_cmptime(T,I,Is,CallForeach,L):-
$retrieve_list_comp_lvars_goal_cmptime(Is,LocalVars1,Goal1,Is1),
(nonvar(T),T=_^_-> % array access
LocalVars=[TempVar|LocalVars1],
(Goal1==true->
Goal=(TempVar@=T,L^0=[TempVar|L^1])
;
Goal=(Goal1->(TempVar@=T,L^0=[TempVar|L^1]);L^0=L^1)
)
;
LocalVars=LocalVars1,
(Goal1==true->
Goal=(L^0=[T|L^1])
;
Goal=(Goal1->L^0=[T|L^1];L^0=L^1)
)
),
append(Is1,[LocalVars,ac1(L,[]),Goal],Is2),
CallForeach=..[foreach,I|Is2].
$retrieve_list_comp_lvars_goal_cmptime([],LocalVars,Goal,Is) =>
LocalVars=[],Goal=true,Is=[].
$retrieve_list_comp_lvars_goal_cmptime([E|Es],LocalVars,Goal,Is),E = (_ in _) =>
Is=[E|IsR],
$retrieve_list_comp_lvars_goal_cmptime(Es,LocalVars,Goal,IsR).
$retrieve_list_comp_lvars_goal_cmptime([LVars,G],LocalVars,Goal,Is),LVars=[] =>
Is=[],LocalVars=LVars,G=Goal.
$retrieve_list_comp_lvars_goal_cmptime([LVars,G],LocalVars,Goal,Is),LVars=[_|_] =>
Is=[],LocalVars=LVars,G=Goal.
$retrieve_list_comp_lvars_goal_cmptime([LVars],LocalVars,Goal,Is),LVars=[_|_] =>
Is=[],LocalVars=LVars,Goal=true.
$retrieve_list_comp_lvars_goal_cmptime([LVars],LocalVars,Goal,Is),LVars=[] =>
Is=[],LocalVars=LVars,Goal=true.
$retrieve_list_comp_lvars_goal_cmptime([G],LocalVars,Goal,Is),nonvar(G) =>
Is=[],LocalVars=[],G=Goal.
%%
extract_list_comprehension_array_notation(T,NT,TempCalls,TempCallsR), var(T) =>
NT=T,TempCalls=TempCallsR.
extract_list_comprehension_array_notation(T,NT,TempCalls,TempCallsR), T=(_^_) =>
TempCalls=[NT @= T|TempCallsR].
extract_list_comprehension_array_notation(sum(T),NT,TempCalls,TempCallsR), T=[(_ : _)|_] =>
NT=sum(L),
TempCalls=[L @= T|TempCallsR].
extract_list_comprehension_array_notation(min(T),NT,TempCalls,TempCallsR), T=[(_ : _)|_] =>
NT=min(L),
TempCalls=[L @= T|TempCallsR].
extract_list_comprehension_array_notation(max(T),NT,TempCalls,TempCallsR), T=[(_ : _)|_] =>
NT=max(L),
TempCalls=[L @= T|TempCallsR].
extract_list_comprehension_array_notation(X+Y,NT,TempCalls,TempCallsR) =>
NT=(NX+NY),
extract_list_comprehension_array_notation(X,NX,TempCalls,TempCalls1),
extract_list_comprehension_array_notation(Y,NY,TempCalls1,TempCallsR).
extract_list_comprehension_array_notation(X-Y,NT,TempCalls,TempCallsR) =>
NT=(NX-NY),
extract_list_comprehension_array_notation(X,NX,TempCalls,TempCalls1),
extract_list_comprehension_array_notation(Y,NY,TempCalls1,TempCallsR).
extract_list_comprehension_array_notation(X*Y,NT,TempCalls,TempCallsR) =>
NT=(NX*NY),
extract_list_comprehension_array_notation(X,NX,TempCalls,TempCalls1),
extract_list_comprehension_array_notation(Y,NY,TempCalls1,TempCallsR).
extract_list_comprehension_array_notation(X//Y,NT,TempCalls,TempCallsR) =>
NT=(NX//NY),
extract_list_comprehension_array_notation(X,NX,TempCalls,TempCalls1),
extract_list_comprehension_array_notation(Y,NY,TempCalls1,TempCallsR).
extract_list_comprehension_array_notation(X/Y,NT,TempCalls,TempCallsR) =>
NT=(NX/NY),
extract_list_comprehension_array_notation(X,NX,TempCalls,TempCalls1),
extract_list_comprehension_array_notation(Y,NY,TempCalls1,TempCallsR).
extract_list_comprehension_array_notation(abs(X),NT,TempCalls,TempCallsR) =>
NT=abs(NX),
extract_list_comprehension_array_notation(X,NX,TempCalls,TempCallsR).
extract_list_comprehension_array_notation(T,NT,TempCalls,TempCallsR) =>
NT=T,TempCalls=TempCallsR.
compile_foreach_goal(G,NG,PrefixName,ProgTab,DumNo,DumNoR):-
functor(G,_,Arity),
(compile_foreach_retrieve_iterators(G,1,Arity,Is,ACs,LocalVars,Goal)->
compile_foreach(Is,LocalVars,ACs,Goal,NG,PrefixName,ProgTab,DumNo,DumNoR)
;
NG=G,DumNo=DumNoR % interpreted
).
compile_foreach(Iterators,LocalVars,ACs,G,NG,PrefixName,ProgTab,DumNo,DumNoR):-
initial_acs_map(ACs,ACMap,Init,Fin),
NG=(Init,G1,Fin),
compile_foreach_iterators(Iterators,LocalVars,ACMap,G,G1,PrefixName,ProgTab,DumNo,DumNoR).
compile_foreach_iterators([],_LocalVars,ACMap,G,NG,PrefixName,ProgTab,DumNo,DumNoR) =>
substitute_accumulators(G,G1,ACMap),
expand_constr(G1,NG,PrefixName,ProgTab,DumNo,DumNoR).
compile_foreach_iterators([I in B1..Step..B2|Iterators],LocalVars,ACMap,G,NG,PrefixName,ProgTab,DumNo,DumNoR) =>
(var(I)->true; cmp_error(["wrong loop variable: ", I])),
(Step== -1 ->
compile_foreach_range_downto_1(I,B1,B2,Iterators,LocalVars,ACMap,G,NG,PrefixName,ProgTab,DumNo,DumNoR);
compile_foreach_range_step(I,B1,B2,Step,Iterators,LocalVars,ACMap,G,NG,PrefixName,ProgTab,DumNo,DumNoR)).
compile_foreach_iterators([I in L..U|Iterators],LocalVars,ACMap,G,NG,PrefixName,ProgTab,DumNo,DumNoR) =>
(var(I)->true; cmp_error(["wrong loop variable: ", I])),
compile_foreach_range_upto_1(I,L,U,Iterators,LocalVars,ACMap,G,NG,PrefixName,ProgTab,DumNo,DumNoR).
compile_foreach_iterators([I in Lst|Iterators],LocalVars,ACMap,G,NG,PrefixName,ProgTab,DumNo,DumNoR) =>
compile_foreach_lst(I,Lst,Iterators,LocalVars,ACMap,G,NG,PrefixName,ProgTab,DumNo,DumNoR).
compile_foreach_range_upto_1(I,LExp,UExp,IteratorsR,LocalVars,ACMap,G,NG,PrefixName,ProgTab,DumNo,DumNoR):-
new_pred_name_foreach(PrefixName,DumNo,NewPredName),
DumNo1 is DumNo+1,
term_variables((IteratorsR,G),AllVars),
extract_arg_vars(AllVars,I,IteratorsR,LocalVars,ACMap,GVars,[]),
foreach_accumulator_args(ACMap,ACHeadArgs,[]),
split_acs_map(ACMap,ACMap1,ACMap2),
append(GVars,ACHeadArgs,Args),
foreach_accumulator_args(ACMap2,ACTailArgs,[]),
append(GVars,ACTailArgs,TailArgs),
foreach_end_accumulator_args(ACMap,BodyR1),
CallNewPred=..[NewPredName,Lower,Upper|Args],
NG=(Lower is LExp, Upper is UExp, CallNewPred),
Head=..[NewPredName,Elm,Upper|Args],
Body1=(Elm>Upper : BodyR1),
Tail2=..[NewPredName,Elm1,Upper|TailArgs],
Body2=(G1,Elm1 is Elm+1,Tail2),
Cl1=(Head:-Body1),
copy_term(Cl1,Cl1CP),
Cl2=(Head:-true : Body2),
I=Elm,
copy_term(t(IteratorsR,LocalVars,ACMap1,G,G1,Cl2),TCopy),
TCopy=t(IteratorsRCP,LocalVarsCP,ACMap1CP,GCP,G1CP,Cl2CP),
%
compile_foreach_iterators(IteratorsRCP,LocalVarsCP,ACMap1CP,GCP,G1CP,PrefixName,ProgTab,DumNo1,DumNo2),
%
'$eliminate_disjunctions'(Cl1CP,NCl1CP,ProgTab,DumNo2,DumNo3),
'$eliminate_disjunctions'(Cl2CP,NCl2CP,ProgTab,DumNo3,DumNoR),
functor(Head,_,Arity),
PredDef=pred(NewPredName,Arity,_Mode,_Delay,_Tabled,[NCl1CP,NCl2CP]),
hashtable_put(ProgTab,NewPredName/Arity,PredDef).
compile_foreach_range_downto_1(I,UExp,LExp,IteratorsR,LocalVars,ACMap,G,NG,PrefixName,ProgTab,DumNo,DumNoR):-
new_pred_name_foreach(PrefixName,DumNo,NewPredName),
DumNo1 is DumNo+1,
term_variables((IteratorsR,G),AllVars),
extract_arg_vars(AllVars,I,IteratorsR,LocalVars,ACMap,GVars,[]),
foreach_accumulator_args(ACMap,ACHeadArgs,[]),
split_acs_map(ACMap,ACMap1,ACMap2),
append(GVars,ACHeadArgs,Args),
foreach_accumulator_args(ACMap2,ACTailArgs,[]),
append(GVars,ACTailArgs,TailArgs),
foreach_end_accumulator_args(ACMap,BodyR1),
CallNewPred=..[NewPredName,Upper,Lower|Args],
NG=(Lower is LExp, Upper is UExp, CallNewPred),
Head=..[NewPredName,Elm,Lower|Args],
Body1=(Elm<Lower : BodyR1),
Tail2=..[NewPredName,Elm1,Lower|TailArgs],
Body2=(G1,Elm1 is Elm-1,Tail2),
Cl1=(Head:-Body1),
copy_term(Cl1,Cl1CP),
Cl2=(Head:-true : Body2),
I=Elm,
copy_term(t(IteratorsR,LocalVars,ACMap1,G,G1,Cl2),TCopy),
TCopy=t(IteratorsRCP,LocalVarsCP,ACMap1CP,GCP,G1CP,Cl2CP),
%
compile_foreach_iterators(IteratorsRCP,LocalVarsCP,ACMap1CP,GCP,G1CP,PrefixName,ProgTab,DumNo1,DumNo2),
%
'$eliminate_disjunctions'(Cl1CP,NCl1CP,ProgTab,DumNo2,DumNo3),
'$eliminate_disjunctions'(Cl2CP,NCl2CP,ProgTab,DumNo3,DumNoR),
functor(Head,_,Arity),
PredDef=pred(NewPredName,Arity,_Mode,_Delay,_Tabled,[NCl1CP,NCl2CP]),
hashtable_put(ProgTab,NewPredName/Arity,PredDef).
compile_foreach_range_step(I,B1,B2,Step,IteratorsR,LocalVars,ACMap,G,NG,PrefixName,ProgTab,DumNo,DumNoR):-
new_pred_name_foreach(PrefixName,DumNo,NewPredName),
DumNo1 is DumNo+1,
term_variables((IteratorsR,G),AllVars),
extract_arg_vars(AllVars,I,IteratorsR,LocalVars,ACMap,GVars,[]),
foreach_accumulator_args(ACMap,ACHeadArgs,[]),
split_acs_map(ACMap,ACMap1,ACMap2),
append(GVars,ACHeadArgs,Args),
foreach_accumulator_args(ACMap2,ACTailArgs,[]),
append(GVars,ACTailArgs,TailArgs),
foreach_end_accumulator_args(ACMap,BodyR1),
CallNewPred=..[NewPredName,B1Val,B2Val,StepVal|Args],
NG=(B1Val is B1, B2Val is B2, StepVal is Step, CallNewPred),
Head=..[NewPredName,Elm,B2Arg,StepArg|Args],
Body1=(StepArg>0,Elm>B2Arg : BodyR1),
Cl1=(Head:-Body1),
copy_term(Cl1,Cl1CP),
Body2=(StepArg<0,Elm<B2Arg : BodyR1),
Cl2=(Head:-Body2),
copy_term(Cl2,Cl2CP),
Tail3=..[NewPredName,Elm1,B2Arg,StepArg|TailArgs],
Body3=(G1,Elm1 is Elm+StepArg,Tail3),
Cl3=(Head:-true : Body3),
I=Elm,
copy_term(t(IteratorsR,LocalVars,ACMap1,G,G1,Cl3),TCopy),
TCopy=t(IteratorsRCP,LocalVarsCP,ACMap1CP,GCP,G1CP,Cl3CP),
%
compile_foreach_iterators(IteratorsRCP,LocalVarsCP,ACMap1CP,GCP,G1CP,PrefixName,ProgTab,DumNo1,DumNo2),
%
'$eliminate_disjunctions'(Cl1CP,NCl1CP,ProgTab,DumNo2,DumNo3),
'$eliminate_disjunctions'(Cl2CP,NCl2CP,ProgTab,DumNo3,DumNo4),
'$eliminate_disjunctions'(Cl3CP,NCl3CP,ProgTab,DumNo4,DumNoR),
functor(Head,_,Arity),
PredDef=pred(NewPredName,Arity,_Mode,_Delay,_Tabled,[NCl1CP,NCl2CP,NCl3CP]),
hashtable_put(ProgTab,NewPredName/Arity,PredDef).
compile_foreach_lst(I,Lst,IteratorsR,LocalVars,ACMap,G,NG,PrefixName,ProgTab,DumNo,DumNoR):-
new_pred_name_foreach(PrefixName,DumNo,NewPredName),
DumNo1 is DumNo+1,
term_variables((IteratorsR,G),AllVars),
extract_arg_vars(AllVars,I,IteratorsR,LocalVars,ACMap,GVars,[]),
foreach_accumulator_args(ACMap,ACHeadArgs,[]),
split_acs_map(ACMap,ACMap1,ACMap2),
append(GVars,ACHeadArgs,Args),
foreach_accumulator_args(ACMap2,ACTailArgs,[]),
append(GVars,ACTailArgs,TailArgs),
foreach_end_accumulator_args(ACMap,BodyR1),
NG=..[NewPredName,Lst|Args],
Head1=..[NewPredName,[]|Args],
Body1=BodyR1,
Head2=..[NewPredName,[Elm|Elms]|Args],
Tail2=..[NewPredName,Elms|TailArgs],
Head3=..[NewPredName,[_|Elms]|Args],
Tail3=..[NewPredName,Elms|Args],
Body2=(G1,Tail2),
Cl1=(Head1:-true : Body1),
copy_term(Cl1,Cl1CP),
Cl2=(Head2:-true : Body2),
I=Elm,
copy_term(t(IteratorsR,LocalVars,ACMap1,G,G1,Cl2),TCopy2),
TCopy2=t(IteratorsRCP,LocalVarsCP,ACMap1CP,GCP,G1CP,Cl2CP),
Cl3=(Head3:-true : Tail3),
copy_term(Cl3,Cl3CP),
compile_foreach_iterators(IteratorsRCP,LocalVarsCP,ACMap1CP,GCP,G1CP,PrefixName,ProgTab,DumNo1,DumNo2),
'$eliminate_disjunctions'(Cl1CP,NCl1CP,ProgTab,DumNo2,DumNo3),
'$eliminate_disjunctions'(Cl2CP,NCl2CP,ProgTab,DumNo3,DumNoR),
functor(Head1,_,Arity),
Head4=..[NewPredName,Collection|Args],
Tail4=..[NewPredName,CollectionLst|Args],
Cl4=(Head4:-true : (foreach_collection_to_lst(Collection,CollectionLst),Tail4)),
copy_term(Cl4,Cl4CP),
PredDef=pred(NewPredName,Arity,_Mode,_Delay,_Tabled,[NCl1CP,NCl2CP,Cl3CP,Cl4CP]),
hashtable_put(ProgTab,NewPredName/Arity,PredDef).
foreach_accumulator_args([],Args,ArgsR) => Args=ArgsR.
foreach_accumulator_args([ac_inout(_Name,In,Out)|ACMap],Args,ArgsR) =>
Args=[In,Out|Args1],
foreach_accumulator_args(ACMap,Args1,ArgsR).
foreach_end_accumulator_args([],Body) => Body=true.
foreach_end_accumulator_args([ac_inout(_Name,In,Out)|ACMap],Body) =>
Body=(In=Out,BodyR),
foreach_end_accumulator_args(ACMap,BodyR).
split_acs_map([],ACMap1,ACMap2) => ACMap1=[],ACMap2=[].
split_acs_map([ac_inout(Name,In,Out)|ACMap],ACMap1,ACMap2) =>
ACMap1=[ac_inout(Name,In,Mid)|ACMap1R],
ACMap2=[ac_inout(Name,Mid,Out)|ACMap2R],
split_acs_map(ACMap,ACMap1R,ACMap2R).
/* utilities */
extract_arg_vars([],_I,_Iterators,_LocalVars,_ACMap,Args,ArgsR) => Args=ArgsR.
extract_arg_vars([Var|Vars],I,Iterators,LocalVars,ACMap,Args,ArgsR):-true ?
($occur(Var,I);
is_a_loop_var(Var,Iterators);
membchk(Var,LocalVars);
foreach_lookup_acmap(Var,1,_,ACMap);
foreach_lookup_acmap(Var,0,_,ACMap)),!,
extract_arg_vars(Vars,I,Iterators,LocalVars,ACMap,Args,ArgsR).
extract_arg_vars([Var|Vars],I,Iterators,LocalVars,ACMap,Args,ArgsR) =>
Args=[Var|Args1],
extract_arg_vars(Vars,I,Iterators,LocalVars,ACMap,Args1,ArgsR).
is_a_loop_var(Var,(I in _)):-true ? $occur(Var,I),!.
is_a_loop_var(Var,(Iterators1,_)):-true ?
is_a_loop_var(Var,Iterators1),!.
is_a_loop_var(Var,(_,Iterators2)) =>
is_a_loop_var(Var,Iterators2).
initial_acs_map([],ACMap,InitCode,FinCode) => ACMap=[],InitCode=true,FinCode=true.
initial_acs_map([AC],ACMap,InitCode,FinCode) =>
ACMap=[Triplet],
initial_ac_map(AC,Triplet,InitCode,FinCode).
initial_acs_map([AC|ACs],[Triplet|ACMap],InitCode,FinCode):-
InitCode=(InitCode1,InitCodeR),
FinCode=(FinCode1,FinCodeR),
initial_ac_map(AC,Triplet,InitCode1,FinCode1),
initial_acs_map(ACs,ACMap,InitCodeR,FinCodeR).
initial_acs_map(AC,ACMap,InitCode,FinCode) =>
ACMap=[Triplet],
initial_ac_map(AC,Triplet,InitCode,FinCode).
initial_ac_map(ac(Name,InitVal),ac_inout(Name,NameIn,NameOut),(NameIn=InitVal),(Name=NameOut)).
initial_ac_map(ac1(Name,FinVal),ac_inout(Name,NameIn,NameOut),(Name=NameIn),(NameOut=FinVal)).
% Replace inputs and outputs in recurrences: A^0 is input and A^1 is output.
substitute_accumulators(Term,NTerm,_ACMap):-var(Term) :
NTerm=Term.
substitute_accumulators(Term,NTerm,_ACMap):-atomic(Term) :
NTerm=Term.
substitute_accumulators(Term,NTerm,ACMap):-Term=(Var^Tail) :
(foreach_lookup_acmap(Var,Tail,NTerm,ACMap)->true;
NTerm=Term).
substitute_accumulators([E|Es],Lst,ACMap) =>
Lst=[E1|Es1],
substitute_accumulators(E,E1,ACMap),
substitute_accumulators(Es,Es1,ACMap).
substitute_accumulators(Term,NTerm,ACMap) =>
functor(Term,F,N),
functor(NTerm,F,N),
substitute_accumulators(Term,NTerm,1,N,ACMap).
substitute_accumulators(_Term,_NTerm,I,N,_), I>N => true.
substitute_accumulators(Term,NTerm,I,N,ACMap) =>
arg(I,Term,A),
arg(I,NTerm,NA),
substitute_accumulators(A,NA,ACMap),
I1 is I+1,
substitute_accumulators(Term,NTerm,I1,N,ACMap).
foreach_lookup_acmap(Term,Tail,NTerm,[ac_inout(Term1,In,Out)|_]), Term==Term1 =>
(Tail==0->NTerm=In;
Tail==1->NTerm=Out).
foreach_lookup_acmap(Term,Tail,NTerm,[_|ACMap]) =>
foreach_lookup_acmap(Term,Tail,NTerm,ACMap).
new_pred_name_foreach(PrefixName,DumNo,NewPredName):-
number_codes(DumNo,DumNoCodes),
append(PrefixName,[0'_,0'#,0'_|DumNoCodes],NewPredNameCodes),
atom_codes(NewPredName,NewPredNameCodes).
compile_foreach_retrieve_iterators(G,I,Arity,Iterators,ACs,LocalVars,Goal), I==Arity =>
arg(I,G,Goal),
Iterators=[],
(var(ACs)->ACs=[];true),
(var(LocalVars)->LocalVars=[];true).
compile_foreach_retrieve_iterators(G,I,Arity,Iterators,ACs,LocalVars,Goal) =>
arg(I,G,A),
(nonvar(A),A=(_ in _) ->
Iterators=[A|Iterators1]
;I>=Arity-2 ->
(cmp_foreach_check_accumulators(A) ->
Iterators=Iterators1,
(var(ACs)->ACs=A;cmp_error(["two accumulators given separately in foreach"]),fail)
;cmp_foreach_check_lvars(A)->
Iterators=Iterators1,
(var(LocalVars)->LocalVars=A;cmp_error(["invalid local variables given in foreach"]),fail)
;fail
)
;fail
),
I1 is I+1,
compile_foreach_retrieve_iterators(G,I1,Arity,Iterators1,ACs,LocalVars,Goal).
cmp_foreach_check_lvars([]) => true.
cmp_foreach_check_lvars([X|Xs]) => var(X),cmp_foreach_check_lvars(Xs).
cmp_foreach_check_accumulators(ac1(_,_)) => true.
cmp_foreach_check_accumulators(ac(_,_)) => true.
cmp_foreach_check_accumulators(Accumulators), Accumulators=[_|_] =>
cmp_foreach_check_accumulator_lst(Accumulators).
cmp_foreach_check_accumulator_lst([]) => true.
cmp_foreach_check_accumulator_lst([X|_]), var(X) => fail.
cmp_foreach_check_accumulator_lst([ac(_,_)|L]) =>
cmp_foreach_check_accumulator_lst(L).
cmp_foreach_check_accumulator_lst([ac1(_,_)|L]) =>
cmp_foreach_check_accumulator_lst(L).

399
library/dialect/bprolog/foreach.pl Normal file
View File

@ -0,0 +1,399 @@
% File : foreach.pl
% Author : Neng-Fa Zhou
% Updated: June 2009, updated Dec. 2009, updated Sep. 2010
% Purpose: an interpreter of foreach/2-10 and list comprehension
/************************************************************************/
:- yap_flag(unknown,error).
:- ensure_loaded(actionrules).
:- op(560,xfy,[..,to,downto]).
:- op(700,xfx,[subset,notin,in,@=]).
:- use_module(library(lists)).
/*
test:-
L=[1,2,3],foreach(I in L, writeln(I)),fail.
test:-
foreach(I in 1..10,format("~d ",I)),fail.
test:-
foreach(I in 1..2..10,format("~d ",I)),fail. % step = 2
test:-
foreach(I in 10.. -1.. 1,format("~d ",I)),fail. % step = -1
test:-
foreach((A,N) in ([a,b],1..2),writeln(A=N)),fail.
test:-
L=[1,2,3],foreach(I in L, ac(S,0), S^1 is S^0+I),writeln(S),fail.
test:-
T=f(1,2,3),functor(T,_,N),foreach(I in 1..N,ac(S,0),(S^1 is S^0+T[I])),writeln(S),fail.
test:-
L=[1,2,3],foreach(I in L, ac1(C,[]), C^0=[I|C^1]),writeln(C),fail.
test:-
foreach(I in [1,2], J in [a,b], ac(L,[]),L^1=[(I,J)|L^0]),writeln(L),fail.
test:-
foreach(I in [1,2], J in [a,b], ac1(L,[]),L^0=[(I,J)|L^1]),writeln(L),fail.
test:-
foreach(T in ([a,b],1..2),writeln(T)),fail.
test:-
foreach(F in 1.0..0.2..1.5,format("~1f ",F)),fail.
test:-
L @= [I : I in 1..10],writeln(L),fail.
test:-
L @= [I : I in 1..2..10],writeln(L),fail.
test:-
L @= [I : I in 10..-1..1],writeln(L),fail.
test:-
L @=[X : X in 1..5],writeln(L),fail.
test:-
L @= [1 : X in 1..5],writeln(L),fail.
test:-
L @= [Y : X in 1..5],writeln(L),fail.
test:-
L @= [Y : X in 1..5,[Y]],writeln(L),fail.
test:-
L @=[(A,I): (A,I) in ([a,b],1..2)],writeln(L),fail.
test:-
L @= [Y : X in [1,2,3], [Y], Y is -X],writeln(L),fail.
test:-
L @=[(A,I): A in [a,b], I in 1..2],writeln(L),fail.
test:-
L @=[(A,I): (A,I) in ([a,b],1..2)],writeln(L),fail.
test.
*/
Lhs @= Rhs,
Rhs=[(T:I)|Is],
I=(_ in _) => % list comprehension
'$change_list_comprehension_to_foreach'(T,I,Is,CallForeach,L),
call(CallForeach),
L @= Lhs.
Lhs @= Rhs,
Lhs=[(T:I)|Is],
I=(_ in _) => % list comprehension
'$change_list_comprehension_to_foreach'(T,I,Is,CallForeach,L),
call(CallForeach),
L @= Rhs.
A^Indexes @= Exp => % array access
'$aget'(A,Indexes,T),
Exp @= T.
Exp @= A^Indexes => % array access
'$aget'(A,Indexes,T),
Exp @= T.
Lhs @= Rhs => Lhs=Rhs.
'$change_list_comprehension_to_foreach'(T,I,Is,CallForeach,L):-
'$retrieve_list_comp_lvars_goal'(Is,LocalVars1,Goal1,Is1),
(nonvar(T),T=_^_-> % array access
LocalVars=[TempVar|LocalVars1],
(Goal1==true->
Goal=(TempVar@=T,L^0=[TempVar|L^1])
;
Goal=(Goal1->(TempVar@=T,L^0=[TempVar|L^1]);L^0=L^1)
)
;
LocalVars=LocalVars1,
(Goal1==true->
Goal=(L^0=[T|L^1])
;
Goal=(Goal1->L^0=[T|L^1];L^0=L^1)
)
),
append(Is1,[LocalVars,ac1(L,[]),Goal],Is2),
CallForeach=..[foreach,I|Is2].
'$retrieve_list_comp_lvars_goal'([],LocalVars,Goal,Is) =>
LocalVars=[],Goal=true,Is=[].
'$retrieve_list_comp_lvars_goal'([E|Es],LocalVars,Goal,Is),E = (_ in _) =>
Is=[E|IsR],
'$retrieve_list_comp_lvars_goal'(Es,LocalVars,Goal,IsR).
'$retrieve_list_comp_lvars_goal'([LVars,G],LocalVars,Goal,Is),LVars=[] =>
Is=[],LocalVars=LVars,G=Goal.
'$retrieve_list_comp_lvars_goal'([LVars,G],LocalVars,Goal,Is),LVars=[_|_] =>
Is=[],LocalVars=LVars,G=Goal.
'$retrieve_list_comp_lvars_goal'([LVars],LocalVars,Goal,Is),LVars=[_|_] =>
Is=[],LocalVars=LVars,Goal=true.
'$retrieve_list_comp_lvars_goal'([LVars],LocalVars,Goal,Is),LVars=[] =>
Is=[],LocalVars=LVars,Goal=true.
'$retrieve_list_comp_lvars_goal'([G],LocalVars,Goal,Is) =>
Is=[],LocalVars=[],G=Goal.
'$retrieve_list_comp_lvars_goal'(Args,_LocalVars,_Goal,_Is) =>
throw(illegal_arguments(list_comprehension(Args))).
foreach(A1,A2,A3,A4,A5,A6,A7,A8,A9,A10):-
foreach_aux((A1,A2,A3,A4,A5,A6,A7),A8,A9,A10).
foreach(A1,A2,A3,A4,A5,A6,A7,A8,A9):-
foreach_aux((A1,A2,A3,A4,A5,A6),A7,A8,A9).
foreach(A1,A2,A3,A4,A5,A6,A7,A8):-
foreach_aux((A1,A2,A3,A4,A5),A6,A7,A8).
foreach(A1,A2,A3,A4,A5,A6,A7):-
foreach_aux((A1,A2,A3,A4),A5,A6,A7).
foreach(A1,A2,A3,A4,A5,A6):-
foreach_aux((A1,A2,A3),A4,A5,A6).
foreach(A1,A2,A3,A4,A5):-
foreach_aux((A1,A2),A3,A4,A5).
foreach(A1,A2,A3,A4):-
foreach_aux(A1,A2,A3,A4).
foreach_aux(A1,A2,A3,A4):-
(A2=(_ in _); A2=(_,_)),!, % iterator
foreach_aux((A1,A2),A3,A4).
foreach_aux(A1,A2,A3,A4):-
foreach_check_accumulators(A3),!,
interp_foreach_with_acs(A1,A2,A3,A4).
foreach_aux(A1,A2,A3,A4):-
foreach_check_accumulators(A2),!,
interp_foreach_with_acs(A1,A3,A2,A4).
foreach_aux(A1,A2,A3,A4):-
throw(illegal_arguments(foreach(A1,A2,A3,A4))).
foreach(A1,A2,A3):-
foreach_aux(A1,A2,A3).
foreach_aux(A1,A2,A3):-
(A2=(_ in _); A2=(_,_)),!,
interp_foreach((A1,A2),true,[],A3,[],[],_).
foreach_aux(A1,A2,A3):-
foreach_check_accumulators(A2),!,
interp_foreach_with_acs(A1,[],A2,A3).
foreach_aux(A1,A2,A3):-
foreach_check_lvars(A2),!,
interp_foreach(A1,true,A2,A3,[],[],_).
foreach(Iterators,Goal):-
interp_foreach(Iterators,true,[],Goal,[],[],_).
interp_foreach_with_acs(Iterators,LVars,Accumulators,Goal):-
init_accumulators(Accumulators,ACs0),!,
interp_foreach(Iterators,true,LVars,Goal,[],ACs0,ACs),
fin_accumulators(Accumulators,ACs0,ACs).
interp_foreach_with_acs(Iterators,LVars,Accumulators,Goal):-
throw(illegal_arguments(foreach(Iterators,LVars,Accumulators,Goal))).
interp_foreach((I,Is),IsRest,LVars,Goal,Map,ACs0,ACs):-!,
(IsRest==true->IsRest1=Is;IsRest1=(Is,IsRest)),
interp_foreach(I,IsRest1,LVars,Goal,Map,ACs0,ACs).
interp_foreach(Pattern in D,IsRest,LVars,Goal,Map,ACs0,ACs):-
interp_foreach_term_instance(D,D1,Map),
(var(D1)->handle_exception(instantiation_error,foreach);true),
interp_foreach_in(Pattern,D1,IsRest,LVars,Goal,Map,ACs0,ACs).
interp_foreach(true,true,LVars,Goal,Map,ACs0,ACs):-!,
foreach_copy_accumulators(ACs0,ACs),
interp_foreach_term_instance(Goal,Goal1,LVars,Map,_,ACs0,ACs),
call(Goal1).
interp_foreach(true,Is,LVars,Goal,Map,ACs0,ACs):-
interp_foreach(Is,true,LVars,Goal,Map,ACs0,ACs).
interp_foreach_in(Var,(L..Step..U),IsRest,LVars,Goal,Map,ACs0,ACs) =>
(var(Var)->true;throw(wrong_loop_variable(Var))),
(foreach_lookup_map(Var,_,Map)->throw(duplicate_loop_variable(Var));true),
L1 is L,
U1 is U,
Step1 is Step,
foreach_range(Var,L1,U1,Step1,IsRest,LVars,Goal,Map,ACs0,ACs).
interp_foreach_in(Var,L..U,IsRest,LVars,Goal,Map,ACs0,ACs) =>
(var(Var)->true;throw(wrong_loop_variable(Var))),
(foreach_lookup_map(Var,_,Map)->throw(duplicate_loop_variable(Var));true),
L1 is L,
U1 is U,
foreach_range(Var,L1,U1,1,IsRest,LVars,Goal,Map,ACs0,ACs).
interp_foreach_in(_,[],IsRest,LVars,Goal,Map,ACs0,ACs) =>
ACs=ACs0.
interp_foreach_in(E,D,IsRest,LVars,Goal,Map,ACs0,ACs):-true :::
term_variables(E,EVars),
(member(Var,EVars),foreach_lookup_map(Var,_,Map),!,throw(duplicate_loop_variable(Var));true),
foreach_pattern_in(E,D,IsRest,LVars,Goal,Map,ACs0,ACs).
foreach_range(_Var,L,U,Step,_IsRest,_LVars,_Goal,_Map,ACs0,ACs),Step>0,L>U =>
ACs0=ACs.
foreach_range(_Var,L,U,Step,_IsRest,_LVars,_Goal,_Map,ACs0,ACs),Step<0,L<U =>
ACs0=ACs.
foreach_range(Var,L,U,Step,IsRest,LVars,Goal,Map,ACs0,ACs) =>
interp_foreach(IsRest,true,LVars,Goal,[(Var,L)|Map],ACs0,ACs1),
L1 is L+Step,
foreach_range(Var,L1,U,Step,IsRest,LVars,Goal,Map,ACs1,ACs).
foreach_pattern_in(_Pattern,D,_IsRest,_LVars,_Goal,_Map,_ACs0,_ACs),var(D) =>
handle_exception(instantiation_error,foreach).
foreach_pattern_in(Pattern,D,IsRest,LVars,Goal,Map,ACs0,ACs),D=[_|_] =>
foreach_pattern_in_list(Pattern,D,IsRest,LVars,Goal,Map,ACs0,ACs).
foreach_pattern_in(Pattern,D,IsRest,LVars,Goal,Map,ACs0,ACs) =>
foreach_simu_collection_to_tuples(D,Tuples),
foreach_pattern_in_list(Pattern,Tuples,IsRest,LVars,Goal,Map,ACs0,ACs).
foreach_pattern_in_list(_Pattern,Lst,_IsRest,_LVars,_Goal,_Map,_ACs0,_ACs),var(Lst) =>
handle_exception(instantiation_error,foreach).
foreach_pattern_in_list(_Pattern,[],_IsRest,_LVars,_Goal,_Map,ACs0,ACs) =>
ACs0=ACs.
foreach_pattern_in_list(Pattern,[E|Es],IsRest,LVars,Goal,Map,ACs0,ACs) =>
(foreach_update_map(Pattern,E,Map,Map1)->
interp_foreach(IsRest,true,LVars,Goal,Map1,ACs0,ACs1)
;
ACs0=ACs1),
foreach_pattern_in_list(Pattern,Es,IsRest,LVars,Goal,Map,ACs1,ACs).
foreach_pattern_in_list(_Pattern,Lst,_IsRest,_LVars,_Goal,_Map,_ACs0,_ACs):-true :::
handle_exception(type_error(list,Lst),foreach).
foreach_update_map(Var,E,Map0,Map):-var(Var),!,Map=[(Var,E)|Map0].
foreach_update_map(Pattern,E,Map0,Map):-atomic(Pattern),!,E==Pattern,Map=Map0.
foreach_update_map(Pattern,E,Map0,Map):-nonvar(E),
functor(Pattern,F,N),
functor(E,F,N),
foreach_update_map(Pattern,E,Map0,Map,1,N).
foreach_update_map(_Pattern,_E,Map0,Map,I,N):-I>N,!,Map=Map0.
foreach_update_map(Pattern,E,Map0,Map,I,N):-
arg(I,Pattern,Ti),
arg(I,E,Ei),
foreach_update_map(Ti,Ei,Map0,Map1),
I1 is I+1,
foreach_update_map(Pattern,E,Map1,Map,I1,N).
interp_foreach_term_instance(Term,Term1,Map):-
interp_foreach_term_instance(Term,Term1,[],Map,_,[],[]).
% Replace loop variables with their values; rename local variables;
% replace inputs and outputs in recurrences: A^0 is input and A^1 is output.
interp_foreach_term_instance(Term,NTerm,LVars,Map,NMap,_ACs0,_ACs):-var(Term),!,
(foreach_lookup_map(Term,NTerm,Map)->NMap=Map;
membchk(Term,LVars)->NMap=[(Term,NTerm)|Map];
NTerm=Term,NMap=Map).
interp_foreach_term_instance(Term,NTerm,_LVars,Map,NMap,_ACs0,_ACs):-atomic(Term),!,
NTerm=Term,NMap=Map.
interp_foreach_term_instance(Term^Tail,NTerm,_LVars,Map,NMap,ACs0,_ACs):-
var(Term),Tail==0,
foreach_lookup_map(Term,NTerm,ACs0),!,
NMap=Map.
interp_foreach_term_instance(Term^Tail,NTerm,_LVars,Map,NMap,_ACs0,ACs):-
var(Term),Tail==1,
foreach_lookup_map(Term,NTerm,ACs),!,
NMap=Map.
interp_foreach_term_instance([E|Es],Lst,LVars,Map,NMap,ACs0,ACs):-!,
Lst=[E1|Es1],
interp_foreach_term_instance(E,E1,LVars,Map,Map1,ACs0,ACs),
interp_foreach_term_instance(Es,Es1,LVars,Map1,NMap,ACs0,ACs).
interp_foreach_term_instance(Term,NTerm,_LVars,Map,NMap,_ACs0,_ACs):-
is_array(Term),!,
NTerm=Term,NMap=Map.
interp_foreach_term_instance(Term,NTerm,_LVars,Map,NMap,_ACs0,_ACs):-
is_hashtable(Term),!,
NTerm=Term,NMap=Map.
interp_foreach_term_instance(Term,NTerm,LVars,Map,NMap,ACs0,ACs):-
functor(Term,F,N),
functor(NTerm,F,N),
interp_foreach_term_instance(Term,NTerm,LVars,Map,NMap,1,N,ACs0,ACs).
interp_foreach_term_instance(_Term,_NTerm,_LVars,Map,NMap,I,N,_,_):-I>N,!,
NMap=Map.
interp_foreach_term_instance(Term,NTerm,LVars,Map,NMap,I,N,ACs0,ACs):-
arg(I,Term,A),
arg(I,NTerm,NA),
interp_foreach_term_instance(A,NA,LVars,Map,Map1,ACs0,ACs),
I1 is I+1,
interp_foreach_term_instance(Term,NTerm,LVars,Map1,NMap,I1,N,ACs0,ACs).
init_accumulators(ac1(Name,_),ACs):-!, ACs=[(Name,_)].
init_accumulators(ac(Name,Init),ACs):-!, ACs=[(Name,Init)].
init_accumulators(Accumulators,ACs):-Accumulators=[_|_],
init_accumulator_lst(Accumulators,ACs).
init_accumulator_lst([],ACs):-!,ACs=[].
init_accumulator_lst([ac1(Name,_)|Accumulators],ACs):-!,
ACs=[(Name,_)|ACsR],
init_accumulator_lst(Accumulators,ACsR).
init_accumulator_lst([ac(Name,Init)|Accumulators],ACs):-
ACs=[(Name,Init)|ACsR],
init_accumulator_lst(Accumulators,ACsR).
fin_accumulators(ac1(Name,Fin),[(_,Init)],[(_,Val)]):-!,
Name=Init,Fin=Val.
fin_accumulators(ac(Name,_),_,[(_,Val)]):-!, Name=Val.
fin_accumulators(Accumulators,ACs0,ACs):-Accumulators=[_|_],
fin_accumulator_lst(Accumulators,ACs0,ACs).
fin_accumulator_lst([],_,_).
fin_accumulator_lst([ac1(Name,Fin)|Accumulators],[(_,Init)|ACs0],[(_,Val)|ACs]):-!,
Fin=Val,
Name=Init,
fin_accumulator_lst(Accumulators,ACs0,ACs).
fin_accumulator_lst([ac(Name,_)|Accumulators],[_|ACs0],[(_,Val)|ACs]):-
Name=Val,
fin_accumulator_lst(Accumulators,ACs0,ACs).
foreach_copy_accumulators([],ACs):-!, ACs=[].
foreach_copy_accumulators([(Name,_)|ACs0],ACs):-
ACs=[(Name,_)|ACs1],
foreach_copy_accumulators(ACs0,ACs1).
foreach_check_lvars([]):-true ::: true.
foreach_check_lvars([X|Xs]):- var(X) ::: foreach_check_lvars(Xs).
foreach_check_lvars(Xs):-true :::
throw(illegal_local_variables(Xs)).
foreach_check_accumulators(ac1(_,_)):-!.
foreach_check_accumulators(ac(_,_)):-!.
foreach_check_accumulators(Accumulators):-Accumulators=[_|_],
foreach_check_accumulator_lst(Accumulators).
foreach_check_accumulator_lst([]).
foreach_check_accumulator_lst([X|_]):-var(X),!,fail.
foreach_check_accumulator_lst([ac(_,_)|L]):-!,
foreach_check_accumulator_lst(L).
foreach_check_accumulator_lst([ac1(_,_)|L]):-
foreach_check_accumulator_lst(L).
foreach_lookup_map(Term,NTerm,[(Term1,NTerm1)|_]):-Term==Term1,!,
NTerm=NTerm1.
foreach_lookup_map(Term,NTerm,[_|Map]):-
foreach_lookup_map(Term,NTerm,Map).
foreach_simu_collection_to_tuples((C1,C2,C3),Tuples) ?=>
foreach_collection_to_lst(C1,L1),
foreach_collection_to_lst(C2,L2),
foreach_collection_to_lst(C3,L3),!,
(foreach_simu_collection_to_tuples3(L1,L2,L3,Tuples)->true;
handle_exception(wrong_collection_in_foreach,(C1,C2,C3))).
foreach_simu_collection_to_tuples((C1,C2),Tuples) ?=>
foreach_collection_to_lst(C1,L1),
foreach_collection_to_lst(C2,L2),!,
(foreach_simu_collection_to_tuples2(L1,L2,Tuples)->true;
handle_exception(wrong_collection_in_foreach,(C1,C2))).
foreach_simu_collection_to_tuples(CTuple,_) =>
handle_exception(wrong_collection_in_foreach,CTuple).
foreach_collection_to_lst([],L) => L=[].
foreach_collection_to_lst(C,L),C=[_|_] => L=C.
foreach_collection_to_lst((B1..Step..B2),L) =>
NB1 is B1,
NB2 is B2,
NStep is Step,
foreach_eval_range(NB1,NB2,NStep,L).
foreach_collection_to_lst((B1..B2),L) =>
NB1 is B1,
NB2 is B2,
foreach_eval_range(NB1,NB2,1,L).
foreach_collection_to_lst(CTuple,L),CTuple=(_,_) =>
foreach_simu_collection_to_tuples(CTuple,L).
foreach_collection_to_lst(Collection,_L) =>
handle_exception(wrong_collection_in_foreach,Collection).
foreach_eval_range(B1,B2,Step,L),Step>0,B1>B2 => L=[].
foreach_eval_range(B1,B2,Step,L),Step<0,B1<B2 => L=[].
foreach_eval_range(B1,B2,Step,L) => L=[B1|LR],
NB1 is B1+Step,
foreach_eval_range(NB1,B2,Step,LR).
foreach_simu_collection_to_tuples3([],[],[],Tuples) => Tuples=[].
foreach_simu_collection_to_tuples3([X1|L1],[X2|L2],[X3|L3],Tuples) =>
Tuples=[(X1,X2,X3)|TuplesR],
foreach_simu_collection_to_tuples3(L1,L2,L3,TuplesR).
foreach_simu_collection_to_tuples2([],[],Tuples) => Tuples=[].
foreach_simu_collection_to_tuples2([X1|L1],[X2|L2],Tuples) =>
Tuples=[(X1,X2)|TuplesR],
foreach_simu_collection_to_tuples2(L1,L2,TuplesR).

56
library/dialect/bprolog/hashtable.yap Normal file
View File

@ -0,0 +1,56 @@
:- module(bphash, [new_hashtable/1,
new_hashtable/2,
is_hashtable/1,
hashtable_get/3,
hashtable_put/3,
hashtable_register/3,
hashtable_size/2,
hashtable_to_list/2,
hashtable_values_to_list/2,
hashtable_keys_to_list/2]).
:- use_module(library(bhash), [b_hash_new/2,
is_b_hash/1,
b_hash_lookup/3,
b_hash_insert/3,
b_hash_size/2,
b_hash_to_list/2,
b_hash_values_to_list/2,
b_hash_keys_to_list/2]).
new_hashtable(Hash) :-
b_hash_new(Hash, 7).
new_hashtable(Hash, Size) :-
b_hash_new(Hash, Size).
is_hashtable(Hash) :-
is_b_hash(Hash).
hashtable_get(Hash, Key, Value) :-
b_hash_lookup(Key, Value, Hash).
hashtable_put(Hash, Key, Value) :-
b_hash_insert(Key, Value, Hash).
hashtable_register(Hash, Key, Value) :-
b_hash_lookup(Key, Value0, Hash), !,
Value0 = Value.
hashtable_register(Hash, Key, Value) :-
b_hash_insert(Hash, Key, Value).
hashtable_size(Hash, Size) :-
b_hash_size(Hash, Size).
hashtable_to_list(Hash, List) :-
b_hash_to_list(Hash, List).
hashtable_keys_to_list(Hash, List) :-
b_hash_keys_to_list(Hash, List).
hashtable_values_to_list(Hash, List) :-
b_hash_values_to_list(Hash, List).