/* SIMP */
/* Simplification package */
/* Gathered here by Alan Bundy 24.8.78 */
/* Alterations by Lawrence 24.4.79 */



/***********************************
  TIDY (for cleaning up expressions)
************************************/

/*Exp1 tidies to Exp2*/

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

tidy(Old,New) :- t_tidyax(Old,New), !.

tidy(Old,New) :- !,
	bag_routines(Old,Exp),
	try_rewrite(nt_tidyax,Exp,New).

/*  TIDY Axioms */

/* Terminal Tidy Axioms */

t_tidyax( U=U, true ) .

t_tidyax( U>=U, true ) .

t_tidyax( U>U, false ) .

t_tidyax( U=\=U, false ) .

t_tidyax( U^0 , 1 ) .           /* INCLUDING 0^0*/

t_tidyax( 0^U , 0 ) :- positive(U).

t_tidyax( 1^U , 1 ) .

t_tidyax( log(U,1) , 0 ) .

t_tidyax( log(U,U) , 1 ) .

t_tidyax(cos(U)^2+sin(U)^2, 1).

/* Non Terminal Tidy Axioms */
nt_tidyax( U^1 , U ) .

nt_tidyax((U^(-1))^(-1), U).

nt_tidyax( log(U,U^V) , V).

nt_tidyax( U^log(U,V) , V ).



/*******  BAG FLUSHING ROUTINES  ********/

/*top level flushing routine*/
bag_routines(Old,New) :-
  decomp(Old,[Sym|OArgs]), maplist(tidy,OArgs,NArgs),
  flush([Sym|NArgs],Nlist),
  recomp(New,Nlist),
  !.

/*empty bag if it contains zero element*/
flush([*|L],[+]) :- member(0,L), !.
flush([&|L],[#]) :- member(false,L), !.
flush([#|L],[&]) :- member(true,L), !.

/*Otherwise do other bag flushing routines*/
flush(Old,New) :- fl1(Old,X), fl2(X,Y), fl3(Y,New), !.

/* FIRST REMOVE UNIT ELEMENTS*/

fl1([+|L],New) :- select(0,L,R), !, fl1([+|R],New).
fl1([*|L],New) :- select(1,L,R), !, fl1([*|R],New).
fl1([&|L],New) :- select(true,L,R), !, fl1([&|R],New).
fl1([#|L],New) :- select(false,L,R), !, fl1([#|R],New).
fl1(Old,Old) :- !.


/* THEN REMOVE CANCELLING PAIRS*/

fl2([+|L],New) :- twofrom(L,X,Y,R), cancelling(X,Y), 
    !, fl2([+|R],New).

fl2([*|L],New) :- twofrom(L,X,Y,R), reciprocal(X,Y), 
    !, fl2([*|R],New).

fl2([&|L],New) :- twofrom(L,X,X,R), !, fl2([&,X|R],New).

fl2([#|L],New) :- twofrom(L,X,X,R), !, fl2([#,X|R],New).

fl2(Old,Old) :- !.

cancelling(U,V) :- perm2(U,V,(-1)*X,X).

reciprocal(U,V) :- perm2(U,V,X,X^ -1).
reciprocal(U^X,U^Y) :- cancelling(X,Y).




/* then apply evaluation*/

fl3([Head,New],[Head,New]) :- ! .

fl3([*|L],New) :- select((-1)^(-1),L,R), !, 
    fl3([*,-1|R],New).

fl3([+|L],New) :- pairint(L,X,Y,R), !, Z is X+Y,
    (Z=0 -> fl3([+|R],New) ; fl3([+,Z|R],New)).

fl3([*|L],New) :- pairint(L,X,Y,R), !, Z is X*Y,
    (Z=1 -> fl3([*|R],New) ; fl3([*,Z|R],New)).

fl3([*|L],New) :- twofrom(L,N^(-1),M^(-1),R),
	integer(N), integer(M), !, Z is N*M,
	fl3([*,Z^(-1)|R],New).

fl3([*|L],New) :- twofrom(L,N^(-1),M,R),
    integer(N), integer(M), !,
    eval1(M/N,Q),
    (Q=1 -> fl3([*|R],New) ; fl3([*,Q|R],New)).

fl3([Pred|Args],Anslist) :- Exp =..[Pred|Args],
 checklist(integer,Args), !, eval1(Exp,Ans), Ans=..Anslist.

fl3(Old,Old) :- !.


pairint(L,X,Y,R) :- select(X,L,S), integer(X),
    select(Y,S,R), integer(Y).


/***********************************************************
 NORMALIZE (for putting expressions in weak normal form)
************************************************************/

/*Exp1 normalizes to Exp2*/

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

normalize(Old,New) :-
	removals(Old,Exp1),
	restrict_exp(Exp1,New),
	!.

/* Remove syntactic sugar */
removals(Old,New) :-
	recurse(removals,Old,Exp),
	try_rewrite(remove,Exp,New),
	!.

/* Restrict the scope of negative exponentiation */
restrict_exp(Old,New) :-
	try_rewrite(restrict(negexp),Old,Exp),
	recurse(restrict_exp,Exp,New),
	!.


/*NORMALIZE axioms	additions: sqrt(U) => U^1/2  */
remove(U:V , U^V).

remove(U=<V , V>=U ).

remove(U<V , V>U ).

remove(U/V , U*V^(-1) ).

remove(-U , (-1)*U ).

remove(U-V , U+(-1*V) ).

remove(real(sqrt(U)),U>=0).

remove(sqrt(U)>0,U>0).

restrict(negexp,(U*V)^(-1),U^(-1)*V^(-1)).

restrict(negexp, U^(-1*V), (U^(-1))^V ).


/**********************
	POLYNOMIAL NORMAL FORM
***************************************/


/* Use polynomial form for simplification (always succeeds) */

poly_form(Exp,Poly) :- !,
	poly_form1(Exp,New),
	tidy(New,Poly).

/* Look for terms to simplify */

poly_form1(Exp,Poly) :-
	Exp=..[Sym|Args], ispred(Sym), !,
	maplist(poly_form1,Args,PArgs),
	Poly=..[Sym|PArgs].

/* Apply to term */

poly_form1(Exp,Poly) :- !,
	wordsin(Exp,Vars),
	sublist(mult_occ(Exp),Vars,Vars1),
	poly_form(Vars1,Exp,Poly).
.


/* Test for predicate or logical connective */

ispred(&).	ispred(#).	ispred(=).
ispred(>).	ispred(>=).	ispred(<).	ispred(=<).



/* Put term in polynomial normal form with respect to list of variables*/

poly_form([],Exp,Exp) :- !.

poly_form([Var|Vars],Exp,Poly) :- !,
	poly(Var,Exp,Ebag1,simp),
	maplist(half_poly(Vars),Ebag1,Ebag2),
	make_poly(Var,Ebag2,Poly).


/* Apply poly_form to coeffs */

half_poly(Vars,pair(N,E1), pair(N,E2)) :- !,
	poly_form(Vars,E1,E2).


/* Put polynomials in normal form (succeeds only for polynomials) */

poly_norm(X,Poly,Pbag) :- !,
	poly(X,Poly,Pbag,poly).


/* Forms bag of coefficients */

poly(X,X,[pair(1,1)],Flag) :- !.

poly(X,X^N,[pair(N,1)],poly) :- 
	integer(N), !.

poly(X,X^N,[pair(N,1)],simp) :-
	integer(N), !.

poly(X,E,[pair(0,E)],Flag) :-
	freeof(X,E), !.

poly(X,S+T,Ebag,Flag) :-!,
	poly(X,S,Sbag,Flag), poly(X,T,Tbag,Flag),
	add(Sbag,Tbag,Ebag).

poly(X,S*T,Ebag,Flag) :- !,
	poly(X,S,Sbag,Flag), poly(X,T,Tbag,Flag),
	times(Sbag,Tbag,Ebag).

poly(X,S^N,Ebag,Flag) :-
	integer(N), N>0, !,
	poly(X,S,Sbag,Flag),
	binomial(Sbag,N,Ebag).

poly(X,E,[pair(0,E1)],simp) :- !,
	E=..[Sym|Args],
	maplist(poly_form1,Args,Args1),
	E1=..[Sym|Args1].

/* Add two coefficients bags */

add([],Bag,Bag) :- !.

add([pair(N,E1)|Rest1],Bag2,[pair(N,E1+E2)|Poly]) :- 
	select(pair(N,E2),Bag2,Rest2), !,
	add(Rest1,Rest2,Poly).

add([pair(N,E)|Rest1],Bag2,[pair(N,E)|Pbag]) :- !,
	add(Rest1,Bag2,Pbag).


/* Multiply two coefficient bag */

times([],Bag,[]) :- !.

times([pair(N,E)|Rest1], Bag2, Pbag) :- !,
	maplist(times1(pair(N,E)),Bag2,Pbag1),
	times(Rest1,Bag2,Pbag2),
	add(Pbag1,Pbag2,Pbag).

times1(pair(N1,E1), pair(N2,E2), pair(N,E1*E2)) :- !,
	N is N1+N2.


/* Binomial expansion of coefficient bag */

binomial(Bag, 1, Bag) :- !.

binomial(Sbag, N, Ebag) :- !,
	N1 is N-1,
	binomial(Sbag,N1,Ebag1),
	times(Sbag,Ebag1,Ebag).


/* Reconstitute bag of coefficients into polynomial */

make_poly(X,Bag1,Poly) :- !,
	maplist(combine(X),Bag1,Bag2),
	recomp(Poly,[+|Bag2]).

/* combine coefficient and power into product */

combine(X,pair(0,E),E) :- !.
combine(X,pair(1,E),E*X) :- !.
combine(X,pair(N,E),E*X^N) :- !.


/************ SUBSTITUTE with messages *************/


subst_mesg(S,Old,New)
	:- subst(S,Old,Exp), tidy(Exp,New),
	   trace('Applying substitution %c\n  to    : %c\n  gives : %c\n',
			[S,Old,New], 1),
	   !.



