module fixsubf;
% Author: James H. Davenport.
fluid '(!*nosubs asymplis!* dmode!* ncmp!*);
% The standard version of SUBF messes with the order of variables before
% calling SUBF1, something we can't afford, so we define a new version.
symbolic procedure algint!-subf(a,b); algint!-subf1(a,b);
symbolic procedure algint!-subsq(u,v);
!*multsq(algint!-subf(numr u,v),!*invsq algint!-subf(denr u,v));
symbolic procedure algint!-subf1(u,l);
%U is a standard form,
%L an association list of substitutions of the form
%(<kernel> . <substitution>).
%Value is the standard quotient for substituted expression.
%Algorithm used is essentially the straight method.
%Procedure depends on explicit data structure for standard form;
if domainp u
then if atom u then if null dmode!* then u ./ 1 else simpatom u
else if dmode!* eq car u then !*d2q u
else simp prepf u
else begin integer n; scalar kern,m,w,x,xexp,y,y1,z;
z := nil ./ 1;
a0: kern := mvar u;
if m := assoc(kern,asymplis!*) then m := cdr m;
a: if null u or (n := degr(u,kern))=0 then go to b
else if null m or n<m then y := lt u . y;
u := red u;
go to a;
b: if not atom kern and not atom car kern then kern := prepf kern;
if null l then xexp := if kern eq 'k!* then 1 else kern
else if (xexp := algint!-subsublis(l,kern)) = kern
and not assoc(kern,asymplis!*)
then go to f;
c: w := 1 ./ 1;
n := 0;
if y and cdaar y<0 then go to h;
if (x := getrtype xexp) then typerr(x,"substituted expression");
x := simp!* xexp;
% SIMP!* here causes problem with HE package in subf,
% but we probably need the extra power of simp!*
x := reorder numr x ./ reorder denr x;
% needed in case substitution variable is in XEXP;
if null l and kernp x and mvar numr x eq kern then go to f
else if null numr x then go to e; %Substitution of 0;
for each j in y do
<<m := cdar j;
w := !*multsq(!*exptsq(x,m-n),w);
n := m;
z := !*addsq(!*multsq(w,algint!-subf1(cdr j,l)),z)>>;
e: y := nil;
if null u then return z
else if domainp u then return !*addsq(algint!-subf1(u,l),z);
go to a0;
f: sub2chk kern;
for each j in y do
z := !*addsq(!*multsq(!*f2q !*p2f car j,
algint!-subf1(cdr j,l)),z);
go to e;
h: %Substitution for negative powers;
x := simprecip list xexp;
j: y1 := car y . y1;
y := cdr y;
if y and cdaar y<0 then go to j;
k: m := -cdaar y1;
w := !*multsq(!*exptsq(x,m-n),w);
n := m;
z := !*addsq(!*multsq(w,algint!-subf1(cdar y1,l)),z);
y1 := cdr y1;
if y1 then go to k else if y then go to c else go to e
end;
symbolic procedure algint!-subsublis(u,v);
begin scalar x;
return if x := assoc(v,u) then cdr x
else if atom v then v
else if car v eq '!*sq then
list('!*sq,algint!-subsq(cadr v,u),caddr v)
% Previous two lines added by JHD 7 July 1982.
% without them, CDRs in SQ expressions buried inside;
% !*SQ forms are lost;
else if x := get(car v,'subfunc) then apply2(x,u,v)
else for each j in v collect algint!-subsublis(u,j)
end;
put('int,'subfunc,'algint!-subsubf);
symbolic procedure algint!-subsubf(l,expn);
%Sets up a formal SUB expression when necessary;
begin scalar x,y;
for each j in cddr expn do
if (x := assoc(j,l)) then <<y := x . y; l := delete(x,l)>>;
expn := sublis(l,car expn)
. for each j in cdr expn
collect algint!-subsublis(l,j);
%to ensure only opr and individual args are transformed;
if null y then return expn;
expn := aconc!*(for each j in reversip!* y
collect list('equal,car j,aeval cdr j),expn);
return mk!*sq if l then algint!-simpsub expn
else !*p2q mksp('sub . expn,1)
end;
symbolic procedure algint!-simpsub u;
begin scalar !*nosubs,w,x,z;
a: if null cdr u
then <<if getrtype car u or eqcar(car u,'equal)
then typerr(car u,"scalar");
u := simp!* car u;
z := reversip!* z; % to put replacements in same
% order as input.
return quotsq(algint!-subf(numr u,z),
algint!-subf(denr u,z))>>;
!*nosubs := t; % We don't want left side of eqns to change.
w := reval car u;
!*nosubs := nil;
if getrtype w eq 'list
then <<u := append(cdr w,cdr u); go to a>>
else if not eqexpr w then errpri2(car u,t);
x := cadr w;
if null getrtype x then x := !*a2k x;
z := (x . caddr w) . z;
u := cdr u;
go to a;
end;
endmodule;
end;