reduce-historical/r30/alg2.red

%*********************************************************************
%*********************************************************************
%            REDUCE BASIC ALGEBRAIC PROCESSOR (PART 2)
%*********************************************************************
%********************************************************************;

%Copyright (c) 1983 The Rand Corporation;

SYMBOLIC;

COMMENT The following free variables are referenced in this module;

FLUID '(!*MCD);

GLOBAL '(ASYMPLIS!* FRLIS!* KORD!* MCHFG!* MCOND!* POWLIS!* POWLIS1!*
	 SPLIS!* SUBFG!* TYPL!* VARNAM!* WTL!* !*FLOAT !*FORT !*MATCH
	 !*NAT !*PRI !*RESUBS !*SUB2);


%*********************************************************************
%*********************************************************************
%      FUNCTIONS WHICH APPLY MORE GENERAL PATTERN MATCHING RULES
%*********************************************************************
%********************************************************************;

%*********************************************************************
%		     FUNCTIONS FOR MATCHING POWERS
%********************************************************************;

COMMENT Fluid variable used in this section;

FLUID '(!*STRUCTURE);

!*STRUCTURE := NIL;

COMMENT If STRUCTURE is ON, then expressions like (a**(b/2))**2 are not
simplified, to allow some attempt at a structure theorem use, especially
in the integrator;

SYMBOLIC PROCEDURE SUBS2Q U; QUOTSQ(SUBS2F NUMR U,SUBS2F DENR U);

SYMBOLIC PROCEDURE SUBS2F U;
   BEGIN SCALAR X;
	!*SUB2 := NIL;
	X := SUBS2F1 U;
	IF (!*SUB2 OR POWLIS1!*) AND !*RESUBS
	   THEN IF NUMR X=U AND DENR X=1 THEN !*SUB2 := NIL
		ELSE X := SUBS2Q X; RETURN X;
   END;

SYMBOLIC PROCEDURE SUBS2F1 U;
   IF DOMAINP U THEN !*D2Q U
    ELSE BEGIN SCALAR KERN,V,W,X,Y,Z;
	KERN := MVAR U;
	Z := NIL ./ 1;
    A:	IF NULL U OR DEGR(U,KERN)=0 THEN GO TO A1;
	Y := LT U .+ Y;
	U := RED U;
	GO TO A;
    A1: X := POWLIS!*;
    A2: IF NULL X THEN GO TO B
	 ELSE IF CAAAR Y = CAAR X
	  THEN <<W := SUBS2P(CAAR Y,CADAR X,CADDDR CAR X); GO TO E1>>
%	 ELSE IF EQCAR(KERN,'SQRT) AND CADR KERN = CAAR X
%	  THEN <<W := RADDSQ(SUBS2P(CADR KERN . CDAAR Y,
%			     CADAR X,CADDDR CAR X),2);% GO TO E1>>;
	 ELSE IF EQCAR(KERN,'EXPT)
		AND CADR KERN = CAAR X
		AND EQCAR(CADDR KERN,'QUOTIENT)
		AND CADR CADDR KERN = 1
		AND NUMBERP CADDR CADDR KERN
	  THEN <<V := DIVIDE(CDAAR Y,CADDR CADDR KERN);
		 IF CAR V NEQ 0 THEN W := MKSQ(CADR KERN,CAR V)
		  ELSE W := 1 ./ 1;
		 IF CDR V NEQ 0
		   THEN <<V := CANCEL(CDR V.CADDR CADDR KERN);
			 W := MULTSQ(RADDSQ(SUBS2P(CADR KERN . CAR V,
				     	CADAR X,CADDDR CAR X),
			      	CDR V),W)>>;
		 GO TO E1>>;
	X := CDR X;
	GO TO A2;
    B:	X := POWLIS1!*;
    L2: IF NULL X THEN GO TO L3
	 ELSE IF W:= MTCHP(CAAR Y,CAAR X,CADDAR X,CAADAR X,CDADAR X)
	  THEN GO TO E1;
	X := CDR X;
	GO TO L2;
    L3: IF EQCAR(KERN,'EXPT) AND NOT !*STRUCTURE THEN GO TO L1;
	Z := ADDSQ(MULTPQ(CAAR Y,SUBS2F1 CDAR Y),Z);
    C:	Y := CDR Y;
	IF Y THEN GO TO A1;
    D:	RETURN ADDSQ(Z,SUBS2F1 U);
    E1: Z := ADDSQ(MULTSQ(W,SUBS2F1 CDAR Y),Z);
	GO TO C;
    L1: IF ONEP CDAAR Y THEN W := MKSQ(KERN,1)
	 ELSE W := SIMPEXPT LIST(CADR KERN,
				 LIST('TIMES,CADDR KERN,CDAAR Y));
	Z := ADDSQ(MULTSQ(W,SUBS2F1 CDAR Y),Z);
	Y := CDR Y;
	IF Y THEN GO TO L1 ELSE GO TO D;
    END;

SYMBOLIC PROCEDURE SUBS2P(U,V,W);
   %U is a power, V an integer, and W an algebraic expression, such
   %that CAR U**V=W. Value is standard quotient for U with this
   %substitution;
   BEGIN 
      V := DIVIDE(CDR U,V);
      IF CAR V=0 THEN RETURN !*P2Q U;
      W := EXPTSQ(SIMP W,CAR V);
      RETURN IF CDR V=0 THEN W ELSE MULTPQ(CAR U TO CDR V,W)
   END;

SYMBOLIC PROCEDURE RADDSQ(U,N);
   %U is a standard quotient, N and integer. Value is sq for U**(1/N);
   SIMPEXPT LIST(MK!*SQ U,LIST('QUOTIENT,1,N));

SYMBOLIC PROCEDURE MTCHP(U,V,W,FLG,BOOL);
   %U is a standard power, V a power to be matched against.
   %W is the replacement expression.
   %FLG is a flag which is T if an exact power match required.
   %BOOL is a boolean expression to be satisfied for substitution.
   %Value is the substitution standard quotient if a match found,
   %NIL otherwise;
   BEGIN SCALAR X;
	X := MTCHP1(U,V,FLG,BOOL);
    A:	IF NULL X THEN RETURN NIL
	 ELSE IF EVAL SUBLA(CAR X,BOOL) THEN GO TO B;
	X := CDR X;
	GO TO A;
    B:	V := DIVIDE(CDR U,SUBLA(CAR X,CDR V));
	W := EXPTSQ(SIMP SUBLA(CAR X,W),CAR V);
	IF CDR V NEQ 0 THEN W := MULTPQ(CAR U TO CDR V,W);
	RETURN W
   END;

SYMBOLIC PROCEDURE MTCHP1(U,V,FLG,BOOL);
   %U is a standard power, V a power to be matched against.
   %FLG is a flag which is T if an exact power match required.
   %BOOL is a boolean expression to be satisfied for substitution.
   %Value is a list of possible free variable pairings which
   %match conditions;
   BEGIN SCALAR X;
	IF U=V THEN RETURN LIST NIL
	 ELSE IF NOT (X:= MCHK(CAR U,CAR V)) THEN RETURN NIL
	 ELSE IF CDR V MEMQ FRLIS!*
	  THEN RETURN MAPCONS(X,CDR V . CDR U)
	 ELSE IF (FLG AND NOT CDR U=CDR V)
		OR (IF !*MCD THEN CDR U<CDR V
		     ELSE (CDR U*CDR V)<0 OR
			%implements explicit sign matching;
			    ABS CDR U<ABS CDR V)
	  THEN RETURN NIL
	 ELSE RETURN X
   END;


%*********************************************************************
%		    FUNCTIONS FOR MATCHING PRODUCTS
%********************************************************************;

SYMBOLIC PROCEDURE SUBS3Q U;
   %U is a standard quotient.
   %Value is a standard quotient with all product substitutions made;
   BEGIN SCALAR X;
	X := MCHFG!*;	%save value in case we are in inner loop;
	MCHFG!* := NIL;
	U := QUOTSQ(SUBS3F NUMR U,SUBS3F DENR U);
	MCHFG!* := X;
	RETURN U
   END;

SYMBOLIC PROCEDURE SUBS3F U;
   %U is a standard form.
   %Value is a standard quotient with all product substitutions made;
   SUBS3F1(U,!*MATCH,T);

SYMBOLIC PROCEDURE SUBS3F1(U,L,BOOL);
   %U is a standard form.
   %L is a list of possible matches.
   %BOOL is a boolean variable which is true if we are at top level.
   %Value is a standard quotient with all product substitutions made;
   BEGIN SCALAR X,Z;
	Z := NIL ./ 1;
    A:	IF NULL U THEN RETURN Z
	 ELSE IF DOMAINP U THEN RETURN ADDSQ(Z,U ./ 1)
	 ELSE IF BOOL AND DOMAINP LC U THEN GO TO C;
	X := SUBS3T(LT U,L);
	IF NOT BOOL				%not top level;
	 OR NOT MCHFG!* THEN GO TO B;		%no replacement made;
	MCHFG!* := NIL;
	IF NULL !*RESUBS THEN GO TO B
	 ELSE IF !*SUB2 OR POWLIS1!* THEN X := SUBS2Q X;
	   %make another pass;
	X := SUBS3Q X;
    B:	Z := ADDSQ(Z,X);
	U := CDR U;
	GO TO A;
    C:	X := LIST LT U ./ 1;
	GO TO B
   END;

SYMBOLIC PROCEDURE SUBS3T(U,V);
   %U is a standard term, V a list of matching templates.
   %Value is a standard quotient for the substituted term;
   BEGIN SCALAR X,Y,Z;
	X := MTCHK(CAR U,IF DOMAINP CDR U THEN SIZCHK(V,1) ELSE V);
	IF NULL X THEN GO TO A			%lpow doesn't match;
	 ELSE IF NULL CAAR X THEN GO TO B;	%complete match found;
	Y := SUBS3F1(CDR U,X,NIL);		%check tc for match;
	IF MCHFG!* THEN RETURN MULTPQ(CAR U,Y);
    A:	RETURN LIST U . 1;			%no match;
    B:	X := CDDAR X;		%list(<subst value>,<denoms>);
	Z := CAADR X;		%leading denom;
	MCHFG!* := NIL; 	%initialize for tc check;
	Y := SUBS3F1(CDR U,!*MATCH,NIL);
	MCHFG!* := T;
	IF CAR Z NEQ CAAR U THEN GO TO E
	 ELSE IF Z NEQ CAR U	%powers don't match;
	  THEN Y := MULTPQ(CAAR U TO (CDAR U-CDR Z),Y);
    B1: Y := MULTSQ(SIMPCAR X,Y);
	X := CDADR X;
	IF NULL X THEN RETURN Y;
	Z := 1; 		%unwind remaining denoms;
    C:	IF NULL X THEN GO TO D;
	Z:=LIST(MKSP(CAAR X,
      %was IF ATOM CAAR X OR SFP CAAR X THEN CAAR X ELSE REVOP1 CAAR X;
			IF !*MCD THEN CDAR X ELSE -CDAR X) . Z);
	%kernel CAAR X is not unique here;
	X := CDR X;
	GO TO C;
    D:	RETURN IF !*MCD THEN CAR Y . MULTF(Z,CDR Y)
		ELSE MULTF(Z,CAR Y) . CDR Y;
    E:	IF SIMP CAR Z NEQ SIMP CAAR U THEN ERRACH LIST('SUBS3T,U,X,Z);
	%maybe arguments were in different order, otherwise it's fatal;
	IF CDR Z NEQ CDAR U
	  THEN Y:= MULTPQ(CAAR U TO (CDAR U-CDR Z),Y);
	GO TO B1
   END;

SYMBOLIC PROCEDURE SIZCHK(U,N);
   IF NULL U THEN NIL
    ELSE IF LENGTH CAAR U>N THEN SIZCHK(CDR U,N)
    ELSE CAR U . SIZCHK(CDR U,N);

SYMBOLIC PROCEDURE MTCHK(U,V);
   %U is a standard power, V a list of matching templates.
   %If a match is made, value is of the form:
   %list list(NIL,<boolean form>,<subst value>,<denoms>),
   %otherwise value is an updated list of templates;
   BEGIN SCALAR FLG,V1,W,X,Y,Z;
	FLG := NONCOMP CAR U;
    A0: IF NULL V THEN RETURN Z;
	V1 := CAR V;
	W := CAR V1;
    A:	IF NULL W THEN GO TO D;
	X := MTCHP1(U,CAR W,CAADR V1,CDADR V1);
    B:	IF NULL X THEN GO TO C
	 ELSE IF CAR (Y := SUBLA(CAR X,DELETE(CAR W,CAR V1))
				. LIST(SUBLA(CAR X,CADR V1),
				      SUBLA(CAR X,CADDR V1),
				      SUBLA(CAR X,CAR W)
					  . CADDDR V1))
	  THEN Z := Y . Z
	 ELSE IF EVAL SUBLA(CAR X,CDADR V1) THEN RETURN LIST Y;
	X := CDR X;
	GO TO B;
    C:	IF FLG THEN GO TO C1;
	W := CDR W;
	GO TO A;
    C1: IF CADDDR V1 AND NOT NOCP CADDDR V1 THEN GO TO E;
    D:	Z := APPEND(Z,LIST V1);
    E:	V := CDR V;
	GO TO A0
   END;

SYMBOLIC PROCEDURE NOCP U;
   NULL U OR (NONCOMP CAAR U AND NOCP CDR U);


%*********************************************************************
%		      FUNCTIONS FOR MATCHING SUMS
%********************************************************************;

SYMBOLIC PROCEDURE SUBS4Q U;
   QUOTSQ(SUBS4F NUMR U,SUBS4F DENR U);

SYMBOLIC PROCEDURE SUBS4F U;
   BEGIN SCALAR W,X,Y,Z;
      X := SPLIS!*;
    A:	IF NULL X THEN RETURN U ./ 1;
	W := LQREMF!*(U,CAAR X);
	IF NULL CDR W THEN <<X := CDR X; GO TO A>>;
	X := SIMP CADDAR X;
	Y := 1 ./ 1;
	Z := NIL ./ 1;
	WHILE W DO
	 <<IF CAR W THEN Z := ADDSQ(MULTSQ(CAR W ./ 1,Y),Z);
	   Y := MULTSQ(X,Y);
	   W := CDR W>>;
	RETURN IF DENR Z=1 AND NUMR Z=U THEN U ./ 1 ELSE SUBS4Q Z;
	%one could test on size here and only change if smaller;
   END;

SYMBOLIC PROCEDURE LQREMF!*(U,V);
   IF DOMAINP U THEN LIST U ELSE LQREMF(U,REORDER V);


%*********************************************************************
%*********************************************************************
%		EXTENDED OUTPUT PACKAGE FOR EXPRESSIONS
%*********************************************************************
%********************************************************************;

%Global variables used in this Section;

GLOBAL '(DNL!* FACTORS!* ORDL!* UPL!* !*ALLFAC !*DIV !*RAT);

DNL!* := NIL;		%output control flag: puts powers in denom;
FACTORS!* := NIL;	%list of output factors;
ORDL!* := NIL;		%list of kernels introduced by ORDER statement;
UPL!* := NIL;		%output control flag: puts denom powers in
			%numerator;
!*ALLFAC := T;		%factoring option for this package;
!*DIV := NIL;		%division option in this package;
!*RAT := NIL;		%flag indicating rational mode for output;

!*PRI := T;		%to activate this package;

SYMBOLIC PROCEDURE FACTOR U;
   FACTOR1(U,T,'FACTORS!*);

SYMBOLIC PROCEDURE FACTOR1(U,V,W);
   BEGIN SCALAR X,Y;
	Y := EVAL W;
	FOR EACH J IN U DO
	 <<X := !*A2K J;
	   IF V THEN Y := ACONC(DELETE(X,Y),X)
	    ELSE IF NOT X MEMBER Y
	     THEN MSGPRI(NIL,J,"not found",NIL,NIL)
	    ELSE Y := DELETE(X,Y)>>;
	SET(W,Y)
   END;

SYMBOLIC PROCEDURE REMFAC U;
   FACTOR1(U,NIL,'FACTORS!*);

RLISTAT '(FACTOR REMFAC);

SYMBOLIC PROCEDURE ORDER U;
   IF U AND NULL CAR U AND NULL CDR U THEN (ORDL!* := NIL)
    ELSE FOR EACH X IN U DO
      <<IF (X := !*A2K X) MEMBER ORDL!* THEN ORDL!* := DELETE(X,ORDL!*);
	ORDL!* := ACONC(ORDL!*,X)>>;

RLISTAT '(ORDER);

SYMBOLIC PROCEDURE UP U;
   FACTOR1(U,T,'UPL!*);

SYMBOLIC PROCEDURE DOWN U;
   FACTOR1(U,T,'DNL!*);

RLISTAT '(UP DOWN);

SYMBOLIC PROCEDURE FORMOP U;
   IF DOMAINP U THEN U
    ELSE RADDF(MULTOP(LPOW U,FORMOP LC U),FORMOP RED U);

SYMBOLIC PROCEDURE MULTOP(U,V);
   IF NULL KORD!* THEN MULTPF(U,V)
    ELSE IF CAR U EQ 'K!* THEN V
    ELSE RMULTPF(U,V);

SYMBOLIC SMACRO PROCEDURE LCX U;
   %returns leading coefficient of a form with zero reductum, or an
   %error otherwise;
   CDR CARX U;

SYMBOLIC PROCEDURE QUOTOF(P,Q);
   %P is a standard form, Q a standard form which is either a domain
   %element or has zero reductum.
   %returns the quotient of P and Q for output purposes;
   IF NULL P THEN NIL
    ELSE IF P=Q THEN 1
    ELSE IF Q=1 THEN P
    ELSE IF DOMAINP Q THEN QUOTOFD(P,Q)
    ELSE IF DOMAINP P
     THEN MKSP(MVAR Q,-LDEG Q) .* QUOTOF(P,LCX Q) .+ NIL
    ELSE (LAMBDA (X,Y);
	  IF CAR X EQ CAR Y
	      THEN (LAMBDA (N,W,Z);
		 IF N=0 THEN RADDF(W,Z)
		  ELSE ((CAR Y TO N) .* W) .+ Z)
	      (CDR X-CDR Y,QUOTOF(LC P,LCX Q),QUOTOF(RED P,Q))
	   ELSE IF ORDOP(CAR X,CAR Y)
	      THEN (X .* QUOTOF(LC P,Q)) .+ QUOTOF(RED P,Q)
	   ELSE MKSP(CAR Y,- CDR Y) .* QUOTOF(P,LCX Q) .+ NIL)
       (LPOW P,LPOW Q);

SYMBOLIC PROCEDURE QUOTOFD(P,Q);
   %P is a form, Q a domain element. Value is quotient of P and Q
   %for output purposes;
   IF NULL P THEN NIL
    ELSE IF DOMAINP P THEN QUOTODD(P,Q)
    ELSE (LPOW P .* QUOTOFD(LC P,Q)) .+ QUOTOFD(RED P,Q);

SYMBOLIC PROCEDURE QUOTODD(P,Q);
   %P and Q are domain elements. Value is domain element for P/Q;
   IF ATOM P AND ATOM Q THEN MKRN(P,Q) ELSE LOWEST!-TERMS(P,Q);

SYMBOLIC PROCEDURE LOWEST!-TERMS(U,V);
   %reduces compatible domain elements U and V to a ratio in lowest
   %terms.  Value as a rational may contain domain arguments rather than
   %just integers;
   IF FLAGP(CAR V,'FIELD) OR FLAGP(CAR U,'FIELD)
     THEN MULTDM(U,!:EXPT(V,-1))
     ELSE BEGIN SCALAR X;
      X := DCOMBINE(U,V,'GCD);
      U := DCOMBINE(U,X,'QUOTIENT);
      V := DCOMBINE(V,X,'QUOTIENT);
      RETURN IF !:ONEP V THEN U ELSE '!:RN!: . (U . V)
   END;

SYMBOLIC PROCEDURE CKRN U;
   BEGIN SCALAR X;
	IF DOMAINP U THEN RETURN U;
    A:	X := GCK2(CKRN CDAR U,X);
	IF NULL CDR U
	  THEN RETURN IF NONCOMP MVAR U THEN X ELSE LIST(CAAR U . X)
	 ELSE IF DOMAINP CDR U OR NOT CAAAR U EQ CAAADR U
	  THEN RETURN GCK2(CKRN CDR U,X);
	U := CDR U;
	GO TO A
   END;

SYMBOLIC PROCEDURE GCK2(U,V);
   %U and V are domain elements or forms with a zero reductum.
   %Value is the gcd of U and V;
   IF NULL V THEN U
    ELSE IF U=V THEN U
    ELSE IF DOMAINP U THEN IF DOMAINP V THEN GCDDD(U,V)
	ELSE GCK2(U,CDARX V)
    ELSE IF DOMAINP V THEN GCK2(CDARX U,V)
    ELSE (LAMBDA (X,Y);
	IF CAR X EQ CAR Y
	  THEN LIST((IF CDR X>CDR Y THEN Y ELSE X) .
		    GCK2(CDARX U,CDARX V))
	 ELSE IF ORDOP(CAR X,CAR Y) THEN GCK2(CDARX U,V)
	 ELSE GCK2(U,CDARX V))
    (CAAR U,CAAR V);

SYMBOLIC PROCEDURE CDARX U;
   CDR CARX U;

SYMBOLIC PROCEDURE PREPSQ!* U;
   BEGIN SCALAR X;
	IF NULL NUMR U THEN RETURN 0;
	X := KORD!*;
	KORD!* := APPEND((FOR EACH J IN FACTORS!*
		     CONC IF NOT IDP J THEN NIL
			   ELSE FOR EACH K IN GET(J,'KLIST)
				     COLLECT CAR K),
		   APPEND(FACTORS!*,ORDL!*));
	IF KORD!* NEQ X OR WTL!*
	  THEN U := FORMOP NUMR U . FORMOP DENR U;
	U := IF !*RAT OR (NOT !*FLOAT AND !*DIV) OR UPL!* OR DNL!*
	       THEN REPLUS PREPSQ!*1(NUMR U,DENR U,NIL)
	      ELSE SQFORM(U,FUNCTION(LAMBDA J;
			    REPLUS PREPSQ!*1(J,1,NIL)));
	KORD!* := X;
	RETURN U
   END;

SYMBOLIC PROCEDURE PREPSQ!*0(U,V);
   %U is a standard quotient, but not necessarily in lowest terms.
   %V a list of factored powers;
   %Value is equivalent list of prefix expressions (an implicit sum);
   BEGIN SCALAR X;
      RETURN IF NULL NUMR U THEN NIL
 	      ELSE IF (X := GCDF(NUMR U,DENR U)) NEQ 1
        THEN PREPSQ!*1(QUOTF(NUMR U,X),QUOTF(DENR U,X),V)
       ELSE PREPSQ!*1(NUMR U,DENR U,V)
   END;

SYMBOLIC PROCEDURE PREPSQ!*1(U,V,W);
   %U and V are the numerator and denominator expression resp,
   %in lowest terms.
   %W is a list of powers to be factored from U;
   BEGIN SCALAR X,Y,Z;
	%look for "factors" in the numerator;
	IF NOT DOMAINP U AND (MVAR U MEMBER FACTORS!* OR (NOT
		ATOM MVAR U AND CAR MVAR U MEMBER FACTORS!*))
	  THEN RETURN NCONC(IF V=1 THEN PREPSQ!*0(LC U ./ V,LPOW U . W)
		ELSE (BEGIN SCALAR N,V1,Z1;
		%see if the same "factor" appears in denominator;
		N := LDEG U;
		V1 := V;
		Z1 := !*K2F MVAR U;
		WHILE (Z := QUOTF(V1,Z1))
		   DO <<V1 := Z; N := N-1>>;
		RETURN
		  PREPSQ!*0(LC U ./ V1,
			    IF N>0 THEN (MVAR U .** N) . W
			     ELSE IF N<0
			      THEN MKSP(LIST('EXPT,MVAR U,N),1) . W
			     ELSE W)
		   END),
			PREPSQ!*0(RED U ./ V,W));
	%now see if there are any remaining "factors" in denominator
	%(KORD!* contains all potential kernel factors);
	IF NOT DOMAINP V
	 THEN FOR EACH J IN KORD!* DO
	   BEGIN INTEGER N; SCALAR Z1;
		N := 0;
		Z1 := !*K2F J;
		WHILE Z := QUOTF(V,Z1) DO <<N := N-1; V := Z>>;
		IF N<0 THEN W := MKSP(LIST('EXPT,J,N),1) . W
           END;
	%now all "factors" have been removed;
	IF KERNLP U THEN <<U := MKKL(W,U); W := NIL>>;
	IF DNL!*
	  THEN <<X := IF NULL !*ALLFAC THEN 1 ELSE CKRN U;
		 Z := CKRN!*(X,DNL!*);
		 X := QUOTOF(X,Z);
		 U := QUOTOF(U,Z);
		 V := QUOTOF(V,Z)>>;
	Y := CKRN V;
	IF UPL!*
	  THEN <<Z := CKRN!*(Y,UPL!*);
		 Y := QUOTOF(Y,Z);
		 U := QUOTOF(U,Z);
		 V := QUOTOF(V,Z)>>;
	IF NULL !*DIV AND NULL !*FLOAT THEN Y := 1;
	U := CANONSQ (U . QUOTOF(V,Y));
%	IF !*GCD THEN U := CANCEL U;
	U := QUOTOF(NUMR U,Y) ./ DENR U;
	IF NULL !*ALLFAC THEN X := 1 ELSE X := CKRN NUMR U;
	IF !*ALLFAC AND X NEQ CAR U THEN GO TO B
	 ELSE IF W THEN <<W := EXCHK(W,NIL,NIL); GO TO C>>;
    D:	U := PREPSQ U;
	RETURN IF EQCAR(U,'PLUS) THEN CDR U ELSE LIST U;
    B:	IF ONEP X AND NULL W THEN GO TO D
	 ELSE IF !*FLOAT THEN X := QUOTOF(X,KERNLP X);
	U := QUOTOF(NUMR U,X) . DENR U;
	W := PREPF MKKL(W,X);
	IF U = (1 ./ 1) THEN RETURN W
	 ELSE IF EQCAR(W,'TIMES) THEN W := CDR W
	 ELSE W := LIST W;
    C:	RETURN LIST RETIMES ACONC(W,PREPSQ U)
   END;

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

SYMBOLIC PROCEDURE CKRN!*(U,V);
   IF NULL U THEN ERRACH 'CKRN!*
    ELSE IF DOMAINP U THEN 1
    ELSE IF CAAAR U MEMBER V
       THEN LIST (CAAR U . CKRN!*(CDR CARX U,V))
    ELSE CKRN!*(CDR CARX U,V);


COMMENT Procedures for printing the structure of expressions;

FLUID '(COUNTR VAR VARLIS);

SYMBOLIC PROCEDURE STRUCTR U;
   BEGIN SCALAR COUNTR,FVAR,VAR,VARLIS;
      %VARLIS is a list of elements of form:
      %(<unreplaced expression> . <newvar> . <replaced exp>);
      COUNTR :=0;
      FVAR := VAR := VARNAM!*;
      IF CDR U THEN FVAR := CADR U;
      U := SIMPCAR U;
      U := STRUCTF NUMR U./ STRUCTF DENR U;
      IF NULL !*FORT THEN MATHPRINT MK!*SQ U;
	IF COUNTR=0 AND NULL !*FORT THEN RETURN NIL;
      IF NULL !*FORT THEN <<IF NULL !*NAT THEN TERPRI();
			    PRIN2T "   WHERE">>
       ELSE VARLIS := REVERSIP VARLIS;
      FOR EACH X IN VARLIS DO
	 <<TERPRI!* T;
	   IF NULL !*FORT THEN PRIN2!* "      ";
	     VARPRI(CDDR X,LIST MKQUOTE CADR X,T)>>;
      IF !*FORT THEN VARPRI(MK!*SQ U,LIST MKQUOTE FVAR,T)
   END;

RLISTAT '(STRUCTR);

SYMBOLIC PROCEDURE STRUCTF U;
   IF NULL U THEN NIL
    ELSE IF DOMAINP U THEN U
    ELSE BEGIN SCALAR X,Y;
	X := MVAR U;
	IF SFP X THEN IF Y := ASSOC(X,VARLIS) THEN X := CADR Y
		ELSE X := STRUCTK(PREPSQ!*(STRUCTF X ./ 1),GENVAR(),X)
	 ELSE IF NOT ATOM X AND NOT ATOMLIS CDR X
	  THEN IF Y := ASSOC(X,VARLIS) THEN X := CADR Y
		ELSE X := STRUCTK(X,GENVAR(),X);
	RETURN X .** LDEG U .* STRUCTF LC U .+ STRUCTF RED U
     END;

SYMBOLIC PROCEDURE STRUCTK(U,ID,V);
   BEGIN SCALAR X;
      IF X := SUBCHK1(U,VARLIS,ID)
	THEN RPLACD(X,(V . ID . U) . CDR X)
       ELSE IF X := SUBCHK2(U,VARLIS)
	THEN VARLIS := (V . ID . X) . VARLIS
       ELSE VARLIS := (V . ID . U) . VARLIS;
      RETURN ID
   END;

SYMBOLIC PROCEDURE SUBCHK1(U,V,ID);
   BEGIN SCALAR W;
      WHILE V DO
       <<SMEMBER(U,CDDAR V)
	    AND <<W := V; RPLACD(CDAR V,SUBST(ID,U,CDDAR V))>>;
	 V := CDR V>>;
      RETURN W
   END;

SYMBOLIC PROCEDURE SUBCHK2(U,V);
   BEGIN SCALAR BOOL;
      FOR EACH X IN V DO
       SMEMBER(CDDR X,U)
	  AND <<BOOL := T; U := SUBST(CADR X,CDDR X,U)>>;
      IF BOOL THEN RETURN U ELSE RETURN NIL
   END;

UNFLUID '(COUNTR VAR VARLIS);


%*********************************************************************
%*********************************************************************
%                       COEFF OPERATOR PACKAGE
%*********************************************************************
%********************************************************************;

%*********************************************************************
%		   REQUIRES EXTENDED OUTPUT PACKAGE
%********************************************************************;

FLAG ('(HIPOW!* LOWPOW!*),'SHARE);

GLOBAL '(HIPOW!* LOWPOW!*);

SYMBOLIC PROCEDURE COEFF(U,V,W);
   BEGIN SCALAR X,Y,Z;
	V := !*A2K V;
	IF ATOM W THEN (IF NOT ARRAYP W
	   THEN (IF NUMBERP(W := REVAL W) THEN TYPERR(W,'ID)))
	 ELSE IF NOT ARRAYP CAR W THEN TYPERR(CAR W,'array)
	 ELSE W := CAR W . FOR EACH X IN CDR W
			    COLLECT IF X EQ 'TIMES THEN X ELSE REVAL X;
	U := !*Q2F SIMP!* U;
	X := SETKORDER LIST V;
	Y := REORDER U;
	SETKORDER X;
	IF NULL Y THEN GO TO B0;
	WHILE NOT DOMAINP Y AND MVAR Y=V
	   DO <<Z := (LDEG Y . MK!*SQ1 CANCEL (LC Y ./ 1)) . Z;
		Y := RED Y>>;
    B:	IF NULL Y THEN GO TO B1;
    B0: Z := (0 . MK!*SQ1 CANCEL (Y ./ 1)) . Z;
    B1: LOWPOW!* := CAAR Z;
	IF (NOT ATOM W AND ATOM CAR W
			 AND (Y := DIMENSION CAR W))
	     OR ((Y := DIMENSION W) AND NULL CDR Y)
	 THEN GO TO G;
	Y := EXPLODE W;
	W := NIL;
    C:	W := INTERN COMPRESS APPEND(Y,EXPLODE CAAR Z) . W;
	SETK1(CAR W,CDAR Z,T);
	IF NULL CDR Z THEN GO TO D;
	Z := CDR Z;
	GO TO C;
    D:	HIPOW!* := CAAR Z;
	LPRIM ACONC(W,"are non zero");
    E:	RETURN HIPOW!*;
    G:	Z := REVERSE Z;
	IF ATOM W
	  THEN <<IF CAAR Z NEQ (CAR Y-1)
		   THEN <<Y := LIST(CAAR Z+1);
			  PUT(W,'ARRAY,MKARRAY Y);
			  PUT(W,'DIMENSION,Y)>>;
		 W := LIST(W,'TIMES)>>;
	HIPOW!* := CAAR Z;
	Y := PAIR(CDR W,Y);
    G0: WHILE NOT SMEMQ('TIMES,CAAR Y) DO Y := CDR Y;
	Y := CDAR Y-REVAL SUBST(0,'TIMES,CAAR Y)-1;
	   %-1 needed since DIMENSION gives length, not highest index;
	IF CAAR Z>Y
	  THEN REDERR LIST("Index",CAAR Z,"out of range");
    H:	IF NULL Z OR Y NEQ CAAR Z
	  THEN SETELV(SUBST(Y,'TIMES,W),0)
	 ELSE <<SETELV(SUBST(Y,'TIMES,W),CDAR Z); Z := CDR Z>>;
	IF Y=0 THEN GO TO E;
	Y := Y-1;
	GO TO H
   END;

SYMBOLIC PROCEDURE MK!*SQ1 U;
   IF WTL!* THEN PREPSQ U ELSE MK!*SQ U;

FLAG ('(COEFF),'OPFN);

FLAG ('(COEFF),'NOVAL);


%*********************************************************************
%*********************************************************************
%                     ASYMPTOTIC COMMAND PACKAGE
%********************************************************************;
%********************************************************************;

SYMBOLIC PROCEDURE WEIGHT U;
   BEGIN SCALAR Y,Z;
	RMSUBS();
	FOR EACH X IN U DO
	   IF NOT EQEXPR X THEN ERRPRI2(X,'HOLD)
	    ELSE <<Y := !*A2K CADR X;
		   Z := REVAL CADDR X;
		   IF NOT (NUMBERP Z AND FIXP Z AND Z>0)
		     THEN TYPERR(Z,"weight");
		   WTL!* :=  (Y . Z) . DELASC(Y,WTL!*)>>
   END;

SYMBOLIC PROCEDURE WTLEVEL U;
   BEGIN INTEGER N; SCALAR X;
	N := REVAL CAR U;
	IF NOT(NUMBERP N AND FIXP N AND NOT N<0)
	  THEN ERRPRI2(N,'HOLD);
	N := N+1;
	X := ATSOC('K!*,ASYMPLIS!*);
	IF N=CDR X THEN RETURN NIL ELSE IF N<=CDR X THEN RMSUBS2();
	RMSUBS1();
	RPLACD(X,N)
   END;

RLISTAT '(WEIGHT WTLEVEL);

ALGEBRAIC LET K!***2=0;


%*********************************************************************
%*********************************************************************
%			LINEAR OPERATOR PACKAGE
%*********************************************************************
%********************************************************************;

%Global variables referenced in this Section;

GLOBAL '(DEPL!*);   %list of dependencies among kernels;

%*********************************************************************
%      FUNCTIONS FOR DEFINING AND CHECKING EXPRESSION DEPENDENCY
%********************************************************************;

SYMBOLIC PROCEDURE DEPEND U;
   FOR EACH X IN CDR U DO DEPEND1(CAR U,X,T);

SYMBOLIC PROCEDURE NODEPEND U;
   <<RMSUBS(); FOR EACH X IN CDR U DO DEPEND1(CAR U,X,NIL)>>;

RLISTAT '(DEPEND NODEPEND);

SYMBOLIC PROCEDURE DEPEND1(U,V,BOOL);
   BEGIN SCALAR Y,Z;
      U := !*A2K U;
      V := !*A2K V;
      IF U EQ V THEN RETURN NIL;
      Y := ASSOC(U,DEPL!*);
      IF Y THEN IF BOOL THEN RPLACD(Y,UNION(LIST V,CDR Y))
		 ELSE IF (Z := DELETE(V,CDR Y)) THEN RPLACD(Y,Z)
		 ELSE DEPL!* := DELETE(Y,DEPL!*)
       ELSE IF NULL BOOL
	 THEN LPRIM LIST(U,"has no prior dependence on",V)
       ELSE DEPL!* := LIST(U,V) . DEPL!*
   END;

SYMBOLIC PROCEDURE DEPENDS(U,V);
   IF NULL U OR NUMBERP U OR NUMBERP V THEN NIL
    ELSE IF U=V THEN U
    ELSE IF ATOM U AND U MEMQ FRLIS!* THEN T
      %to allow the most general pattern matching to occur;
    ELSE IF (LAMBDA X; X AND LDEPENDS(CDR X,V)) ASSOC(U,DEPL!*)
     THEN T
    ELSE IF NOT ATOM U
      AND (LDEPENDS(CDR U,V) OR DEPENDS(CAR U,V)) THEN T
    ELSE IF ATOM V THEN NIL
    ELSE DEPENDSL(U,CDR V);

SYMBOLIC PROCEDURE LDEPENDS(U,V);
   U AND (DEPENDS(CAR U,V) OR LDEPENDS(CDR U,V));

SYMBOLIC PROCEDURE DEPENDSL(U,V);
   V AND (DEPENDS(U,CAR V) OR DEPENDSL(U,CDR V));

SYMBOLIC PROCEDURE FREEOF(U,V);
   NOT(SMEMBER(V,U) OR V MEMBER ASSOC(U,DEPL!*));

FLAG('(FREEOF),'BOOLEAN);

INFIX FREEOF;

PRECEDENCE FREEOF,LESSP;   %put it above all boolean operators;


%*********************************************************************
%	      FUNCTIONS FOR SIMPLIFYING LINEAR OPERATORS
%********************************************************************;

SYMBOLIC PROCEDURE LINEAR U;
   FOR EACH X IN U DO
    <<IF NOT IDP X THEN TYPERR(X,'operator); FLAG(LIST X,'LINEAR);
      MKOP X>>;

RLISTAT '(LINEAR);

PUT('LINEAR,'SIMPFG,'((RMSUBS)));

SYMBOLIC PROCEDURE FORMLNR U;
  (LAMBDA (X,Y,Z);
   IF Y = 1 THEN U
    ELSE IF NOT DEPENDS(Y,CAR Z)
     THEN LIST('TIMES,Y,X . 1 . Z)
    ELSE IF ATOM Y THEN U
    ELSE IF CAR Y EQ 'PLUS
     THEN 'PLUS . FOR EACH J IN CDR Y COLLECT FORMLNR(X . J. Z)
    ELSE IF CAR Y EQ 'MINUS
     THEN LIST('MINUS,FORMLNR(X . CADR Y . Z))
    ELSE IF CAR Y EQ 'DIFFERENCE
     THEN LIST('DIFFERENCE,FORMLNR(X . CADR Y . Z),
			   FORMLNR(X . CADDR Y . Z))
    ELSE IF CAR Y EQ 'TIMES THEN FORMLNTMS(X,CDR Y,Z,U)
    ELSE IF CAR Y EQ 'QUOTIENT THEN FORMLNQUOT(X,CDR Y,Z,U)
    ELSE IF CAR Y EQ 'RECIP AND NOT DEPENDS(CADR Y,CAR Z)
     THEN LIST('QUOTIENT,X . 1 . Z,CADR Y)
    ELSE (LAMBDA V; IF V THEN LIST('TIMES,CAR V,X . CDR V . Z) ELSE U)
	  EXPT!-SEPARATE(Y,CAR Z))
   (CAR U,CADR U,!*A2K CADDR U . CDDDR U);

SYMBOLIC PROCEDURE FORMSEPARATE(U,V);
   %separates U into two parts, and returns a dotted pair of them: those
   %which are not commutative and do not depend on V, and the remainder;
   BEGIN SCALAR W,X,Y;
      FOR EACH Z IN U DO
	IF NOT NONCOMP Z AND NOT DEPENDS(Z,V) THEN X := Z . X
	 ELSE IF (W := EXPT!-SEPARATE(Z,V))
	THEN <<X := CAR W . X; Y := CDR W . Y>>
	 ELSE Y := Z . Y;
      RETURN REVERSIP X . REVERSIP Y
   END;

SYMBOLIC PROCEDURE EXPT!-SEPARATE(U,V);
   %determines if U is an expression in EXPT that can be separated into
   %two parts, one that does not depend on V and one that does,
   %except if there is no non-dependent part, NIL is returned;
   IF NOT EQCAR(U,'EXPT) OR DEPENDS(CADR U,V)
	   OR NOT EQCAR(CADDR U,'PLUS)
     THEN NIL
    ELSE EXPT!-SEPARATE1(CDADDR U,CADR U,V);

SYMBOLIC PROCEDURE EXPT!-SEPARATE1(U,V,W);
   BEGIN SCALAR X;
      X := FORMSEPARATE(U,W);
      RETURN IF NULL CAR X THEN NIL
	      ELSE LIST('EXPT,V,REPLUS CAR X) .
		   IF NULL CDR X THEN 1 ELSE LIST('EXPT,V,REPLUS CDR X)
   END;

SYMBOLIC PROCEDURE FORMLNTMS(U,V,W,X);
   %U is a linear operator, V its first argument with TIMES removed,
   %W the rest of the arguments and X the whole expression.
   %Value is the transformed expression;
   BEGIN SCALAR Y;
      Y := FORMSEPARATE(V,CAR W);
      RETURN IF NULL CAR Y THEN X
	      ELSE 'TIMES . ACONC(CAR Y,
		IF NULL CDDR Y THEN FORMLNR(U . CADR Y . W)
		      ELSE U . ('TIMES . CDR Y) . W)
   END;

SYMBOLIC PROCEDURE FORMLNQUOT(FN,QUOTARGS,REST,WHOLE);
   %FN is a linear operator, QUOTARGS its first argument with QUOTIENT
   %removed, REST the remaining arguments, WHOLE the whole expression.
   %Value is the transformed expression;
   BEGIN SCALAR X;
      RETURN IF NOT DEPENDS(CADR QUOTARGS,CAR REST)
	 THEN LIST('QUOTIENT,FORMLNR(FN . CAR QUOTARGS . REST),
		   CADR QUOTARGS)
	ELSE IF NOT DEPENDS(CAR QUOTARGS,CAR REST)
	       AND CAR QUOTARGS NEQ 1
	 THEN LIST('TIMES,CAR QUOTARGS,
		   FORMLNR(FN . LIST('RECIP,CADR QUOTARGS) . REST))
	ELSE IF EQCAR(CAR QUOTARGS,'PLUS)
	 THEN 'PLUS . FOR EACH J IN CDAR QUOTARGS
		COLLECT FORMLNR(FN . ('QUOTIENT . J . CDR QUOTARGS)
				 . REST)
	ELSE IF EQCAR(CAR QUOTARGS,'MINUS)
	 THEN LIST('MINUS,FORMLNR(FN .
			('QUOTIENT . CADAR QUOTARGS . CDR QUOTARGS)
			    . REST))
	ELSE IF EQCAR(CAR QUOTARGS,'TIMES)
		AND CAR(X := FORMSEPARATE(CDAR QUOTARGS,CAR REST))
	 THEN 'TIMES . ACONC(CAR X,
		FORMLNR(FN . LIST('QUOTIENT,MKTIMES CDR X,
			     CADR QUOTARGS) . REST))
	ELSE IF EQCAR(CADR QUOTARGS,'TIMES)
		AND CAR(X := FORMSEPARATE(CDADR QUOTARGS,CAR REST))
	 THEN LIST('TIMES,LIST('RECIP,MKTIMES CAR X),
		FORMLNR(FN . LIST('QUOTIENT,CAR QUOTARGS,MKTIMES CDR X)
			 . REST))
	ELSE IF X := EXPT!-SEPARATE(CAR QUOTARGS,CAR REST)
	 THEN LIST('TIMES,CAR X,FORMLNR(FN . LIST('QUOTIENT,CDR X,CADR
						     QUOTARGS) . REST))
	ELSE IF X := EXPT!-SEPARATE(CADR QUOTARGS,CAR REST)
	 THEN LIST('TIMES,LIST('RECIP,CAR X),
		   FORMLNR(FN . LIST('QUOTIENT,CAR QUOTARGS,CDR X)
			      . REST))
	ELSE IF (X := REVAL!* CADR QUOTARGS) NEQ CADR QUOTARGS
	 THEN FORMLNQUOT(FN,LIST(CAR QUOTARGS,X),REST,WHOLE)
	ELSE WHOLE
   END;

SYMBOLIC PROCEDURE MKTIMES U;
   IF NULL CDR U THEN CAR U ELSE 'TIMES . U;

SYMBOLIC PROCEDURE REVAL!* U;
   %like REVAL, except INTSTR is always ON;
   BEGIN SCALAR !*INTSTR;
      !*INTSTR := T;
      RETURN REVAL U
   END;


%*********************************************************************
%       FUNCTIONS FOR ALGEBRAIC MODE OPERATIONS ON POLYNOMIALS
%********************************************************************;

SYMBOLIC PROCEDURE POLPART(EXPRN,KERN,FN);
   BEGIN SCALAR X,Y;
      EXPRN := !*A2F EXPRN;
      KERN := !*A2K KERN;
      IF DOMAINP EXPRN THEN RETURN NIL
       ELSE IF MVAR EXPRN EQ KERN
	THEN RETURN !*F2A APPLY(FN,LIST EXPRN);
      X := SETKORDER LIST KERN;
      EXPRN := REORDER EXPRN;
      IF NOT(MVAR EXPRN EQ KERN) THEN EXPRN := NIL
       ELSE EXPRN := APPLY(FN,LIST EXPRN);
      SETKORDER X;
      RETURN !*F2A EXPRN
   END;

SYMBOLIC PROCEDURE DEG(U,KERN); POLPART(U,KERN,'CDAAR);

SYMBOLIC PROCEDURE LCOF(U,KERN); POLPART(U,KERN,'CDAR);

SYMBOLIC PROCEDURE LTERM(U,KERN); POLPART(U,KERN,'!*LTERM);

SYMBOLIC PROCEDURE !*LTERM U; LT U .+ NIL;

SYMBOLIC PROCEDURE MAINVAR U;
   IF DOMAINP(U := !*A2F U) THEN NIL
    ELSE IF SFP(U := MVAR U) THEN PREPF U
    ELSE U;

SYMBOLIC PROCEDURE REDUCT(EXPRN,KERN);
   BEGIN SCALAR X,Y;
      EXPRN := !*A2F EXPRN;
      KERN := !*A2K KERN;
      IF DOMAINP EXPRN THEN RETURN EXPRN
       ELSE IF MVAR EXPRN EQ KERN THEN RETURN !*F2A CDR EXPRN;
      X := SETKORDER LIST KERN;
      EXPRN := REORDER EXPRN;
      IF MVAR EXPRN EQ KERN THEN EXPRN := CDR EXPRN;
      SETKORDER X;
      RETURN !*F2A EXPRN
   END;

SYMBOLIC OPERATOR DEG,LCOF,LTERM,MAINVAR,REDUCT;


%*********************************************************************
%	    SIMPLIFICATION RULES FOR ELEMENTARY FUNCTIONS
%********************************************************************;

ALGEBRAIC;

COMMENT RULE FOR I**2;

REMFLAG('(I),'RESERVED);

LET I**2= -1;

FLAG('(E I NIL PI T),'RESERVED);

COMMENT LOGARITHMS;

OPERATOR LOG;

LET LOG(E)= 1,
    LOG(1)= 0;

FOR ALL X LET LOG(E**X)=X;

FOR ALL X LET DF(LOG(X),X) = 1/X;

COMMENT TRIGONOMETRICAL FUNCTIONS;

SYMBOLIC PROCEDURE SIMPTRIG U;
   %This is a basic simplification function for trigonometrical
   %functions. The prefix expression U is of the form (<trig-function>
   % <argument>). It is assumed that the trig-function is either even
   %or odd, with even the default (and the odd case a flag "odd"). 
   %The value is a standard quotient for the simplified expression;
   BEGIN SCALAR BOOL,FN,X,Y,Z;
      FN := CAR U;
      U := CDR U;
      IF NULL U OR CDR U
	THEN REDERR LIST("Wrong number of arguments to",FN);
      U := SIMP!* CAR U;
      IF NULL NUMR U AND FLAGP(FN,'ODD) THEN RETURN NIL ./ 1;
      X := LIST(FN,PREPSQ!* U);
      IF SUBFG!* AND (Z := OPMTCH X) THEN RETURN SIMP Z
       ELSE IF Z := NUMVALCHK X THEN RETURN Z
       ELSE IF MINUSF NUMR U
	THEN <<IF FLAGP(FN,'ODD) THEN BOOL := T;
	       X := LIST(FN,PREPSQ!*(NEGF NUMR U ./ DENR U));
	       IF SUBFG!* AND (Z := OPMTCH X) THEN RETURN SIMP Z>>;
      X := MKSQ(X,1);
      RETURN IF BOOL THEN NEGSQ X ELSE X
   END;

DEFLIST('((ACOS SIMPTRIG) (ASIN SIMPTRIG) (ATAN SIMPTRIG)
	  (ACOSH SIMPTRIG) (ASINH SIMPTRIG) (ATANH SIMPTRIG)
	  (COS SIMPTRIG) (SIN SIMPTRIG) (TAN SIMPTRIG)
	  (COT SIMPTRIG)(ACOT SIMPTRIG)(COTH SIMPTRIG)(ACOTH SIMPTRIG)
	  (COSH SIMPTRIG) (SINH SIMPTRIG) (TANH SIMPTRIG)
   ),'SIMPFN);

%The following declaration causes the simplifier to pass the full
%expression (including the function) to SIMPTRIG;

FLAG ('(ACOS ASIN ATAN ACOSH ASINH ATANH COS SIN TAN COSH SINH TANH
	COT ACOT COTH ACOTH),
      'FULL);

FLAG('(ASIN ATAN ASINH ATANH SIN TAN SINH TANH COT ACOT COTH ACOTH),
      'ODD);

%In the following rules, it is not necessary to let f(0)=0, when f
%is odd, since SIMPTRIG already does this;

LET COS(0)= 1,
    COS(PI/2)= 0,
    SIN(PI/2)= 1,
    SIN(PI)= 0,
    COS(PI)=-1,
    COSH 0=1;

FOR ALL X LET COS ACOS X=X, SIN ASIN X=X, TAN ATAN X=X,
	   COSH ACOSH X=X, SINH ASINH X=X, TANH ATANH X=X,
	   COT ACOT X=X, COTH ACOTH X=X;


FOR ALL N SUCH THAT NUMBERP N AND FIXP N
	  LET SIN(N*PI)=0, COS(N*PI) = (-1)**N;

FOR ALL X LET DF(ACOS(X),X)= -SQRT(1-X**2)/(1-X**2),
	      DF(ASIN(X),X)= SQRT(1-X**2)/(1-X**2),
	      DF(ATAN(X),X)= 1/(1+X**2),
	      DF(ACOSH(X),X)= SQRT(X**2-1)/(X**2-1),
	      DF(ASINH(X),X)= SQRT(X**2+1)/(X**2+1),
	      DF(ATANH(X),X)= 1/(1-X**2),
	      DF(COS X,X)= -SIN(X),
	      DF(SIN(X),X)= COS(X),
              DF(TAN X,X)=1+TAN X**2,
              DF(SINH X,X)=COSH X,
              DF(COSH X,X)=SINH X,
              DF(TANH X,X)=1-TANH X**2,
	      DF(COT X,X)=-1-COT X**2,
	      DF(COTH X,X)=1-COTH X**2;

LET   E**(I*PI/2) = I,
      E**(I*PI) = -1,
      E**(3*I*PI/2)=-I;

%FOR ALL X LET E**LOG X=X;   %requires every power to be checked;

FOR ALL X,Y LET DF(X**Y,X)= Y*X**(Y-1),
                DF(X**Y,Y)= LOG X*X**Y;

COMMENT SQUARE ROOTS;

DEFLIST('((SQRT SIMPSQRT)),'SIMPFN);

%FOR ALL X LET SQRT X**2=X;

FLUID '(!*!*SQRT);   %Used to indicate that SQRTs have been used;

SYMBOLIC PROCEDURE MKSQRT U;
   <<IF NULL !*!*SQRT THEN <<!*!*SQRT := T;
			     ALGEBRAIC FOR ALL X LET SQRT X**2=X>>;
     LIST('SQRT,U)>>;

FOR ALL X LET DF(SQRT X,X)=SQRT X/(2*X);


COMMENT ERF,EXP, EXPINT AND DILOG;

OPERATOR ERF,EXP,EXPINT,DILOG;

LET ERF 0=0;

LET DILOG(0)=PI**2/6;

FOR ALL X LET ERF(-X)=-ERF X;

FOR ALL X LET DF(ERF X,X)=2*SQRT(PI)*E**(-X**2/2)/PI;

FOR ALL X LET EXP(X)=E**X;

FOR ALL X LET DF(EXPINT(X),X)=E**X/X;

FOR ALL X LET DF(DILOG X,X)=-LOG X/(X-1);


SYMBOLIC;


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

SYMBOLIC PROCEDURE NSSIMP(U,V);
   %U is a prefix expression involving non-commuting
   %quantities. Result is an expression of the form
   % SUM R(I)*PRODUCT M(I,J) where the R(I) are standard
   %quotients and the M(I,J) non-commuting expressions;
   %N. B: the products in M(I,J) are returned in reverse order
   %(to facilitate, e.g., matrix augmentation);
   BEGIN SCALAR W,X,Y,Z;
	U := DSIMP(U,V);
    A:	IF NULL U THEN RETURN Z;
	W := CAR U;
    C:	IF NULL W THEN GO TO D
	 ELSE IF NUMBERP CAR W
		OR NOT(EQCAR(CAR W,'!*DIV) OR APPLY(V,LIST CAR W))
	  THEN X := ACONC(X,CAR W)
	 ELSE Y := ACONC(Y,CAR W);
	W := CDR W;
	GO TO C;
    D:	IF NULL Y THEN GO TO ER;
    E:	Z := ADDNS(((IF NULL X THEN 1 ./ 1 ELSE SIMPTIMES X) . Y),Z);
	U := CDR U;
	X := Y:= NIL;
	GO TO A;
    ER: Y := GET(V,'NAME);
	IF IDP CAR X
	  THEN IF NOT FLAGP(CAR X,GET(Y,'FN)) THEN REDMSG(CAR X,Y)
	    ELSE REDERR LIST(Y,X,"not set")
	 ELSE IF Y EQ 'MATRIX THEN <<Y:= '((MAT (1))); GO TO E>>
	 %to allow a scalar to be a 1 by 1 matrix;
	 ELSE REDERR LIST("Missing",Y,X);
	PUT(CAR X,Y,Y);
	Y := LIST CAR X;
	X := CDR X;
	GO TO E
   END;

SYMBOLIC PROCEDURE DSIMP(U,V);
   %result is a list of lists representing a sum of products;
   %N. B: symbols are in reverse order in product list;
   IF NUMBERP U THEN LIST LIST U
    ELSE IF ATOM U THEN (LAMBDA W; (LAMBDA X;
	IF X AND NOT X EQ W AND SUBFG!* THEN DSIMP(X,V)
	 ELSE IF FLAGP(U,'SHARE) THEN DSIMP(EVAL U,V)
	 ELSE <<FLAG(LIST U,'USED!*); LIST LIST U>>)
     GET(U,W))
    GET(V,'NAME)
    ELSE IF CAR U EQ 'PLUS
     THEN FOR EACH J IN CDR U CONC DSIMP(J,V)
    ELSE IF CAR U EQ 'DIFFERENCE
     THEN NCONC(DSIMP(CADR U,V),
		DSIMP('MINUS . CDDR U,V))
    ELSE IF CAR U EQ 'MINUS
     THEN DSIMPTIMES(LIST(-1,CARX CDR U),V)
    ELSE IF CAR U EQ 'TIMES
     THEN DSIMPTIMES(CDR U,V)
    ELSE IF CAR U EQ 'QUOTIENT
     THEN DSIMPTIMES(LIST(CADR U, LIST('RECIP,CARX CDDR U)),V)
    ELSE IF NOT APPLY(V,LIST U) THEN LIST LIST U
    ELSE IF CAR U EQ 'RECIP THEN LIST LIST LIST('!*DIV,CARX CDR U)
    ELSE IF CAR U EQ 'EXPT THEN (LAMBDA Z;
       IF NOT NUMBERP Z OR NOT FIXP Z THEN ERRPRI2(U,T)
	ELSE IF Z<0
	 THEN LIST LIST LIST('!*DIV,'TIMES . NLIST(CADR U,-Z))
	 ELSE IF Z=0 THEN LIST LIST LIST('!*DIV,CADR U,1)
	ELSE DSIMPTIMES(NLIST(CADR U,Z),V))
      REVAL CADDR U
    ELSE IF CAR U EQ 'MAT THEN LIST LIST U
    ELSE IF ARRAYP CAR U
       THEN DSIMP(GETELV U,V)
    ELSE (LAMBDA X; IF X THEN DSIMP(X,V)
		     ELSE (LAMBDA Y; IF Y THEN DSIMP(Y,V)
					  ELSE LIST LIST U)
				OPMTCH REVOP1 U)
	OPMTCH U;

SYMBOLIC PROCEDURE DSIMPTIMES(U,V);
   IF NULL U THEN ERRACH 'DSIMPTIMES
    ELSE IF NULL CDR U THEN DSIMP(CAR U,V)
    ELSE (LAMBDA J;
	  FOR EACH K IN DSIMPTIMES(CDR U,V) CONC MAPPEND(J,K))
       DSIMP(CAR U,V);

SYMBOLIC PROCEDURE ADDNS(U,V);
   IF NULL V THEN LIST U
    ELSE IF CDR U=CDAR V
       THEN (LAMBDA X; IF NULL CAR X THEN CDR V
			 ELSE (X . CDR U) . CDR V)
       ADDSQ(CAR U,CAAR V)
    ELSE IF ORDP(CDR U,CDAR V) THEN U . V
    ELSE CAR V . ADDNS(U,CDR V);

SYMBOLIC PROCEDURE NSLET(U,V,W,B,FLG);
   BEGIN
	IF FLG THEN GO TO A
	 ELSE IF NOT ATOM U
	  THEN IF ARRAYP CAR U THEN GO TO A ELSE TYPERR(U,"array");
	REDMSG(U,W);
	PUT(U,W,W);
    A:	IF NULL B THEN GO TO C
	 ELSE IF NOT ATOM U OR FLAGP(U,'USED!*) THEN RMSUBS();
    C:	IF NOT ATOM U
	  THEN IF ARRAYP CAR U
		 THEN SETELV(U,IF B THEN V ELSE NIL)
		ELSE PUT(CAR U,'OPMTCH,XADD!*(CDR U .
		    LIST(NIL . (IF MCOND!* THEN MCOND!* ELSE T),V,NIL),
			GET(CAR U,'OPMTCH),U,B))
	 ELSE IF NULL B THEN REMPROP(U,W)
	 ELSE IF W EQ 'MATRIX AND NOT EQCAR(V,'MAT)
	  THEN PUT(U,W,IF MATP V THEN GET(V,'MATRIX)
			ELSE LIST('MAT,LIST V))   %1 by 1 matrix case;
	 ELSE PUT(U,W,V)
   END;

SYMBOLIC PROCEDURE NSP(U,V);
   IF NUMBERP U THEN NIL
    ELSE IF ATOM U THEN GET(U,V)
			  OR (FLAGP(U,'SHARE) AND NSP(EVAL U,V))
    ELSE IF CAR U MEMQ '(TIMES QUOTIENT) THEN NSOR(CDR U,V)
    ELSE IF CAR U MEMQ '(PLUS DIFFERENCE MINUS EXPT RECIP)
     THEN NSP(CADR U,V)
    ELSE IF ARRAYP CAR U THEN NSP(GETELX U,V)
    ELSE FLAGP(CAR U,GET(V,'FN));

SYMBOLIC PROCEDURE GETELX U;
   %to take care of free variables in LET statements;
   IF SMEMQLP(FRLIS!*,CDR U) THEN NIL
    ELSE IF NULL(U := GETELV U) THEN 0
    ELSE REVAL U;

SYMBOLIC PROCEDURE NSOR(U,V);
   U AND (NSP(CAR U,V) OR NSOR(CDR U,V));


%*********************************************************************
%*********************************************************************
%			    MATRIX PACKAGE
%*********************************************************************
%********************************************************************;

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

SYMBOLIC PROCEDURE MATRIX U;
   %declares list U as matrices;
   BEGIN SCALAR V,W; INTEGER N;
	TYPL!* := UNION('(MATP),TYPL!*);
    A:	IF NULL U THEN RETURN NIL
	 ELSE IF ATOM CAR U AND NOT TYPECHK(CAR U,'MATRIX)
	  THEN PUT(CAR U,'MATRIX,'MATRIX)
	 ELSE IF NOT IDP CAAR U
		OR LENGTH (V := REVLIS CDAR U) NEQ 2 OR NOT NUMLIS V
	  THEN GO TO ER
	 ELSE IF NOT TYPECHK(CAAR U,'MATRIX) THEN GO TO C;
    B:	U := CDR U;
	GO TO A;
    C:	N := CAR V;
    D:	IF N=0 THEN GO TO E;
	W := NZERO CADR V . W;
	N := N-1;
	GO TO D;
    E:	PUT(CAAR U,'MATRIX,'MAT . W);
	W := NIL;
	GO TO B;
    ER: ERRPRI2(CAR U,'HOLD);
	GO TO B
   END;

RLISTAT '(MATRIX);

SYMBOLIC PROCEDURE NZERO N;
   %returns a list of N zeros;
   IF N=0 THEN NIL ELSE 0 . NZERO(N-1);

SYMBOLIC PROCEDURE FORMMAT(U,VARS,MODE);
   'LIST . MKQUOTE 'MAT
     . FOR EACH X IN U COLLECT('LIST . FORMLIS(X,VARS,MODE));

PUT('MAT,'FORMFN,'FORMMAT);

SYMBOLIC PROCEDURE MATP U;
   %predicate which tests for matrix expressions;
   NSP(U,'MATRIX);

FLAG('(MAT TP),'MATFLG);

PUT('TP,'MSIMPFN,'TP);

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

PUT('MATP,'NAME,'MATRIX);

PUT('MATRIX,'FN,'MATFLG);

PUT('MATP,'EVFN,'MATSM!*);

PUT('MATP,'PRIFN,'MATPRI!*);


END;