File contents

/*basic
Basic utilities for PRESS (to be compiled)
Alan Bundy 31.1.80 */


/*service routines (for util?)*/

/*convert lists to conjunctions*/
dottoand([],true) :- !.
dottoand([Hd|Tl],Hd&Rest) :-
	dottoand(Tl,Rest), !.

/*convert conjunctions to lists*/
andtodot(true,[]) :- !.
andtodot(Hd&Tl,[Hd|Rest]) :- !,
	andtodot(Tl,Rest).
andtodot(Exp,[Exp]) :- !.


/*some element of list has property*/
some(Prop,[Hd | Tl]) :-
	apply(Prop,[Hd]), !.
some(Prop,[Hd | Tl]) :-
	some(Prop,Tl), !.


/*Exp is a least dominating expression of X (i.e. 2 args contain X)*/

least_dom(X,Exp) :-
	Exp=..[F|Args],
	sublist(contains(X),Args,XArgs),
	length(XArgs,N), N>1, !.




/*****************************************/
/* PATTERN MATCHER*/
/*****************************************/


/* Rewrite Old into New */

rewrite(Rule,Old,New) :-
	functor(Old,Sym,Arity), functor(Lhs,Sym,Arity),
	apply(Rule,[Lhs,Rhs]),
	apply_rule(Old,Lhs,Rhs,New).

/* Apply rule Lhs => Rhs to Old to produce New */
apply_rule(O1+O2,L1+L2,R,N) :- !,
	decomp(O1+O2,[+|Os]),
	split2ways(Os,[C1|Cs1],[B|Bs]), split2ways([B|Bs],[C2|Cs2],Ns),
	recomp(D1,[+,C1|Cs1]), recomp(D2,[+,C2|Cs2]),
	match(D1,L1), match(D2,L2),
	recomp(N,[+,R|Ns]).

apply_rule(O1*O2,L1*L2,R,N) :- !,
	decomp(O1*O2,[*|Os]),
	split2ways(Os,[C1|Cs1],[B|Bs]), split2ways([B|Bs],[C2|Cs2],Ns),
	recomp(D1,[*,C1|Cs1]), recomp(D2,[*,C2|Cs2]),
	match(D1,L1), match(D2,L2),
	recomp(N,[*,R|Ns]).

apply_rule(O,L,N,N) :- match(O,L).


/*Negative Numbers Hack*/
match(NN,-N) :- integer(NN), NN<0, N is -NN, !.
match(-N,NN) :- integer(NN), NN<0, N is -NN, !.


/* BUILT-IN COMMUTATIVITY AND ASSOCIATIVITY OF + AND */

match(A1+A2, U1+U2) :-
	decomp(A1+A2,[+|As]), split2ways(As,[B1|Bs1],[B2|Bs2]),
	recomp(C1,[+,B1|Bs1]), recomp(C2,[+,B2|Bs2]),
	match(C1,U1), match(C2,U2).

match(A1*A2, U1*U2) :-
	decomp(A1*A2,[*|As]), split2ways(As,[B1|Bs1],[B2|Bs2]),
	recomp(C1,[*,B1|Bs1]), recomp(C2,[*,B2|Bs2]),
	match(C1,U1), match(C2,U2).

/* Unify if X is atomic */

match(X,X) :- atomic(X), !.

/* MATCH ARGUMENTS OF OTHER DOMINANT FUNCTION SYMBOLS*/

match(X,Y) :- 
	functor(X,F,Arity), functor(Y,F,Arity),
	X=..[F|As], Y=..[F|Bs], 
	maplist(match,As,Bs).


/* Split bag into 2 parts */

split2ways([],[],[]).

split2ways([Hd|Tl],L1,R1) :-
	split2ways(Tl,L,R), add_to_one(Hd,L,R,L1,R1).

/* Add Hd to one of L or R */
add_to_one(Hd,L,R,[Hd|L],R).

add_to_one(Hd,L,R,L,[Hd|R]).

/*****************************************/
/* DECOMPOSITION AND RECOMPOSITION OF EXPRESSIONS*/
/*****************************************/

/* DECOMP AND RECOMP ARE GENERALISATIONS OF UNIV TREATING +, *, & and # */
/* AS FUNCTION SYMBOLS HAVING ANY NUMBER OF ARGUMENTS*/

decomp(E+(X+Y),L) :- !, decomp(E+X+Y,L).
decomp(E+X+Y,[+,Y|L]) :- !, decomp(E+X,[+|L]).
decomp(E+X,[+,X,E]) :- !.

decomp(X*(Y*E),L) :- !, decomp(X*Y*E,L).
decomp(E*X*Y,[*,Y|L]) :- !, decomp(E*X,[*|L]).
decomp(Y*E,[*,Y,E]) :- !.

decomp((E&X)&Y,L) :- !, decomp(E&X&Y,L).
decomp(Y&E&X,[&,Y|L]) :- !, decomp(E&X,[&|L]).
decomp(X&E,[&,X,E]) :- !.

decomp((E#X)#Y,L) :- !, decomp(E#X#Y,L).
decomp(Y#E#X,[#,Y|L]) :- !, decomp(E#X,[#|L]).
decomp(X#E,[#,X,E]) :- !.


decomp(E,F) :- E=..F, !.


recomp(E,[+,E]) :- !.
recomp(E+X,[+,X|L]) :- !, recomp(E,[+|L]).
recomp(0,[+]) :- !.

recomp(E,[*,E]) :- !.
recomp(E*X,[*,X|L]) :- !, recomp(E,[*|L]).
recomp(1,[*]) :- !.

recomp(E,[&,E]) :- !.
recomp(X&E,[&,X|L]) :- !, recomp(E,[&|L]).
recomp(true,[&]) :- !.

recomp(E,[#,E]) :- !.
recomp(X#E,[#,X|L]) :- !, recomp(E,[#|L]).
recomp(false,[#]) :- !.


recomp(E,F) :- E=..F, !.






/*********************************************/
/* MISCELLANEOUS ROUTINES*/
/*********************************************/



freeof(X,E) :- occ(X,E,0), !.
singleocc(X,E) :- occ(X,E,1), !.
contains(X,E) :- not occ(X,E,0), !.



/*closeness of all occurences of x in exp is num*/

closeness(X,Exp,Num) :-
	findall(Path,position(X,Exp,Path),Paths),
	closeness(Paths,Num),
	!.

/*closeness of occurences defined by paths is c*/

closeness(Paths,C) :-
	split(Paths,Top,Groups),
	maplist(size,Groups,Sizes),
	sumlist(Sizes,C),
	!.


/*size of tree defined by paths is size*/

size(Paths,Size) :-
	split(Paths,Top,Groups),
	maplist(size,Groups,Sizes),
	sumlist(Sizes,S),
	length(Top,T),
	Size is S+T,
	!.

/*split tree defined by paths into common top and groups of remaining subtrees
where each group has common top*/

split([],[],[]) :- !.

split([Path],Path,[]) :- !.

split(Paths,[F|Rest],Groups) :-
	maplist(cons(F),Rests,Paths), !,
	split(Rests,Rest,Groups).

split(Paths,[],Groups) :-
	group(Paths,Groups),
	!.

/*partition tree defined by paths into groups of subtrees which start the same*/

group([],[]) :- !.

group([[F|Rest]|Paths], [[[F|Rest]|Group]|Groups]) :-
	sublist(hd(F),Paths,Group),
	subtract(Paths,Group,Others),
	group(Others,Groups),
	!.


/*Head and Cons*/
hd(F,[F|Rest]) :- !.

cons(F,Rest,[F|Rest]) :- !.


/*X occurs in E at a position definded by path*/

position(X,E,[]):-
	E=..[X|Args].

position(X,E,L):-
	argn(N,E,T),
	L=[N|L1],
	position(X,T,L1).
	
 
/* X is the nth member of the list*/

nmember(X,[X|_],1).
nmember(X,[_|L],N):-
	nmember(X,L,M),N is M+1.
 
/* x is the nth argument of t*/

argn(N,T,X):-T=..[_|L],nmember(X,L,N).
 
 
/*Add up all numbers in list*/
sumlist([],0) :- !.

sumlist([Hd|Tl],Sum) :-
	sumlist(Tl,TlSum), Sum is Hd+TlSum, !.

/* GENERATE IDENTIFIERS DENOTING ARBITRARY INTEGERS*/

arbint(N) :-  gensym(n,N),
	trace('\twhere %t denotes an arbitrary integer.\n',[N],1),
	assert(integral(N)),
	!.

identifier(Id) :- gensym(x,Id),
	assert(intermediate(Id)),
	!.


subterm(T,E) :- E=..[_|As], member(A,As), subterm(T,A).
subterm(E,E) .




/*****************************************/
/* LIST PROCESSING  put in usvw*/
/*****************************************/

twofrom(L,X,Y,Rem) :- select(X,L,R), select(Y,R,Rem).

any1(P,[X|Xs],[Y|Xs]) :- apply(P,[X,Y]).
any1(P,[X|Xs],[X|Ys]) :- any1(P,Xs,Ys).


/*apply procedure recursively*/
recurse(Proc,Old,New) :-
  Old=..[Sym|Args], maplist(Proc,Args,Nargs),
  New=..[Sym|Nargs],
  !.

/*apply Proc to Exp to get New*/
try_rewrite(Proc,Old,New) :- apply(Proc,[Old,New]), !.
try_rewrite(Proc,Old,Old) :- !.

/* Version of rewrite using matcher */
try_rewrite2(Proc,Old,New) :- 
	rewrite(Proc,Old,Exp), !,
	try_rewrite2(Proc,Exp,New).


try_rewrite2(Proc,Old,Old) :- !.