Artifact 952923b6e33eb886375d378edb23a0fe4a71d5177fd0e57132db8f8aaef20b6a:
- Executable file
r37/packages/misc/compactf.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: 8653) [annotate] [blame] [check-ins using] [more...]
- Executable file
r38/packages/misc/compactf.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: 8653) [annotate] [blame] [check-ins using]
module compactf; % Algorithms for compacting algebraic expressions. % Author: Anthony C. Hearn. % Copyright (c) 1991 The RAND Corporation. All Rights Reserved. fluid '(frlis!* mv!-vars!*); global '(!*trcompact); switch trcompact; % Interface to REDUCE simplifier. put('compact,'simpfn,'simpcompact); symbolic procedure simpcompact u; begin scalar bool; if null u or null cdr u then rerror(compact,1, list("Wrong number of arguments to compact")); if null !*exp then <<rmsubs(); bool := !*exp := t>>; u := errorset!*(list('simpcompact1,mkquote u),nil); if bool then !*exp := nil; if errorp u then rerror(compact,2,"Compact error"); return car u end; symbolic procedure simpcompact1 u; begin scalar v,x,y,w; v := simp!* car u; u := cadr u; if idp u then if eqcar(x := get(u,'avalue),'list) then u := cadr x else typerr(u,"list") else if getrtype u eq 'list then u := cdr u else typerr(u,"list"); u := for each j in u collect << w:=t; if eqcar(j,'equal) or eqcar(j,'replaceby) then << if eqcar(y:=caddr j,'when) then <<w:=compactbool formbool(caddr y,nil,'algebraic); y:=cadr y>>; j:= {'difference,cadr j,y}>>; % propagate free variables. if(y:=compactfmatch2 j) then <<j:=sublis(for each x in y collect x.cadr x,j); j:=sublis(for each x in y collect cadr x.x,j)>>; j.w>>; for each j in u do v := compactsq(v,simp!* car j,cdr j); return v end; symbolic procedure compactbool w; % Reform condtion w for later evaluation and substitution. % Without this reform (list (quote ~)(quote x)) would not % be substituted by subst('(((~ x).y)..)... . if atom w then w else if eqcar(w,'list) and cdr w and cadr w='(quote !~) then {'quote,{'!~,cadr caddr w}} else compactbool car w . compactbool cdr w; % True beginning of compacting routines. symbolic procedure compactsq(u,v,c); % U is a standard quotient, v a standard quotient for equation v=0. % Result is a standard quotient for u reduced wrt v=0. begin if denr v neq 1 then msgpri("Relation denominator",prepf denr v,"discarded", nil,nil); v := numr v; return multsq(compactf(numr u,v,c) ./ 1, 1 ./ compactf(denr u,v,c)) end; symbolic procedure compactf(u,v,c); % U is a standard form, v a standard form for an equation v=0. % C is a condition for applying v. % Result is a standard form for u reduced wrt v=0. begin scalar x; integer n; if !*trcompact then <<prin2t "*** Arguments on entering compactf:"; mathprint mk!*sq !*f2q u; mathprint mk!*sq !*f2q v>>; while x neq u do <<x := u; u := compactf0(u,v,c); n := n+1>>; if !*trcompact and n>2 then <<prin2 " *** Compactf looped ";prin2 n; prin2t " times">>; return u end; symbolic procedure compactf0(u,v,c); begin scalar x,y,w; x := kernels u; y := kernels v; if not smemq('!~,v) then return compactf1(u,v,x,y); for each p in compactfmatch(x,y) do if p and not smemq('!~,w:=sublis(p,c)) and eval w and not smemq('!~,w:=numr subf(v,p)) then u:=compactf1(u,w,x,kernels w); return u; end; symbolic procedure compactfmatch(x,y); % Finds all possible matches between free variables in % kernels of list x and pattern list y, including incomplete, % inconsistent and the empty match. if null x or null y then '(nil) else begin scalar y1,z,r; z:=compactfmatch(x,cdr y); if not smemq('!~,car y) then return z; y1:=car y; y:= cdr y; r:=for each x1 in x join for each w in compactfmatch1(x1,y1) join for each q in compactfmatch(delete(x1,x),sublis(w,y)) collect union(w,q); return union(r,z); end; symbolic procedure compactfmatch1(x,y); if car y = '!~ then {{y.x}} else if pairp x and car x=car y then mcharg(cdr x,cdr y,car y) where frlis!* =nconc(compactfmatch2 y,frlis!*); symbolic procedure compactfmatch2 y; if atom y then nil else if car y = '!~ then {y} else append(compactfmatch2(car y),compactfmatch2(cdr y)); symbolic procedure compactf1(u,v,x,y); begin scalar z; % x := kernels u; % y := kernels v; z := intersection(x,y); % find common vars. if null z then return u; % Unfortunately, it's too expensive in space to generate all perms. % as in this example: % l:={-c31*c21+c32*c22+c33*c23+c34*c24=t1}; % x:= -c31*c21+c32*c22+c33*c23+c34*c24; % compact(x,l); % out of heap space % for each j in permutations z do u := compactf11(u,v,x,y,j); return compactf11(u,v,x,y,z) % return u end; symbolic procedure compactf11(u,v,x,y,z); begin scalar w; if domainp u then return u; y := append(z,setdiff(y,z)); % vars in eqn. x := append(setdiff(x,z),y); % all vars. x := setkorder x; u := reorder u; % reorder expressions. v := reorder v; z := comfac!-to!-poly comfac u; u := quotf(u,z); u := remchkf(u,v,y); w := compactf2(u,mv!-reduced!-coeffs sf2mv(v,y),y); if termsf w < termsf u then u := w; % Now reduce z (required, e.g. for compact(u1*(h0+h1),{h0+h1=z1})) if not kernlp z then <<z := remchkf(z,v,y); w := compactf2(z,mv!-reduced!-coeffs sf2mv(v,y),y); if termsf w < termsf z then z := w>>; u := multf(z,u); setkorder x; u := reorder u; if !*trcompact then <<prin2t "*** Value on leaving compactf11:"; mathprint mk!*sq !*f2q u>>; return u end; symbolic procedure remchkf(u,v,vars); % This procedure returns u after checking if a smaller remainder % results after division by v. It is potentially inefficient, since % we check all the way down the list, term by term. However, the % process terminates when we no longer have any relevant kernels. (if domainp x or null intersection(kernels u,vars) then x else lt x .+ remchkf(red x,v,vars)) where x=remchkf1(u,v); symbolic procedure remchkf1(u,v); begin integer n; n := termsf u; v := xremf(u,v,n); if null v or termsf(v := car v)>=n then return u else if !*trcompact then prin2t "*** Remainder smaller"; return v end; symbolic procedure xremf(u,v,m); % Returns the quotient and remainder of U divided by V, or NIL if % the number of terms in the remainder exceeds M. % The goal is to keep terms u+terms z<=m. % There is some slop in the count, so one must check sizes on % leaving. begin integer m1,m2,n; scalar x,y,z; if domainp v then return list cdr qremd(u,v); m2 := termsf u; a: if m<= 0 then return nil else if domainp u then return list addf(z,u) else if mvar u eq mvar v then if (n := ldeg u-ldeg v)<0 then return list addf(z,u) else <<x := qremf(lc u,lc v); y := multpf(lpow u,cdr x); m := m+m1; z := addf(z,y); m1 := termsf z; m := m-m1+m2; u := if null car x then red u else addf(addf(u,multf(if n=0 then v else multpf(mvar u .** n,v), negf car x)), negf y); m2 := termsf u; m := m-m2; go to a>> else if not ordop(mvar u,mvar v) then return list addf(z,u); m := m+m1; x := xremf(lc u,v,m); if null x then return nil; z := addf(z,multpf(lpow u,car x)); m1 := termsf z; m := m-m1; u := red u; go to a end; symbolic procedure compactf2(u,v,vars); % U is standard form for expression, v for equation. W is ordered % list of variables in v. Result is a compacted form for u. if domainp u then u else if mvar u memq vars then compactf3(u,v,vars) else lpow u .* compactf2(lc u,v,vars) .+ compactf2(red u,v,vars); symbolic procedure compactf3(u,v,vars); begin scalar mv!-vars!*; mv!-vars!* := vars; return mv2sf(mv!-compact(sf2mv(u,vars),v,nil),vars) end; endmodule; end;