Artifact f2f6c4fd29fb6e1e5d3e0ccbf1c2a692f666ee69d7637e835772e5f636fb2986:
- Executable file
r37/packages/excalc/indsymm.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: 7940) [annotate] [blame] [check-ins using] [more...]
- Executable file
r38/packages/excalc/indsymm.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: 7940) [annotate] [blame] [check-ins using]
module indsymm; % Author: Eberhard Schruefer fluid '(indl); % Needed by Common Lisp. comment index_symmetries u(k,l,m,n): symmetric in {k,l},{m,n} antisymmetric in {{k,l},{m,n}}, g(k,l),h(k,l): symmetric; symbolic procedure index!-symmetriestat; begin scalar res,x,y; scan(); a: res := (begin scalar indexedvars,syms,asyms; d: indexedvars := (xread1 'for) . indexedvars; if null(cursym!* eq '!*colon!*) then <<scan(); go to d>>; x := scan(); if x eq 'symmetric then go to sym else if x eq 'antisymmetric then go asym else symerr('index!-symmetries,t); sym: if scan() eq 'in then begin scan(); flag('(antisymmetric),'delim); b: y := cdr xread1 'for; if eqcar(car y,'list) then y := for each j on y collect if eqcar(car j,'list) and (null cdr j or (length car j = length cadr j)) then cdar j else symerr('index!-symmetries,t); syms := y . syms; if null((x := cursym!*) eq 'antisymmetric) and null(x eq '!*semicol!*) and (scan() eq '!*lcbkt!*) then go to b; remflag('(antisymmetric),'delim); end else <<syms := 'symmetric; x := cursym!*; if x eq '!*comma!* then scan()>>; if x eq 'antisymmetric then go to asym else return {indexedvars,syms,asyms}; asym: if scan() eq 'in then begin scan(); flag('(symmetric),'delim); c: y := cdr xread1 'for; if eqcar(car y,'list) then y := for each j on y collect if eqcar(car j,'list) and (null cdr j or (length car j = length cadr j)) then cdar j else symerr('index!-symmetries,t); asyms := y . asyms; if null((x := cursym!*) eq 'symmetric) and null(x eq '!*semicol!*) and (scan() eq '!*lcbkt!*) then go to c; remflag('(symmetric),'delim) end else <<asyms := 'antisymmetric; x := cursym!*; if x eq '!*comma!* then scan()>>; if x eq 'symmetric then go to sym else return {indexedvars,syms,asyms} end) . res; if null(x eq '!*semicol!*) then go to a; return {'indexsymmetries,mkquote res} end; put('index_symmetries,'stat,'index!-symmetriestat); symbolic procedure indexsymmetries u; for each j in u do begin scalar v,x,y,z; integer n; v := cdr j; for each m in car j do <<x := v; if car v eq 'symmetric then x := list cdr m . cdr v else if cadr v eq 'antisymmetric then x := {car v,list cdr m}; n := 0; z := x; for each k in cdr m do <<x := subst(list('nth,'indl,n := n+1),k,x); z := subst(n,k,z)>>; y := for each l in car x collect {'lambda,'(indl), {'tot!-sym!-indp, {'evlis,if atom caar l then mkquote l else mkquote for each r in l collect {'evlis, mkquote r}}}}; for each l in cadr x do y := {'lambda,'(indl), {'tot!-asym!-indp, {'evlis,if atom caar l then mkquote l else mkquote for each r in l collect {'evlis, mkquote r}}}} . y; put(car m,'indxsymmetries,y); y := for each l in car z collect {'lambda,'(indl), {'symmetrize!-inds, mkquote l,'indl}}; for each l in cadr z do y := {'lambda,'(indl), {'asymmetrize!-inds, mkquote l,'indl}} . y; put(car m,'indxsymmetrize,y)>> end; symbolic procedure indxsymp(u,bool); null bool or apply1(car bool,u) and indxsymp(u,cdr bool); symbolic procedure tot!-sym!-indp u; null u or null cdr u or (car u = cadr u) or (if atom car u then indordp(car u,cadr u) else (indxchk car u or indxchk cadr u or indordlp(car u,cadr u))) and tot!-sym!-indp cdr u; symbolic procedure tot!-asym!-indp u; null u or null cdr u or (null(car u=cadr u) and (if atom car u then indordp(car u,cadr u) else (indxchk car u or indxchk cadr u or indordlp(car u,cadr u)))) and tot!-asym!-indp cdr u; symbolic procedure indexsymmetrize u; begin scalar x,y; integer sgn; x := get(car u,'indxsymmetrize); sgn := 1; y := 1 . cdr u; a: if null x then return sgn . (car u . cdr y); y := apply1(car x,cdr y); if null y then return; sgn := car y*sgn; x := cdr x; go to a; end; symbolic procedure symmetrize!-inds(u,v); begin scalar x,y,z; integer n; x := for each j in u collect if atom j then nth(v,j) else for each k in j collect nth(v,k); z := if atom car x then indordn x else flatindl indordln x; if null atom car u then u := flatindl u; x := pair(u,z); return 1 . for each j in v collect if x and (caar x = (n := n+1)) then <<y := cdar x; x := cdr x; y>> else j end; symbolic procedure asymmetrize!-inds(u,v); % Permp must use = here. begin scalar x,y,z; integer n,sgn; x := for each j in u collect if atom j then nth(v,j) else for each k in j collect nth(v,k); if repeats x then return; sgn := if permp(z := if atom car x then indordn x else indordln x,x) then 1 else -1; if null atom car u then <<u := flatindl u; z := flatindl z>>; z := pair(u,z); return sgn . for each j in v collect if z and (caar z = (n := n+1)) then <<y := cdar z; z := cdr z; y>> else j end; symbolic procedure indordln u; if null u then nil else if null cdr u then u else if null cddr u then indordl2(car u,cadr u) else indordlad(car u,indordln cdr u); symbolic procedure indordl2(u,v); if indordlp(u,v) then list(u,v) else list(v,u); symbolic procedure indordlad(a,u); if null u then list a else if indordlp(a,car u) then a . u else car u . indordlad(a,cdr u); endmodule; end;