reduce-historical/r30/hephys.red

%*********************************************************************
%*********************************************************************
%		      HIGH ENERGY PHYSICS PACKAGE
%*********************************************************************
%********************************************************************;

%Copyright (c) 1983 The Rand Corporation;

SYMBOLIC;

%*********************************************************************
%     REQUIRES SIMPLIFICATION FUNCTIONS FOR NON-SCALAR QUANTITIES
%********************************************************************;


%*********************************************************************
%            NON LOCAL VARIABLES REFERENCED IN THIS PACKAGE
%********************************************************************;

FLUID '(!*S!*);

GLOBAL '(DEFINDICES!* INDICES!* MUL!* NCMP!* NDIM!* TYPL!* !*SUB2);

DEFINDICES!* := NIL; %deferred indices in N dim calculations;

INDICES!* := NIL; %list of indices in High Energy Physics
		  %tensor expressions;
NDIM!* := 4;      %number of dimensions in gamma algebra;

COMMENT The generalizations in this package for n dimensional vector
	and gamma algebra are due to Gastmans, Van Proeyen and
	Verbaeten, University of Leuven, Belgium;


%*********************************************************************
%			  SOME DECLARATIONS
%********************************************************************;

DEFLIST ('((CONS SIMPDOT)),'SIMPFN);

SYMBOLIC PROCEDURE VECTOR U;
   VECTOR1 U;

SYMBOLIC PROCEDURE VECTOR1 U;
   <<TYPL!* := UNION('(HVECTORP),TYPL!*);
     FOR EACH X IN U DO PUT(X,'VECTOR,'VECTOR)>>;

SYMBOLIC PROCEDURE HVECTORP U;
   NSP(U,'VECTOR);

PUT('VECTOR,'FN,'VECFN);

PUT('HVECTORP,'LETFN,'NSLET);

PUT('HVECTORP,'NAME,'VECTOR);

PUT('HVECTORP,'EVFN,'VEVAL);

PUT('G,'SIMPFN,'SIMPGAMMA);

FLAGOP NONCOM,NOSPUR;

FLAG ('(G),'NONCOM);

SYMBOLIC PROCEDURE INDEX U;
   BEGIN VECTOR1 U; RMSUBS(); INDICES!* := UNION(INDICES!*,U) END;

SYMBOLIC PROCEDURE REMIND U;
   BEGIN INDICES!* := SETDIFF(INDICES!*,U) END;

SYMBOLIC PROCEDURE MASS U;
   <<TYPL!* := UNION('(HVECTORP),TYPL!*);
     FOR EACH X IN U DO
     <<PUT(CADR X,'MASS,CADDR X); PUT(CADR X,'VECTOR,'VECTOR)>>>>;

SYMBOLIC PROCEDURE GETMAS U;
   (LAMBDA X; IF X THEN X ELSE REDERR LIST(U,"has no mass"))
      GET!*(U,'MASS);

SYMBOLIC PROCEDURE VECDIM U;
   BEGIN
      TYPL!* := UNION('(HVECTORP),TYPL!*);
      NDIM!* := CAR U
   END;

SYMBOLIC PROCEDURE MSHELL U;
   BEGIN SCALAR X,Z;
	TYPL!* := UNION('(HVECTORP),TYPL!*);
    A:	IF NULL U THEN RETURN LET0(Z,NIL);
	X := GETMAS CAR U;
	Z := LIST('EQUAL,LIST('CONS,CAR U,CAR U),LIST('EXPT,X,2)) . Z;
	U := CDR U;
	GO TO A
   END;

RLISTAT '(VECDIM INDEX MASS MSHELL REMIND VECTOR);


%*********************************************************************
%	   FUNCTIONS FOR SIMPLIFYING HIGH ENERGY EXPRESSIONS
%********************************************************************;

SYMBOLIC PROCEDURE VEVAL U;
   BEGIN SCALAR Z;
	U := NSSIMP(U,'HVECTORP);
    A:	IF NULL U THEN RETURN REPLUS Z
	 ELSE IF NULL CDAR U THEN REDERR "Missing vector"
	 ELSE IF CDDAR U THEN REDERR LIST("Redundant vector",CDAR U);
	Z := ACONC(Z,RETIMES(PREPSQ CAAR U . CDAR U));
	U := CDR U;
	GO TO A
   END;

SYMBOLIC PROCEDURE VMULT U;
   BEGIN SCALAR Z;
	Z := LIST LIST(1 . 1);
    A:	IF NULL U THEN RETURN Z;
	Z := VMULT1(NSSIMP(CAR U,'HVECTORP),Z);
	IF NULL Z THEN RETURN;
	U := CDR U;
	GO TO A
   END;

SYMBOLIC PROCEDURE VMULT1(U,V);
   BEGIN SCALAR Z;
	IF NULL V THEN RETURN;
    A:	IF NULL U THEN RETURN Z
	 ELSE IF CDDAR U
	  THEN REDERR("Redundant vector" . CDAR U);
	Z := NCONC(Z,MAPCAR(V,FUNCTION (LAMBDA J;
	      MULTSQ(CAR J,CAAR U) . APPEND(CDR J,CDAR U))));
	U := CDR U;
	GO TO A
   END;

SYMBOLIC PROCEDURE SIMPDOT U;
   MKVARG(U,FUNCTION DOTORD);

SYMBOLIC PROCEDURE DOTORD U;
   <<IF XNP(U,INDICES!*) AND NOT MEMQ('ISIMPQ,MUL!*)
	   THEN MUL!* := ACONC(MUL!*,'ISIMPQ) ELSE NIL;
	IF 'A MEMQ U
	  THEN REDERR "A represents only gamma5 in vector expressions"
	 ELSE MKSQ('CONS . ORD2(CAR U,CARX(CDR U,'DOT)),1)>>;

SYMBOLIC PROCEDURE MKVARG(U,V);
   BEGIN SCALAR Z;
	U := VMULT U;
	Z := NIL ./ 1;
    A:	IF NULL U THEN RETURN Z;
	Z := ADDSQ(MULTSQ(APPLY(V,LIST CDAR U),CAAR U),Z);
	U := CDR U;
	GO TO A
   END;

SYMBOLIC PROCEDURE SPUR U;
   <<RMSUBS();
	 MAP(U,FUNCTION (LAMBDA J;
		   <<REMFLAG(LIST CAR J,'NOSPUR);
			 REMFLAG(LIST CAR J,'REDUCE)>>))>>;

RLISTAT '(SPUR);

SYMBOLIC PROCEDURE SIMPGAMMA !*S!*;
   IF NULL !*S!* OR NULL CDR !*S!*
       THEN REDERR "Missing arguments for G operator"
    ELSE BEGIN
	IF NOT MEMQ('ISIMPQ,MUL!*) THEN MUL!*:= ACONC(MUL!*,'ISIMPQ);
	NCMP!* := T;
	RETURN MKVARG(CDR !*S!*,FUNCTION (LAMBDA J;
			 LIST ((('G . CAR !*S!* . J) . 1) . 1) . 1))
    END;

SYMBOLIC PROCEDURE SIMPEPS U;
   MKVARG(U,FUNCTION EPSORD);

SYMBOLIC PROCEDURE EPSORD U;
   IF REPEATS U THEN NIL ./ 1 ELSE MKEPSQ U;

SYMBOLIC PROCEDURE MKEPSK U;
   %U is of the form (v1 v2 v3 v4).
   %Value is <sign flag> . <kernel for EPS(v1,v2,v3,v4)>;
   BEGIN SCALAR X;
	IF XNP(U,INDICES!*) AND NOT 'ISIMPQ MEMQ MUL!*
	  THEN MUL!* := ACONC(MUL!*,'ISIMPQ);
	X := ORDN U;
	U := PERMP(X,U);
	RETURN U . ('EPS . X)
   END;

SYMBOLIC PROCEDURE MKEPSQ U;
   (LAMBDA X; (LAMBDA Y; IF NULL CAR X THEN NEGSQ Y ELSE Y)
		 MKSQ(CDR X,1))
	MKEPSK U;


%*********************************************************************
%    FUNCTIONS FOR SIMPLIFYING VECTOR AND GAMMA MATRIX EXPRESSIONS
%********************************************************************;

SYMBOLIC SMACRO PROCEDURE MKG(U,L);
   %Value is the standard form for G(L,U);
   !*P2F('G . L . U TO 1);

SYMBOLIC SMACRO PROCEDURE MKA L;
   %Value is the standard form for G(L,A);
   !*P2F(LIST('G,L,'A) TO 1);

SYMBOLIC SMACRO PROCEDURE MKGF(U,L);
   MKSF('G . (L . U));

SYMBOLIC PROCEDURE MKG1(U,L);
   IF NOT FLAGP(L,'NOSPUR) THEN MKG(U,L) ELSE MKGF(U,L);

SYMBOLIC SMACRO PROCEDURE MKPF(U,V);
   MULTPF(U,V);

SYMBOLIC PROCEDURE MKF(U,V);
   MULTF(U,V);

SYMBOLIC PROCEDURE MULTD!*(U,V);
   IF ONEP U THEN V ELSE MULTD(U,V);

SYMBOLIC SMACRO PROCEDURE ADDFS(U,V);
   ADDF(U,V);

SYMBOLIC SMACRO PROCEDURE MULTFS(U,V);
   %U and V are pseudo standard forms
   %Value is pseudo standard form for U*V;
   MULTF(U,V);

FLUID '(NDIMS!*);

SYMBOLIC PROCEDURE ISIMPQ U;
   BEGIN SCALAR NDIMS!*;
      NDIMS!* := SIMP NDIM!*;
      IF DENR NDIMS!* NEQ 1
	THEN <<!*SUB2 := T;
	       NDIMS!* := MULTPF(MKSP(LIST('RECIP,DENR NDIMS!*),1),
				 NUMR NDIMS!*)>>
       ELSE NDIMS!* := NUMR NDIMS!*;
   A: U := ISIMP1(NUMR U,INDICES!*,NIL,NIL,NIL) ./ DENR U;
      IF DEFINDICES!*
	THEN <<INDICES!* := UNION(DEFINDICES!*,INDICES!*);
	       DEFINDICES!* := NIL;
	       GO TO A>>
       ELSE IF NULL !*SUB2 THEN RETURN U
       ELSE RETURN RESIMP U
   END;

SYMBOLIC PROCEDURE ISIMP1(U,I,V,W,X);
   IF NULL U THEN NIL
    ELSE IF DOMAINP U
       THEN IF X THEN MULTD(U,SPUR0(CAR X,I,V,W,CDR X))
	     ELSE IF V THEN REDERR("Unmatched index" . I)
	     ELSE IF W THEN MULTFS(EMULT W,ISIMP1(U,I,V,NIL,X))
	     ELSE U
    ELSE ADDFS(ISIMP2(CAR U,I,V,W,X),ISIMP1(CDR U,I,V,W,X));

SYMBOLIC PROCEDURE ISIMP2(U,I,V,W,X);
   BEGIN SCALAR Z;
	IF ATOM (Z := CAAR U) THEN GO TO A
	 ELSE IF CAR Z EQ 'CONS AND XNP(CDR Z,I)
	    THEN RETURN DOTSUM(U,I,V,W,X)
	 ELSE IF CAR Z EQ 'G
	  THEN GO TO B
	 ELSE IF CAR Z EQ 'EPS THEN RETURN ESUM(U,I,V,W,X);
    A:	RETURN MKPF(CAR U,ISIMP1(CDR U,I,V,W,X));
    B:	Z := GADD(APPN(CDDR Z,CDAR U),X,CADR Z);
	RETURN ISIMP1(MULTD!*(NB CAR Z,CDR U),I,V,W,CDR Z)
   END;

SYMBOLIC PROCEDURE NB U;
   IF U THEN 1 ELSE -1;

SYMBOLIC SMACRO PROCEDURE MKDOT(U,V);
   %Returns a standard form for U.V;
   MKSF('CONS . ORD2(U,V));

SYMBOLIC PROCEDURE DOTSUM(U,I,V,W,X);
   BEGIN SCALAR I1,N,U1,U2,V1,Y,Z;
	N := CDAR U;
	IF NOT (CAR (U1 := CDAAR U) MEMBER I) THEN U1 := REVERSE U1;
	U2 := CADR U1;
	U1 := CAR U1;
	V1 := CDR U;
	IF N=2 THEN GO TO H ELSE IF N NEQ 1 THEN REDERR U;
    A:	IF U1 MEMBER I THEN GO TO A1
	 ELSE IF NULL (Z := MKDOT(U1,U2)) THEN RETURN NIL
	 ELSE RETURN MKF(Z,ISIMP1(V1,I1,V,W,X));
    A1: I1 := DELETE(U1,I);
	IF U1 EQ U2 THEN RETURN MULTF(NDIMS!*,ISIMP1(V1,I1,V,W,X))
	 ELSE IF NOT (Z := ATSOC(U1,V)) THEN GO TO C
	 ELSE IF U2 MEMBER I THEN GO TO D;
	U1 := CDR Z;
	GO TO E;
    C:	IF Z := MEMLIS(U1,X)
	    THEN RETURN ISIMP1(V1,
			      I1,
			      V,
			      W,
			      SUBST(U2,U1,Z) . DELETE(Z,X))
	 ELSE IF Z := MEMLIS(U1,W)
	    THEN RETURN ESUM((('EPS . SUBST(U2,U1,Z)) . 1) . V1,
			     I1,
			     V,
			     DELETE(Z,W),
			     X)
	 ELSE IF U2 MEMBER I AND NULL Y THEN GO TO G;
	RETURN ISIMP1(V1,I,(U1 . U2) . V,W,X);
    D:	U1 := U2;
	U2 := CDR Z;
    E:	I := I1;
	V := DELETE(Z,V);
	GO TO A;
    G:	Y := T;
	Z := U1;
	U1 := U2;
	U2 := Z;
	GO TO A1;
    H:	IF U1 EQ U2 THEN REDERR U;
	I := I1 := DELETE(U1,I);
	U1 := U2;
	GO TO A
   END;

SYMBOLIC PROCEDURE MKSF U;
   %U is a kernel.
   %Value is a (possibly substituted) standard form for U;
   BEGIN SCALAR X;
	X := MKSQ(U,1);
	IF CDR X=1 THEN RETURN CAR X;
	!*SUB2 := T;
	RETURN !*P2F(U TO 1)
   END;


%*********************************************************************
%	    FUNCTIONS FOR SIMPLIFYING DIRAC GAMMA MATRICES
%********************************************************************;

SYMBOLIC PROCEDURE GADD(U,V,L);
   BEGIN SCALAR W,X; INTEGER N;
	N := 0; 		%number of gamma5 interchanges;
	IF NOT (X := ATSOC(L,V)) THEN GO TO A;
	V := DELETE(X,V);
	W := CDDR X;		%list being built;
	X := CADR X;		%true if gamma5 remains;
    A:	IF NULL U THEN RETURN ((REMAINDER(N,2)=0) . (L . X . W) . V)
	 ELSE IF CAR U EQ 'A THEN GO TO C
	 ELSE W := CAR U . W;
    B:	U := CDR U;
	GO TO A;
    C: IF NDIMS!* NEQ 4
	 THEN REDERR "Gamma5 not allowed unless vecdim is 4";
       X := NOT X;
	N := LENGTH W + N;
	GO TO B
   END;


%*********************************************************************
%	FUNCTIONS FOR COMPUTING TRACES OF DIRAC GAMMA MATRICES
%********************************************************************;

SYMBOLIC PROCEDURE SPUR0(U,I,V1,V2,V3); 
   BEGIN SCALAR L,W,I1,KAHP,N,Z; 
      L := CAR U; 
      N := 1; 
      Z := CADR U; 
      U := REVERSE CDDR U; 
      IF Z THEN U := 'A . U; %GAMMA5 REMAINS;
      IF NULL U THEN GO TO END1
       ELSE IF NULL FLAGP(L,'NOSPUR)
        THEN IF CAR U EQ 'A AND (LENGTH U<5 OR HEVENP U)
                  OR NOT CAR U EQ 'A AND NOT HEVENP U
               THEN RETURN NIL
              ELSE IF NULL I THEN <<W := REVERSE U; GO TO END1>>; 
    A: 
      IF NULL U THEN GO TO END1
       ELSE IF CAR U MEMBER I
        THEN IF CAR U MEMBER CDR U
               THEN <<IF CAR U EQ CADR U
                        THEN <<I := DELETE(CAR U,I); 
                               U := CDDR U; 
                               N := MULTF(N,NDIMS!*); 
                               GO TO A>>; 
                      KAHP := T; 
                      I1 := CAR U . I1; 
                      GO TO A1>>
              ELSE IF CAR U MEMBER I1 THEN GO TO A1
              ELSE IF Z := BASSOC(CAR U,V1)
               THEN <<V1 := DELETE(Z,V1); 
                      I := DELETE(CAR W,I); 
                      U := OTHER(CAR U,Z) . CDR U; 
                      GO TO A>>
              ELSE IF Z := MEMLIS(CAR U,V2)
               THEN RETURN IF FLAGP(L,'NOSPUR)
                                AND NULL V1
                                AND NULL V3
                                AND NULL CDR V2
                             THEN MKF(MKGF(APPEND(REVERSE W,U),L),
                                      MULTFS(N,MKEPSF Z))
                            ELSE MULTD!*(N,
                                         ISIMP1(SPUR0(
           L . (NIL . APPEND(REVERSE U,W)),NIL,V1,DELETE(Z,V2),V3),
						I,NIL,LIST Z,NIL))
              ELSE IF Z := MEMLIS(CAR U,V3)
               THEN IF NDIMS!*=4
		      THEN RETURN SPUR0I(U,DELETE(CAR U,I),V1,V2,
					 DELETE(Z,V3),L,N,W,Z)
                     ELSE <<INDICES!* := DELETE(CAR U,INDICES!*); 
                            I := DELETE(CAR U,I); 
                            IF NOT CAR U MEMQ DEFINDICES!*
                              THEN DEFINDICES!* := 
                                    CAR U . DEFINDICES!*; 
                            GO TO A1>>
	      ELSE REDERR LIST("Unmatched index",CAR U);
    A1: 
      W := CAR U . W; 
      U := CDR U; 
      GO TO A; 
    END1: 
      IF KAHP
        THEN IF NDIMS!*=4
               THEN <<Z := MULTFS(N,KAHANE(REVERSE W,I1,L)); 
                      RETURN ISIMP1(Z,SETDIFF(I,I1),V1,V2,V3)>>
              ELSE Z := SPURDIM(W,I,L,NIL,1)
       ELSE Z := SPURR(W,L,NIL,1); 
      RETURN IF NULL Z THEN NIL
              ELSE IF GET('EPS,'KLIST) AND NOT FLAGP(L,'NOSPUR)
               THEN ISIMP1(MULTFS(N,Z),I,V1,V2,V3)
              ELSE MULTFS(Z,ISIMP1(N,I,V1,V2,V3))
   END;

SYMBOLIC PROCEDURE SPUR0I(U,I,V1,V2,V3,L,N,W,Z); 
   BEGIN SCALAR KAHP,I1; 
      IF FLAGP(L,'NOSPUR) AND FLAGP(CAR Z,'NOSPUR)
	THEN ERRACH "This NOSPUR option not implemented"
       ELSE IF FLAGP(CAR Z,'NOSPUR) THEN KAHP := CAR Z; 
      Z := CDR Z; 
      I1 := CAR Z; 
      Z := REVERSE CDR Z; 
      IF I1 THEN Z := 'A . Z; 
      I1 := NIL; 
      <<WHILE NULL (CAR U EQ CAR Z) DO 
           <<I1 := CAR Z . I1; Z := CDR Z>>; 
        Z := CDR Z; 
        U := CDR U; 
        IF FLAGP(L,'NOSPUR)
          THEN <<W := W . (U . (I1 . Z)); 
                 I1 := CAR W; 
                 Z := CADR W; 
                 U := CADDR W; 
                 W := CDDDR W>>; 
        W := REVERSE W; 
        IF NULL ((NULL U OR NOT EQCAR(W,'A)) AND (U := APPEND(U,W)))
          THEN <<IF NOT HEVENP U THEN N :=  - N; 
                 U := 'A . APPEND(U,CDR W)>>; 
        IF KAHP THEN L := KAHP; 
        Z := 
         MKF(MKG(REVERSE I1,L),
             MULTF(BRACE(U,L,I),MULTFS(N,MKG1(Z,L)))); 
        Z := ISIMP1(Z,I,V1,V2,V3); 
        IF NULL Z OR (Z := QUOTF(Z,2)) THEN RETURN Z
         ELSE ERRACH LIST('SPUR0,N,I,V1,V2,V3)>>
   END;

SYMBOLIC PROCEDURE SPURDIM(U,I,L,V,N);
   BEGIN SCALAR W,X,Y,Z,Z1; INTEGER M;
    A:	IF NULL U
	  THEN RETURN IF NULL V THEN N
		ELSE IF FLAGP(L,'NOSPUR) THEN MULTFS(N,MKGF(V,L))
		ELSE MULTFS(N,SPRGEN V)
	 ELSE IF NOT(CAR U MEMQ CDR U)
	  THEN <<V := CAR U . V; U := CDR U; GO TO A>>;
	X := CAR U;
	Y := CDR U;
	W := Y;
	M := 1;
    B:	IF X MEMQ I THEN GO TO D
	 ELSE IF NOT X EQ CAR W THEN GO TO C
	 ELSE IF NULL(W := MKDOT(X,X)) THEN RETURN Z;
	IF X MEMQ I THEN W := NDIMS!*;
	RETURN ADDFS(MKF(W,SPURDIM(DELETE(X,Y),I,L,V,N)),Z);
    C:	Z1 := MKDOT(X,CAR W);
	IF CAR W MEMQ I
	  THEN Z := ADDFS(SPURDIM(SUBST(X,CAR W,REMOVE(Y,M)),
				  I,L,V,2*N),Z)
	 ELSE IF Z1
	  THEN Z := ADDFS(MKF(Z1,SPURDIM(REMOVE(Y,M),I,L,V,2*N)),Z);
	W := CDR W;
	N := -N;
	M := M+1;
	GO TO B;
   D:	WHILE NOT(X EQ CAR W) DO
	 <<Z:= ADDFS(SPURDIM(SUBST(CAR W,X,REMOVE(Y,M)),I,L,V,2*N),Z);
	   W := CDR W;
	   N := -N;
	   M := M+1>>;
	RETURN ADDFS(MKF(NDIMS!*,SPURDIM(DELETE(X,Y),I,L,V,N)),Z)
   END;

SYMBOLIC PROCEDURE APPN(U,N);
   IF N=1 THEN U ELSE APPEND(U,APPN(U,N-1));

SYMBOLIC PROCEDURE OTHER(U,V);
   IF U EQ CAR V THEN CDR V ELSE CAR V;

SYMBOLIC PROCEDURE KAHANE(U,I,L);
   %The Kahane algorithm for Dirac matrix string reduction
   %Ref: Kahane, J., Journ. Math. Phys. 9 (1968) 1732-1738;
   BEGIN SCALAR P,R,V,W,X,Y,Z; INTEGER K,M;
	K := 0;
    MARK:
	IF EQCAR(U,'A) THEN GO TO A1;
    A:	P := NOT P;		%vector parity;
	IF NULL U THEN GO TO D ELSE IF CAR U MEMBER I THEN GO TO C;
    A1: W := ACONC(W,CAR U);
    B:	U := CDR U;
	GO TO A;
    C:	Y := CAR U . P;
	Z := (X . (Y . W)) . Z;
	X := Y;
	W := NIL;
	K := K+1;
	GO TO B;
    D:	Z := (NIL . (X . W)) . Z;
	%BEWARE ... END OF STRING HAS OPPOSITE CONVENTION;
    PASS2:
	M := 1;
    L1: IF NULL Z THEN GO TO L9;
	U := CAAR Z;
	X := CADAR Z;
	W := CDDAR Z;
	Z := CDR Z;
	M := M+1;
	IF NULL U THEN GO TO L2
	 ELSE IF (CAR U EQ CAR X) AND EXC(X,CDR U) THEN GO TO L7;
	W := REVERSE W;
	R := T;
    L2: P := NOT EXC(X,R);
	X := CAR X;
	Y := NIL;
    L3: IF NULL Z
	  THEN REDERR("Unmatched index" .
	         IF Y THEN IF NOT ATOM CADAR Y THEN CADAR Y
			    ELSE IF NOT ATOM CAAR Y THEN CAAR Y
		  ELSE NIL
		ELSE NIL)
	  ELSE IF (X EQ CAR (I := CADAR Z)) AND NOT EXC(I,P)
	   THEN GO TO L5
	  ELSE IF (X EQ CAR (I := CAAR Z)) AND EXC(I,P) THEN GO TO L4;
	Y := CAR Z . Y;
	Z := CDR Z;
	GO TO L3;
    L4: X := CADAR Z;
	W := APPR(CDDAR Z,W);
	R := T;
	GO TO L6;
    L5: X := CAAR Z;
	W := APPEND(CDDAR Z,W);
	R := NIL;
    L6: Z := APPR(Y,CDR Z);
	IF NULL X THEN GO TO L8
	 ELSE IF NOT EQCAR(U,CAR X) THEN GO TO L2;
    L7: IF W AND CDR U THEN W := ACONC(CDR W,CAR W);
	V := MULTFS(BRACE(W,L,NIL),V);	%V := ('BRACE . L . W) . V;
	GO TO L1;
    L8: V := MKG(W,L);			%V := LIST('G . L . W);
	Z := REVERSE Z;
	K := K/2;
	GO TO L1;
    L9: U := 2**K;
	IF NOT (REMAINDER(K-M,2) = 0) THEN U :=  - U;
	RETURN MULTD!*(U,V)		%RETURN 'TIMES . U . V;
   END;

SYMBOLIC PROCEDURE APPR(U,V);
   IF NULL U THEN V ELSE APPR(CDR U,CAR U . V);

SYMBOLIC PROCEDURE EXC(U,V);
   IF NULL CDR U THEN V ELSE NOT V;

SYMBOLIC PROCEDURE BRACE(U,L,I);
   IF NULL U THEN 2
    ELSE IF XNP(I,U) OR FLAGP(L,'NOSPUR)
     THEN ADDF(MKG1(U,L),MKG1(REVERSE U,L))
    ELSE IF CAR U EQ 'A
       THEN IF HEVENP U THEN ADDFS(MKG(U,L),
				 NEGF MKG('A . REVERSE CDR U,L))
	     ELSE MKF(MKA L,SPR2(CDR U,L,2,NIL))
    ELSE IF HEVENP U THEN SPR2(U,L,2,NIL)
    ELSE SPR1(U,L,2,NIL);

SYMBOLIC PROCEDURE SPR1(U,L,N,B);
   IF NULL U THEN NIL
    ELSE IF NULL CDR U THEN MULTD!*(N,MKG1(U,L))
    ELSE BEGIN SCALAR M,X,Z;
	       X := U;
	       M := 1;
	  A:   IF NULL X THEN RETURN Z;
	       Z:= ADDFS(MKF(MKG1(LIST CAR X,L),
			      IF NULL B THEN SPURR(REMOVE(U,M),L,NIL,N)
			       ELSE SPR1(REMOVE(U,M),L,N,NIL)),
			 Z);
	       X := CDR X;
	       N :=  - N;
	       M := M+1;
	       GO TO A
    END;

SYMBOLIC PROCEDURE SPR2(U,L,N,B);
   IF NULL CDDR U AND NULL B THEN MULTD!*(N,MKDOT(CAR U,CADR U))
    ELSE (LAMBDA X; IF B THEN ADDFS(SPR1(U,L,N,B),X) ELSE X)
       ADDFS(SPURR(U,L,NIL,N),
	     MKF(MKA L,SPURR(APPEND(U,LIST 'A),L,NIL,N)));

SYMBOLIC PROCEDURE HEVENP U;
   NULL U OR NOT HEVENP CDR U;

SYMBOLIC PROCEDURE BASSOC(U,V);
   IF NULL V THEN NIL
    ELSE IF U EQ CAAR V OR U EQ CDAR V THEN CAR V
    ELSE BASSOC(U,CDR V);

SYMBOLIC PROCEDURE MEMLIS(U,V);
   IF NULL V THEN NIL
    ELSE IF U MEMBER CAR V THEN CAR V
    ELSE MEMLIS(U,CDR V);

SYMBOLIC PROCEDURE SPURR(U,L,V,N);
   BEGIN SCALAR W,X,Y,Z,Z1; INTEGER M;
    A:	IF NULL U THEN GO TO B
	 ELSE IF CAR U MEMBER CDR U THEN GO TO G;
	V := CAR U . V;
	U := CDR U;
	GO TO A;
    B:	RETURN IF NULL V THEN N
	 ELSE IF FLAGP(L,'NOSPUR) THEN MULTD!*(N,MKGF(V,L))
	 ELSE MULTD!*(N,SPRGEN V);
    G:	X := CAR U;
	Y := CDR U;
	W := Y;
	M := 1;
    H:	IF NOT X EQ CAR W THEN GO TO H1
	 ELSE IF NULL(W:= MKDOT(X,X)) THEN RETURN Z
	 ELSE RETURN ADDFS(MKF(W,SPURR(DELETE(X,Y),L,V,N)),Z);
    H1: Z1 := MKDOT(X,CAR W);
	IF Z1 THEN Z:= ADDFS(MKF(Z1,SPURR(REMOVE(Y,M),L,V,2*N)),Z);
	W := CDR W;
	N :=  - N;
	M := M+1;
	GO TO H
   END;

SYMBOLIC PROCEDURE SPRGEN V;
   BEGIN SCALAR X,Y,Z;
	IF NOT (CAR V EQ 'A) THEN RETURN SPRGEN1(V,T)
	 ELSE IF NULL (X := COMB(V := CDR V,4)) THEN RETURN NIL
	 ELSE IF NULL CDR X THEN GO TO E;
    C:	IF NULL X THEN RETURN MULTPF('I TO 1,Z);
	Y := MKEPSF CAR X;
	IF ASIGN(CAR X,V,1)=-1 THEN Y := NEGF Y;
	Z := ADDF(MULTF(Y,SPRGEN1(SETDIFF(V,CAR X),T)),Z);
    D:	X := CDR X;
	GO TO C;
    E:	Z := MKEPSF CAR X;
	GO TO D
   END;

SYMBOLIC PROCEDURE ASIGN(U,V,N);
   IF NULL U THEN N ELSE ASIGN(CDR U,V,ASIGN1(CAR U,V,-1)*N);

SYMBOLIC PROCEDURE ASIGN1(U,V,N);
   IF U EQ CAR V THEN N ELSE ASIGN1(U,CDR V,-N);

SYMBOLIC PROCEDURE SPRGEN1(U,B);
   IF NULL U THEN NIL
    ELSE IF NULL CDDR U THEN (LAMBDA X; IF B THEN X ELSE NEGF X)
				MKDOT(CAR U,CADR U)
    ELSE BEGIN SCALAR W,X,Y,Z;
	       X := CAR U;
	       U := CDR U;
	       Y := U;
	  A:   IF NULL U THEN RETURN Z
		ELSE IF NULL(W:= MKDOT(X,CAR U)) THEN GO TO C;
	       Z := ADDF(MULTF(W,SPRGEN1(DELETE(CAR U,Y),B)),Z);
	  C:   B := NOT B;
	       U := CDR U;
	       GO TO A
    END;

%*********************************************************************
%		     FUNCTIONS FOR EPSILON ALGEBRA
%********************************************************************;


PUT('EPS,'SIMPFN,'SIMPEPS);

SYMBOLIC PROCEDURE MKEPSF U;
   (LAMBDA X; (LAMBDA Y; IF NULL CAR X THEN NEGF Y ELSE Y) MKSF CDR X)
	MKEPSK U;

SYMBOLIC PROCEDURE ESUM(U,I,V,W,X);
   BEGIN SCALAR Y,Z,Z1;
	Z := CAR U;
	U := CDR U;
	IF CDR Z NEQ 1
	 THEN U := MULTF(EXPTF(MKEPSF CDAR Z,CDR Z-1),U);
	Z := CDAR Z;
    A:	IF REPEATS Z THEN RETURN;
    B:	IF NULL Z THEN RETURN ISIMP1(U,I,V,REVERSE Y . W,X)
	 ELSE IF NOT (CAR Z MEMBER I) THEN GO TO D
	 ELSE IF NOT (Z1 := BASSOC(CAR Z,V)) THEN GO TO C;
	V := DELETE(Z1,V);
	I := DELETE(CAR Z,I);
	Z := APPEND(REVERSE Y,OTHER(CAR Z,Z1) . CDR Z);
	Y := NIL;
	GO TO A;
    C:	IF Z1 := MEMLIS(CAR Z,W) THEN GO TO C1
	 ELSE RETURN ISIMP1(U,I,V,APPEND(REVERSE Y,Z) . W,X);
    C1: Z := APPEND(REVERSE Y,Z);
	Y := XN(I,XN(Z,Z1));
	RETURN ISIMP1(MULTFS(EMULT1(Z1,Z,Y),U),
		      SETDIFF(I,Y),
		      V,
		      DELETE(Z1,W),
		      X);
    D:	Y := CAR Z . Y;
	Z := CDR Z;
	GO TO B
   END;

SYMBOLIC PROCEDURE EMULT U;
   IF NULL CDR U THEN MKEPSF CAR U
    ELSE IF NULL CDDR U THEN EMULT1(CAR U,CADR U,NIL)
    ELSE MULTFS(EMULT1(CAR U,CADR U,NIL),EMULT CDDR U);

SYMBOLIC PROCEDURE EMULT1(U,V,I);
   (LAMBDA (X,Y);
	 (LAMBDA (M,N);
	       IF M=4 THEN 24*N
		ELSE IF M=3 THEN MULTD(6*N,MKDOT(CAR X,CAR Y))
		ELSE MULTD!*(N*(IF M = 0 THEN 1 ELSE M),
			   CAR DETQ MAPLIST(X,
			     FUNCTION (LAMBDA K;
			       MAPLIST(Y,
				 FUNCTION (LAMBDA J;
				   MKDOT(CAR K,CAR J) . 1))))))
	    (LENGTH I,
	     (LAMBDA J; NB IF PERMP(U,APPEND(I,X)) THEN NOT J ELSE J)
		PERMP(V,APPEND(I,Y))))
      (SETDIFF(U,I),SETDIFF(V,I));


END;