module subs3q; % Routines for matching products.
% Author: Anthony C. Hearn.
% Copyright (c) 1992 RAND. All rights reserved.
fluid '(!*mcd powlis1!* !*sub2 subfg!*);
global '(!*match !*resubs mchfg!*);
symbolic procedure subs3q u;
%U is a standard quotient.
%Value is a standard quotient with all product substitutions made;
begin scalar x;
x := mchfg!*; %save value in case we are in inner loop;
mchfg!* := nil;
u := quotsq(subs3f numr u,subs3f denr u);
mchfg!* := x;
return u
end;
symbolic procedure subs3f u;
%U is a standard form.
%Value is a standard quotient with all product substitutions made;
subs3f1(u,!*match,t);
symbolic procedure subs3f1(u,l,bool);
%U is a standard form.
%L is a list of possible matches.
%BOOL is a boolean variable which is true if we are at top level.
%Value is a standard quotient with all product substitutions made;
begin scalar x,z;
z := nil ./ 1;
a: if null u then return z
else if domainp u then return addsq(z,u ./ 1)
else if bool and domainp lc u then go to c;
x := subs3t(lt u,l);
if not bool %not top level;
or not mchfg!* then go to b; %no replacement made;
mchfg!* := nil;
if numr x = u and denr x = 1 then <<x := u ./ 1; go to b>>
% also shows no replacement made (sometimes true with non
% commuting expressions)
else if null !*resubs then go to b
else if !*sub2 or powlis1!* then x := subs2q x;
%make another pass;
x := subs3q x;
b: z := addsq(z,x);
u := cdr u;
go to a;
c: x := list lt u ./ 1;
go to b
end;
symbolic procedure subs3t(u,v);
% U is a standard term, V a list of matching templates.
% Value is a standard quotient for the substituted term.
begin scalar bool,w,x,y,z;
x := mtchk(car u,if domainp cdr u then sizchk(v,1) else v);
if null x then go to a %lpow doesn't match;
else if null caar x then go to b; %complete match found;
y := subs3f1(cdr u,x,nil); %check tc for match;
if mchfg!* then return multpq(car u,y);
a: return list u . 1; %no match;
b: x := cddar x; %list(<subst value>,<denoms>);
z := caadr x; %leading denom;
mchfg!* := nil; %initialize for tc check;
y := subs3f1(cdr u,!*match,nil);
mchfg!* := t;
if car z neq caar u then go to e
else if z neq car u %powers don't match;
then y := multpq(caar u .** (cdar u-cdr z),y);
b1: y := multsq(simpcar x,y);
x := cdadr x;
if null x then return y;
z := 1; %unwind remaining denoms;
c: if null x then go to d;
w:= if atom caar x or sfp caar x then caar x else
((lambda ww;
if kernp ww and eqcar(ww := mvar numr ww,car caar x)
then ww
else revop1 caar x)
(simp caar x) where subfg!* = nil);
% In the non-commutative case we have to be very careful about
% order of terms in a product. Introducing negative powers
% solves this problem.
if noncomp w or not !*mcd then bool := t;
% z := multpf(mksp(w,if null bool then cdar x else -cdar x),z);
% original line
z := multf(z,!*p2f mksp(w,
if null bool then cdar x else -cdar x));
% kernel CAAR X is not unique here. Earlier versions used just
% CAAR X, but this leads to sums of terms in the wrong order.
% The code here is probably still not correct in all cases, and
% may lead to unbounded calculations. Maybe SIMP should be used
% instead of REVOP1, with appropriate adjustments in the code
% to construct Z.
x := cdr x;
go to c;
d: return if not bool then car y . multf(z,cdr y)
else multf(z,car y) . cdr y;
e: if simp car z neq simp caar u then errach list('subs3t,u,x,z);
%maybe arguments were in different order, otherwise it's fatal;
if cdr z neq cdar u
then y:= multpq(caar u .** (cdar u-cdr z),y);
go to b1
end;
symbolic procedure sizchk(u,n);
if null u then nil
else if length caar u>n then sizchk(cdr u,n)
else car u . sizchk(cdr u,n);
symbolic procedure mtchk(u,v);
%U is a standard power, V a list of matching templates.
%If a match is made, value is of the form:
%list list(NIL,<boolean form>,<subst value>,<denoms>),
%otherwise value is an updated list of templates;
begin scalar flg,v1,w,x,y,z;
flg := noncomp car u;
a0: if null v then return z;
v1 := car v;
w := car v1;
a: if null w then go to d;
x := mtchp1(u,car w,caadr v1,cdadr v1);
b: if null x then go to c
else if car (y := subla(car x,delete(car w,car v1))
. list(subla(car x,cadr v1),
subla(car x,caddr v1),
subla(car x,car w)
. cadddr v1))
then z := y . z
else if lispeval subla(car x,cdadr v1) then return list y;
x := cdr x;
go to b;
c: if null flg then <<w := cdr w; go to a>>
else if cadddr v1 and nocp w then go to e;
d: z :=aconc(z,v1); % Could also be append(z,list v1).
e: v := cdr v;
go to a0
end;
symbolic procedure nocp u;
null u or (noncomp caar u and nocp cdr u);
endmodule;
end;