Artifact e657c3c598689e0d5264d37960f372f33e54c2ebdb6d7dd2d49202b924305f24:
- Executable file
r37/packages/excalc/vardf.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: 7303) [annotate] [blame] [check-ins using] [more...]
- Executable file
r38/packages/excalc/vardf.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: 7303) [annotate] [blame] [check-ins using]
module vardf; % Author: Eberhard Schruefer. fluid '(depl!* kord!*); global '(keepl!* bndeq!*); symbolic procedure simpvardf u; if indvarpf numr simp0 cadr u then mksq('vardf . u,1) else begin scalar b,r,v,w,x,y,z; v := !*a2k cadr u; if null cddr u then w := intern compress append(explode '!', explode if atom v then v else car v) else w := caddr u; if null atom v then w := w . cdr v; putform(w,prepf deg!*form v); kord!* := append(list(w := !*a2k w),kord!*); if x := assoc(v,depl!*) then for each j in cdr x do depend1(w,j,t); x := varysq(simp!* car u,v,w); b := y := nil ./ 1; while x do if (z := mvar ldpf x) eq w then <<y := addsq(lc x,y); x := red x>> else if eqcar(z,'wedge) then if cadr z eq w then <<y := addsq(multsq(!*kk2q('wedge . cddr z), lc x),y); x := red x>> else if eqcar(cadr z,'d) then <<y := addsq(simp list('wedge,list('d, list('times,'wedge . cddr z, prepsq lc x))),y); b := addsq(multsq(!*kk2q('wedge . w . cddr z),lc x), b); x := red x>> else rerror(excalc,11,list("Wrong ordering ",z)) else if eqcar(z,'partdf) then <<r := reval list('innerprod, list('partdf,caddr z), prepsq lc x); x := addpsf((if cdddr z then !*kk2f('partdf . w . cdddr z) else !*k2f w) .* negsq simp list('d,r) .+ nil,red x); b := addsq(multsq(if cdddr z then !*kk2q('partdf . w . cdddr z) else !*k2q w,simp r),b)>> else << b := addsq(multsq(simp cadr z,lc x),b); x := red x>>; kord!* := cdr kord!*; bndeq!* := mk!*sq b; return y end; put('vardf,'simpfn,'simpvardf); put('vardf,'rtypefn,'getrtypeor); put('vardf,'partitfn,'partitvardf); symbolic procedure partitvardf u; partitsq!* simpvardf u; symbolic procedure varysq(u,v,w); multpsf(addpsf(varyf(numr u,v,w), multpsf(1 .* u .+ nil,varyf(negf denr u,v,w))), 1 .* (1 ./ denr u) .+ nil); symbolic procedure varyf(u,v,w); if domainp u then nil else addpsf(addpsf(multpsf(1 .* !*p2q lpow u .+ nil, varyf(lc u,v,w)), multpsf(varyp(lpow u,v,w), 1 .* (lc u ./ 1) .+ nil)), varyf(red u,v,w)); symbolic procedure varyp(u,v,w); begin scalar x,z; integer n; n := cdr u; u := car u; if u eq v then z := !*k2f w .* (1 ./ 1) .+ nil else if atomf u then if x := assoc(u,keepl!*) then begin scalar alglist!*; z := varysq(simp0 cdr x,v,w) end else if null atom u and null atom v then if u=v then !*k2f w .* (1 ./ 1) .+ nil else nil else if null atom v then nil else if depends(u,v) then z := !*k2f w .* simp list('partdf,u,v) .+ nil else nil else if sfp u then z := varyf(u,v,w) else if car u eq '!*sq then z := varysq(cadr u,v,w) else if x := get(car u,dfn_prop u) then for each j in for each k in cdr u collect varysq(simp k,v,w) do <<if j then z := addpsf(multpsf(j,1 .* simp subla(pair(caar x,cdr u),cdar x) .+ nil),z); x := cdr x>> else if x := get(car u,'varyfn) then z := apply3(x,cdr u,v,w) else if ndepends(u,v) then z := !*k2f w .* simp list('partdf,u,v) .+ nil else nil; return if n=1 then z else multpsf(1 .* !*t2q((u to (n-1)) .* n) .+ nil,z) end; symbolic procedure !*pf2psf(u,v); if null u then nil else if domainp u then multsq(u ./ 1,v) else !*k2f ldpf u .* multsq(lc u,v) .+ !*pf2psf(red u,v); symbolic procedure varywedge(u,v,w); begin scalar x,y,z; x := list 'wedge; for each j on u do begin y := varysq(simp car j,v,w); a: if y then z := addpsf(if deg!*form w then !*pf2psf(partitop append(x,prepf ldpf y . cdr j), lc y) else ldpf y .* multsq(1 ./ denr lc y,simp append(x,prepf numr lc y . cdr j)) .+ nil,z); if y and (y := red y) then go to a; x := append(x,list car j); end; return z end; put('wedge,'varyfn,'varywedge); symbolic procedure varyexdf(u,v,w); begin scalar x; for each j on varysq(simp car u,v,w) do if j then x := addpsf(!*pf2psf(partitop list('d,mvar ldpf j),lc j),x); return x end; put('d,'varyfn,'varyexdf); symbolic procedure varyhodge(u,v,w); begin scalar x; for each j on varysq(simp car u,v,w) do if j then x := addpsf(!*pf2psf(partitop list('hodge,mvar ldpf j),lc j),x); return x end; put('hodge,'varyfn,'varyhodge); symbolic procedure varypartdf(u,v,w); begin scalar x; for each j on varysq(simp car u,v,w) do if j then x := addpsf(!*a2f('partdf . mvar ldpf j . cdr u) .* lc j .+ nil, x); return x end; put('partdf,'varyfn,'varypartdf); symbolic procedure simpnoether u; if indvarpf numr simp0 caddr u then mksq('noether . u,1) else begin scalar x,y; simpvardf list(car u,cadr u); x := simp!* bndeq!*; y := intern compress append(explode '!', explode if atom cadr u then cadr u else caadr u); if null atom cadr u then y := y . cdadr u; y := list(y . list('liedf,caddr u,cadr u)); return addsq(multsq(subf(numr x,y),1 ./ denr x), negsq simp list('innerprod,caddr u,car u)) end; put('noether,'simpfn,'simpnoether); symbolic procedure noetherind u; caddr u; put('noether,'indexfun,'noetherind); put('noether,'rtypefn,'getrtypeor); endmodule; end;