Artifact eed5941bff67e9ec283108005737422c737a9a58fc7080ab0e8acddeac0f1d8b:
- Executable file
r37/packages/atensor/perm1.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: 6049) [annotate] [blame] [check-ins using] [more...]
- Executable file
r38/packages/atensor/perm1.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: 6049) [annotate] [blame] [check-ins using]
%====================================================== % Name: PERM1 - permutation package % Author: A.Kryukov (kryukov@theory.npi.msu.su) % Copyright: (C), 1993-1996, A.Kryukov % Version: 2.32 % Release: Nov. 12, 1993 % Mar. 28, 1996 PFIND: add error msg. %====================================================== module perm1$ global '(!*ppacked)$ !*ppacked:=t$ %------------------------------------------------------- % Generator of permutations. % Version 1.2.1 Nov. 18, 1994 % %------------------------------------------------------- procedure GPerm n$ % order of symmetric group. % Return all pertmutation of S(n). begin scalar l$ % if n>9 then rederr list('GPerm,": ",n," is too high order (<=9).")$ while n>0 do << l:=n . l$ n:=n-1 >>$ return for each x in GPerm0 l collect pkp x$ end$ procedure GPerm0(OLst)$ % OLst - list of objects. % Return - list of permutation of these objects. if null OLst then nil else GPerm3(cdr OLst,list list car OLst)$ procedure GPerm3(OList,Res)$ % OList - list of objects, % Res - list of perm. of objects. if null OList then Res else GPerm3(cdr OList,GPerm2(Res,car OList,nil))$ procedure GPerm2(PLst,Obj,Res)$ % Obj - object, % PLst - permutation list, % Res - list of perm. included Obj. if null PLst then Res else GPerm2(cdr PLst,Obj,GPerm1(Rev(car PLst,nil),Obj,nil,Res))$ procedure GPerm1(L,Obj,R,Res)$ % Obj - object, % L,R - left(reverse form) and right(direct form) part of % permutation. % Res - list of permutation. if null L then (Obj . R) . Res else GPerm1(cdr L,Obj,car L . R,Rev(L,Obj . R) . Res)$ procedure Rev(Lst,RLst)$ if null Lst then RLst else Rev(cdr Lst, car Lst . RLst)$ %------------------------------------------------------- symbolic procedure mkunitp k$ begin scalar p$ for i:=1:k do p:=i . p$ return pkp reversip p$ end$ symbolic procedure pfind(l1,l2)$ % l1,l2 - (paked) lists of indices. begin scalar p,z$ integer m$ l1:=unpkp l1$ l2:=unpkp l2$ m:=length l2 + 1$ l2:=for each x in l2 collect x$ for each x in l1 do << z:=member(x,l2)$ if null z then rederr list("PFIND: No index",x,"in",l2)$ %+ AK 28/03/96 p:=(m - length z) . p$ rplaca(z,'nil!*)$ >>$ return pkp reversip p$ end$ symbolic procedure prev(f)$ begin scalar p,w$ integer i,j,l$ f:=unpkp f$ l:=length f$ for i:=1:l do << w:=f$ j:=1$ while not(car w = i) do << j:=j+1$ w:=cdr w >>$ p:=j . p$ >>$ return pkp reversip p$ end$ symbolic procedure psign(f)$ begin integer s,i,j,n,k$ scalar new0,new,wnew,f0,wf$ s:=1$ f:=unpkp f$ n:=length f$ f0:=f$ new0:=for each x in f collect t$ new:=new0$ for i:=1:n do << if car new then % find cycle contained i << j:=car f$ while not(j = i) do << wnew:=new0$ wf:=f0$ for k:=1:j-1 do << wnew:=cdr wnew$ wf:=cdr wf >>$ rplaca(wnew,nil)$ s:=-s$ j:=car wf$ >>$ >>$ new:=cdr new$ f:=cdr f$ >>$ % for i return s$ end$ symbolic procedure pmult(f,g)$ begin scalar p,w,ok$ integer i$ f:=unpkp f$ g:=unpkp g$ while g do << w:=f$ for i:=1:(car g - 1) do w:=cdr w$ p:=car w . p$ g:=cdr g$ >>$ return pkp reversip p$ end$ symbolic procedure pappl(p,l)$ begin scalar l1,w$ integer i$ p:=unpkp p$ while p do << w:=l$ for i:=1:(car p - 1) do w:=cdr w$ l1:=car w . l1$ p:=cdr p$ >>$ return reversip l1$ end$ symbolic procedure pappl0(p1,p2)$ pkp pappl(p1,unpkp p2)$ symbolic procedure pupright(p,d)$ begin scalar w,i,k$ p:=unpkp p$ k:=(length p + 1)$ d:=k+d-1$ for i:=k:d do w:=i . w$ return pkp append(p,reversip w)$ end$ symbolic procedure pupleft(p,d)$ begin scalar w,i$ p:=unpkp p$ p:=for each x in p collect (x+d)$ for i:=1:d do w:=i . w$ return pkp append(reversip w,p)$ end$ symbolic procedure pappend(p1,p2)$ begin scalar l; p1:=unpkp p1; l:=length p1; p2:=unpkp p2; p2:=for each x in p2 collect (x + l)$ return pkp append(p1,p2)$ end$ %-------------------------------------------------------- global '(diglist!*)$ diglist!*:='((!1 . 1) (!2 . 2) (!3 . 3) (!4 . 4) (!5 . 5) (!6 . 6) (!7 . 7) (!8 . 8) (!9 . 9) (!0 . 0))$ symbolic procedure dssoc(x,u)$ if null u then nil else if x=cdar u then car u else dssoc(x,cdr u)$ %symbolic procedure hugerank()$ 3$ symbolic procedure pkp p$ begin scalar w,huge,z$ if atom p or null !*ppacked then return p$ huge:=(length p >= 10)$ for each x in p do if huge then << if x<10 then w := car dssoc(x,diglist!*) . '!0 . w else << z:=divide(x,10)$ w := car dssoc(car z,diglist!*) . w$ w := car dssoc(cdr z,diglist!*) . w$ >>$ >> else w:=car dssoc(x,diglist!*) . w$ return compress reversip w$ end$ symbolic procedure unpkp p$ begin scalar w,huge,z$ if null atom p then return p$ p:=explode p$ huge:=(length p >=10)$ if huge and null evenp length p then p := '!0 . p$ while p do << if huge then << z:=cdr assoc(car p,diglist!*)$ p:=cdr p$ w:= (z*10+cdr assoc(car p,diglist!*)) . w$ >> else w:=cdr assoc(car p,diglist!*) . w$ p:=cdr p$ >>$ return reversip w$ end$ symbolic procedure porder p $ length unpkp p$ symbolic procedure hugep p$ << p:=unpkp p$ if length p >= 10 then list p else nil >>$ endmodule; end;