reduce-historical/r38/packages/atensor/perm1.red

%======================================================
%       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;