Artifact 1d79c2075fa6a7cd21a02cc8cb81e7c693ffe690c676d3bbb3ea8d166930bb69:
- Executable file
r37/packages/poly/subs3q.red
— part of check-in
[f2fda60abd]
at
2011-09-02 18:13:33
on branch master
— Some historical releases purely for archival purposes
git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 5508) [annotate] [blame] [check-ins using] [more...]
- Executable file
r38/packages/poly/subs3q.red
— part of check-in
[f2fda60abd]
at
2011-09-02 18:13:33
on branch master
— Some historical releases purely for archival purposes
git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 5508) [annotate] [blame] [check-ins using]
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;