;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;     The data in this file contains enhancments.                    ;;;;;
;;;                                                                    ;;;;;
;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
;;;     All rights reserved                                            ;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(in-package "MAXIMA")
;	** (c) Copyright 1982 Massachusetts Institute of Technology **

(macsyma-module comm)

(DECLARE-TOP (GENPREFIX C)
	 (SPECIAL $EXPTSUBST $LINECHAR $NOLABELS $INFLAG $PIECE $DISPFLAG
		  $GRADEFS $PROPS $DEPENDENCIES DERIVFLAG DERIVLIST
		  $LINENUM $PARTSWITCH LINELABLE NN* DN* ISLINP
		  $POWERDISP ATVARS ATP $ERREXP $DERIVSUBST $DOTDISTRIB
		  $OPSUBST $SUBNUMSIMP $TRANSRUN IN-P SUBSTP $SQRTDISPFLAG
		  $PFEFORMAT DUMMY-VARIABLE-OPERATORS)
	 #-cl (*LEXPR FACTOR)
	 (FIXNUM I N LARGL LVRS COUNT TIM  (SIGNUM1)))

(PROG1 '(OP and OPR properties)
       (MAPC #'(LAMBDA (X) (PUTPROP (CAR X) (CADR X) 'OP)
			   (PUTPROP (CADR X) (CAR X) 'OPR))
	     '((MPLUS &+) (MMINUS &-) (MTIMES &*) (MEXPT &**) (MEXPT &^)
	       (MNCTIMES |&.|) (RAT &//) (MQUOTIENT &//) (MNCEXPT &^^)
	       (MEQUAL &=) (MGREATERP &>) (MLESSP &<) (MLEQP &<=) (MGEQP &>=)
	       (MNOTEQUAL |&#|) (MAND &AND) (MOR &OR) (MNOT &NOT) (MSETQ |&:|)
	       (MDEFINE |&:=|) (MDEFMACRO |&::=|) (MQUOTE |&'|) (MLIST &[)
	       (MSET |&::|) (MFACTORIAL &!) (MARROW &->) (MPROGN |&(|)
	       (MCOND &IF)))
       (MAPC #'(LAMBDA (X) (PUTPROP (CAR X) (CADR X) 'OP))
	     '((MQAPPLY $SUBVAR) (BIGFLOAT $BFLOAT)))
       (MAPC #'(LAMBDA (X) (PUTPROP (CAR X) (CADR X) 'OPR))
	     #-(or Franz Multics)
	     '((|&and| MAND) (|&or| MOR) (|&not| MNOT) (|&if| MCOND))
	     #+(or Franz Multics)
	     '((|&AND| MAND) (|&OR| MOR) (|&NOT| MNOT) (|&IF| MCOND))))


(SETQ $EXPTSUBST NIL $PARTSWITCH NIL $INFLAG NIL $GRADEFS '((MLIST SIMP))
      $DEPENDENCIES '((MLIST SIMP)) ATVARS '(&@1 &@2 &@3 &@4) ATP NIL
      ISLINP NIL LNORECURSE NIL &** '&^ $DERIVSUBST NIL TIMESP NIL
      $OPSUBST T IN-P NIL SUBSTP NIL)

(DEFMVAR $VECT_CROSS NIL 
	 "If TRUE allows DIFF(X~Y,T) to work where ~ is defined in 
	  SHARE;VECT where VECT_CROSS is set to TRUE.")

#+cl
(DEFMFUN $SUBSTITUTE (old new &optional (expr nil three-arg?))
	 (cond (three-arg? (maxima-substitute old new expr))
	       (t
		(LET ((L old) (Z new))
		  (COND ((AND ($LISTP L) ($LISTP (CADR L)) (NULL (CDDR L)))
			 ($SUBSTITUTE (CADR L) Z))
			((NOTLOREQ L) (IMPROPER-ARG-ERR L '$SUBSTITUTE))
			((EQ (CAAR L) 'MEQUAL) (MAXIMA-SUBSTITUTE (CADDR L) (CADR L) Z))
			(T (DO ((L (CDR L) (CDR L))) ((NULL L) Z)
			     (SETQ Z ($SUBSTITUTE (CAR L) Z)))))))))
#-cl
(DEfMFUN $SUBSTITUTE N
 (COND ((= N 2)
	(LET ((L (ARG 1)) (Z (ARG 2)))
	     (COND ((AND ($LISTP L) ($LISTP (CADR L)) (NULL (CDDR L)))
		    ($SUBSTITUTE (CADR L) Z))
		   ((NOTLOREQ L) (IMPROPER-ARG-ERR L '$SUBSTITUTE))
		   ((EQ (CAAR L) 'MEQUAL) (MAXIMA-SUBSTITUTE (CADDR L) (CADR L) Z))
		   (T (DO ((L (CDR L) (CDR L))) ((NULL L) Z)
			  (SETQ Z ($SUBSTITUTE (CAR L) Z)))))))
       ((= N 3) (MAXIMA-SUBSTITUTE (ARG 1) (ARG 2) (ARG 3)))
       (T (WNA-ERR '$SUBSTITUTE))))

(DECLARE-TOP (SPECIAL X Y OPRX OPRY NEGXPTY TIMESP))

(DEFMFUN MAXIMA-SUBSTITUTE (X Y Z)  ; The args to SUBSTITUTE are assumed to be simplified.
	 (DECLARE (SPECIAL X Y ))
	 (LET ((IN-P T) (SUBSTP T))
	   (IF (AND (MNUMP Y) (= (SIGNUM1 Y) 1))
	       (LET ($SQRTDISPFLAG ($PFEFORMAT T)) (SETQ Z (NFORMAT-ALL Z))))
	   (SIMPLIFYA
	     (IF (ATOM Y)
		 (COND ((EQUAL Y -1)
			(SETQ Y '((MMINUS) 1)) (SUBST2 (NFORMAT-ALL Z)))
		       (T
			#+cl
			(cond ((and (not (symbolp x))
				    (functionp x))
			       (let ((tem (gensym)))
				 (setf (get  tem  'operators) 'application-operator)
				 (setf (symbol-function tem) x)
				 (setq x tem))))
			(LET ((OPRX (GETOPR X)) (OPRY (GETOPR Y)))
			  (declare (special OPRX OPRY ))
			  (SUBST1 Z))))
		 (LET ((NEGXPTY (IF (AND (EQ (CAAR Y) 'MEXPT)
					 (= (SIGNUM1 (CADDR Y)) 1))
				    (MUL2 -1 (CADDR Y))))
		       (TIMESP (IF (EQ (CAAR Y) 'MTIMES) (SETQ Y (NFORMAT Y)))))
		   (declare (special NEGXPTY TIMESP))
		   (SUBST2 Z)))
	     NIL)))
  
;Remainder of page is update from F302 --gsb

;Used only in COMM2 (AT), and below.
(DEFVAR DUMMY-VARIABLE-OPERATORS 
  '(%PRODUCT %SUM %LAPLACE %INTEGRATE %LIMIT %AT))



(DEFUN SUBST1 (Z)  ; Y is an atom
  (COND ((ATOM Z) (IF (EQUAL Y Z) X Z))
	((SPECREPP Z) (SUBST1 (SPECDISREP Z)))
	((EQ (CAAR Z) 'BIGFLOAT) Z)
	((AND (EQ (CAAR Z) 'RAT) (OR (EQUAL Y (CADR Z)) (EQUAL Y (CADDR Z))))
	 (DIV (SUBST1 (CADR Z)) (SUBST1 (CADDR Z))))
	((AT-SUBSTP Z) Z)
	((AND (EQ Y T) (EQ (CAAR Z) 'MCOND))
	 (LIST (cons (CAAR Z) nil) (SUBST1 (CADR Z)) (SUBST1 (CADDR Z))
				(CADDDR Z) (SUBST1 (CAR (CDDDDR Z)))))
	(T (LET ((MARGS (MAPCAR #'SUBST1 (CDR Z))))
	     (IF (AND $OPSUBST
		      (OR (EQ OPRY (CAAR Z))
			  (AND (EQ (CAAR Z) 'RAT) (EQ OPRY 'MQUOTIENT))))
		 (IF (OR (NUMBERP X)
			 (MEMQ X '(T NIL $%E $%PI $%I))
			 (AND (NOT (ATOM X))
			      (NOT (OR (EQ (CAR X) 'LAMBDA)
				       (EQ (CAAR X) 'LAMBDA)))))
		     (IF (OR (AND (MEMQ 'array (CDAR Z))
				  (OR (AND (MNUMP X) $SUBNUMSIMP)
				      (AND (NOT (MNUMP X)) (NOT (ATOM X)))))
			     ($SUBVARP X))
			 (LET ((SUBSTP 'MQAPPLY))
			   (SUBST0 (LIST* '(MQAPPLY) X MARGS) Z))
			 (MERROR
			  "Attempt to MAXIMA-SUBSTITUTE ~M for ~M in ~M~
			   ~%Illegal substitution for operator of expression"
			  X Y Z))
		     (SUBST0 (CONS (cons OPRX nil) MARGS) Z))
		 (SUBST0 (CONS (cons (CAAR Z) nil) MARGS) Z))))))

(DEFUN SUBST2 (Z)
 (LET (NEWEXPT)
   (COND ((ATOM Z) Z)
	 ((SPECREPP Z) (SUBST2 (SPECDISREP Z)))
	 ((AND ATP (MEMQ (CAAR Z) '(%DERIVATIVE %LAPLACE))) Z)
	 ((AT-SUBSTP Z) Z)
	 ((ALIKE1 Y Z) X)
	 ((AND TIMESP (EQ (CAAR Z) 'MTIMES) (ALIKE1 Y (SETQ Z (NFORMAT Z)))) X)
	 ((AND (EQ (CAAR Y) 'MEXPT) (EQ (CAAR Z) 'MEXPT) (ALIKE1 (CADR Y) (CADR Z))
	       (SETQ NEWEXPT (COND ((ALIKE1 NEGXPTY (CADDR Z)) -1)
				   ($EXPTSUBST (EXPTHACK (CADDR Y) (CADDR Z))))))
	  (LIST '(MEXPT) X NEWEXPT))
	 ((AND $DERIVSUBST (EQ (CAAR Y) '%DERIVATIVE) (EQ (CAAR Z) '%DERIVATIVE)
	       (ALIKE1 (CADR Y) (CADR Z)))
	  (LET ((TAIL (SUBST-DIFF-MATCH (CDDR Y) (CDR Z))))
	       (COND ((NULL TAIL) Z)
		     (T (CONS (cons (CAAR Z) nil) (CONS X (CDR TAIL)))))))
	 (T (RECUR-APPLY #'SUBST2 Z)))))

(DECLARE-TOP (UNSPECIAL X Y OPRX OPRY NEGXPTY TIMESP))

(DEFMFUN SUBST0 (NEW OLD)
 (COND ((ALIKE (CDR NEW) (CDR OLD))
	(COND ((EQ (CAAR NEW) (CAAR OLD)) OLD)
	      (T (SIMPLIFYA (CONS (CONS (CAAR NEW) (MEMQ 'array (CDAR OLD))) (CDR OLD))
			    NIL))))
       ((MEMQ 'array (CDAR OLD))
	(SIMPLIFYA (CONS (CONS (CAAR NEW) '(ARRAY)) (CDR NEW)) NIL))
       (T (SIMPLIFYA NEW NIL))))

(DEFUN EXPTHACK (Y Z)
       (PROG (NN* DN* YN YD ZN ZD QD)
	     (COND ((AND (MNUMP Y) (MNUMP Z))
		    (RETURN (IF (NUMBERP (SETQ Y (DIV* Z Y))) Y)))
		   ((ATOM Z) (IF (NOT (MNUMP Y)) (RETURN NIL)))
		   ((OR (RATNUMP Z) (EQ (CAAR Z) 'MPLUS)) (RETURN NIL)))
	     (NUMDEN Y)  ; (CSIMP) sets NN* and DN*
	     (SETQ YN NN* YD DN*)
	     (NUMDEN Z)
	     (SETQ ZN NN* ZD DN*)
	     (SETQ QD (COND ((AND (EQUAL ZD 1) (EQUAL YD 1)) 1)
			    ((PROG2 (NUMDEN (DIV* ZD YD))
				    (AND (EQUAL DN* 1) (EQUAL NN* 1)))
			     1)
			    ((EQUAL NN* 1) (DIV* 1 DN*))
			    ((EQUAL DN* 1) NN*)
			    (T (RETURN NIL))))
	     (NUMDEN (DIV* ZN YN))
	     (IF (EQUAL DN* 1) (RETURN (DIV* NN* QD)))))

(DEFUN SUBST-DIFF-MATCH (L1 L2)
 (DO ((L L1 (CDDR L)) (L2 (copy-top-level L2)) (FAILED NIL NIL))
     ((NULL L) L2)
     (DO ((L2 L2 (CDDR L2)))
	 ((NULL (CDR L2)) (SETQ FAILED T))
	 (IF (ALIKE1 (CAR L) (CADR L2))
	     (IF (AND (FIXNUMP (CADR L)) (FIXNUMP (CADDR L2)))
		 (COND ((< (CADR L) (CADDR L2))
			(RETURN (RPLACD (CDR L2)
					(CONS (f- (CADDR L2) (CADR L))
					      (CDDDR L2)))))
		       ((= (CADR L) (CADDR L2))
			(RETURN (RPLACD L2 (CDDDR L2))))
		       (T (RETURN (SETQ FAILED T))))
		(RETURN (SETQ FAILED T)))))
     (IF FAILED (RETURN NIL))))

;This probably should be a subst or macro.
(DEFUN AT-SUBSTP (Z)
  (AND ATP (OR (MEMQ (CAAR Z) '(%DERIVATIVE %DEL))
	       (MEMQ (CAAR Z) DUMMY-VARIABLE-OPERATORS))))
(DEFMFUN RECUR-APPLY (FUN E)
 (COND ((EQ (CAAR E) 'BIGFLOAT) E)
       ((SPECREPP E) (FUNCALL FUN (SPECDISREP E)))
       (T (LET ((NEWARGS (MAPCAR FUN (CDR E))))
	       (IF (ALIKE NEWARGS (CDR E))
		   E
		   (SIMPLIFYA (CONS (CONS (CAAR E) (MEMQ 'array (CDAR E))) NEWARGS)
			      NIL))))))

(DEFMFUN $DEPENDS N
 (IF (ODDP N) (MERROR "DEPENDS takes an even number of arguments."))
 (DO ((I 1 (f+ I 2)) (L))
     ((> I N) (I-$DEPENDENCIES (NREVERSE L)))
     (COND (($LISTP (ARG I))
	    (DO ((L1 (CDR (ARG I)) (CDR L1))) ((NULL L1))
		(SETQ L (CONS (DEPENDS1 (CAR L1) (ARG (f1+ I))) L))))
	   (T (SETQ L (CONS (DEPENDS1 (ARG I) (ARG (f1+ I))) L))))))

(DEFUN DEPENDS1 (X Y)
 (NONSYMCHK X '$DEPENDS)
 (CONS (cons X nil) (IF ($LISTP Y) (CDR Y) (cons Y nil))))

(DEFMSPEC $DEPENDENCIES (FORM) (I-$DEPENDENCIES (CDR FORM)))

(DEFMFUN I-$DEPENDENCIES (L)
 (DOLIST (Z L)
	 (COND ((ATOM Z) (MERROR "Wrong format.  Try F(X)."))
	       ((OR (EQ (CAAR Z) 'MQAPPLY) (MEMQ 'array (CDAR Z)))
		(MERROR "Improper form for DEPENDS:~%~M" Z))
	       (T (LET ((Y (MGET (CAAR Z) 'DEPENDS)))
		       (MPUTPROP (CAAR Z)
				 (SETQ Y (UNION* (REVERSE (CDR Z)) Y))
				 'DEPENDS)
		       (unless (cdr $dependencies)
			 (setq $dependencies (copy-list '((mlist simp)))))
		       (ADD2LNC (CONS (cons (CAAR Z) nil) Y) $DEPENDENCIES)))))
 (CONS '(MLIST SIMP) L))

(DEFMSPEC $GRADEF (L) (SETQ L (CDR L))
 (LET ((Z (CAR L)) (N 0))
      (COND ((ATOM Z)
	     (IF (NOT (= (LENGTH L) 3)) (MERROR "Wrong arguments to GRADEF"))
	     (MPUTPROP Z
		       (CONS (CONS (CADR L) (MEVAL (CADDR L)))
			     (MGET Z '$ATOMGRAD))
		       '$ATOMGRAD)
	     (I-$DEPENDENCIES (cons (LIST (NCONS Z) (CADR L)) nil))
	     (ADD2LNC Z $PROPS)
	     Z)
	    ((OR (MOPP1 (CAAR Z)) (MEMQ 'array (CDAR Z)))
	     (MERROR "Wrong arguments to GRADEF:~%~M" Z))
	    ((PROG2 (SETQ N (f- (LENGTH Z) (LENGTH L))) (MINUSP N))
	     (WNA-ERR '$GRADEF))
	    (T (DO ((ZL (CDR Z) (CDR ZL))) ((NULL ZL))
		   (IF (NOT (SYMBOLP (CAR ZL)))
		       (MERROR "Parameters to GRADEF must be names:~%~M"
			       (CAR ZL))))
	       (SETQ L (NCONC (MAPCAR #'(LAMBDA (X) (REMSIMP (MEVAL X)))
				      (CDR L))
			      (MAPCAR #'(LAMBDA (X) (LIST '(%DERIVATIVE) Z X 1))
				      (NTHCDR (f- (LENGTH Z) N) Z))))
	       (PUTPROP (CAAR Z)
			(SUBLIS (MAPCAR #'CONS (CDR Z) (MAPCAR #'STRIPDOLLAR (CDR Z)))
				(CONS (CDR Z) L))
			'GRAD)
	       (or (cdr $gradefs) (setq $gradefs (copy-list '((mlist simp)))))
	       (ADD2LNC (CONS (cons (CAAR Z) nil) (CDR Z)) $GRADEFS)
	       Z))))

(DEFMFUN $DIFF N (LET (DERIVLIST) (DERIV (LISTIFY N))))

(DEFMFUN $DEL (E) (STOTALDIFF E))

(DEFUN DERIV (E)
       (PROG (EXP Z COUNT)
	     (COND ((NULL E) (WNA-ERR '$DIFF))
		   ((NULL (CDR E)) (RETURN (STOTALDIFF (CAR E))))
		   ((NULL (CDDR E)) (NCONC E '(1))))
	     (SETQ EXP (CAR E) Z (SETQ E (copy-top-level E)))
	LOOP (IF (OR (NULL DERIVLIST) (zl-MEMBER (CADR Z) DERIVLIST)) (GO DOIT))
					; DERIVLIST is set by $EV
	     (SETQ Z (CDR Z))
	LOOP2(COND ((CDR Z) (GO LOOP))
		   ((NULL (CDR E)) (RETURN EXP))
		   (T (GO NOUN)))
	DOIT (COND ((NONVARCHECK (CADR Z) '$DIFF))
		   ((NULL (CDDR Z)) (WNA-ERR '$DIFF))
		   ((NOT (EQ (ml-typep (CADDR Z)) 'fixnum)) (GO NOUN))
		   ((MINUSP (SETQ COUNT (CADDR Z)))
		    (MERROR "Improper count to DIFF:~%~M" COUNT)))
	LOOP1(COND ((ZEROP COUNT) (RPLACD Z (CDDDR Z)) (GO LOOP2))
		   ((EQUAL (SETQ EXP (SDIFF EXP (CADR Z))) 0) (RETURN 0)))
	     (SETQ COUNT (f1- COUNT))
	     (GO LOOP1)
	NOUN (RETURN (DIFF%DERIV (CONS EXP (CDR E))))))

(DEFUN CHAINRULE (E X)
 (LET (W)
      (COND (ISLINP (IF (AND (NOT (ATOM E))
			     (EQ (CAAR E) '%DERIVATIVE)
			     (NOT (FREEL (CDR E) X)))
			(DIFF%DERIV (LIST E X 1))
			0))
	    ((ATOMGRAD E X))
	    ((NOT (SETQ W (MGET (COND ((ATOM E) E)
				      ((MEMQ 'array (CDAR E)) (CAAR E))
				      ((ATOM (CADR E)) (CADR E))
				      (T (CAAADR E)))
				'DEPENDS)))
	     0)
	    (T (LET (DERIVFLAG)
		    (ADDN (MAPCAR
			   #'(LAMBDA (U) 
			      (LET ((Y (SDIFF U X)))
				   (IF (EQUAL Y 0)
				       0 
				       (LIST '(MTIMES)
					     (OR (ATOMGRAD E U)
						 (LIST '(%DERIVATIVE) E U 1))
					     Y))))
			   W)
			  NIL))))))

(DEFUN ATOMGRAD (E X)
  (LET (Y) (AND (ATOM E) (SETQ Y (MGET E '$ATOMGRAD)) (ASSOLIKE X Y))))

(DEFUN DEPENDS (E X)
  (COND ((ALIKE1 E X) T)
	((MNUMP E) NIL)
	((ATOM E) (MGET E 'DEPENDS))
	(T (OR (DEPENDS (CAAR E) X) (DEPENDSL (CDR E) X)))))

(DEFUN DEPENDSL (L X) (DOLIST (U L) (IF (DEPENDS U X) (RETURN T))))

(DEFMFUN SDIFF (E X)  ; The args to SDIFF are assumed to be simplified.
  (COND ((ALIKE1 E X) 1)
	((MNUMP E) 0)
	((OR (ATOM E) (MEMQ 'array (CDAR E))) (CHAINRULE E X))
	((EQ (CAAR E) 'MRAT) (RATDX E X))
	((EQ (CAAR E) 'MPLUS) (ADDN (SDIFFMAP (CDR E) X) T))
	((MBAGP E) (CONS (CAR E) (SDIFFMAP (CDR E) X)))
	((MEMQ (CAAR E) '(%SUM %PRODUCT)) (DIFFSUMPROD E X))
	((EQ (CAAR E) '%AT) (DIFF-%AT E X))
	((NOT (DEPENDS E X)) 0)
	((EQ (CAAR E) 'MTIMES) (ADDN (SDIFFTIMES (CDR E) X) T))
	((EQ (CAAR E) 'MEXPT) (DIFFEXPT E X))
	((EQ (CAAR E) 'MNCTIMES)
	 (LET (($DOTDISTRIB T))
	   (ADD2 (NCMULN (CONS (SDIFF (CADR E) X) (CDDR E)) T)
		 (NCMUL2 (CADR E) (SDIFF (CONS '(MNCTIMES) (CDDR E)) X)))))
	((AND $VECT_CROSS (EQ (CAAR E) '|$~|))
	 (ADD2* `((|$~|) ,(CADR E) ,(SDIFF (CADDR E) X))
		`((|$~|) ,(SDIFF (CADR E) X) ,(CADDR E))))
	((EQ (CAAR E) 'MNCEXPT) (DIFFNCEXPT E X))
	((MEMQ (CAAR E) '(%LOG %PLOG))
	 (SDIFFGRAD (COND ((AND (NOT (ATOM (CADR E))) (EQ (CAAADR E) 'MABS))
			   (CONS (CAR E) (CDADR E)))
			  (T E))
		    X))
	((EQ (CAAR E) '%DERIVATIVE)
	 (COND ((OR (ATOM (CADR E)) (MEMQ 'array (CDAADR E))) (CHAINRULE E X))
	       ((FREEL (CDDR E) X) (DIFF%DERIV (CONS (SDIFF (CADR E) X) (CDDR E))))
	       (T (DIFF%DERIV (LIST E X 1)))))
	((MEMQ (CAAR E) '(%BINOMIAL $BETA))
	 (LET ((EFACT ($MAKEFACT E)))
	   (MUL2 (FACTOR (SDIFF EFACT X)) (DIV E EFACT))))
	((EQ (CAAR E) '%INTEGRATE) (DIFFINT E X))
	((EQ (CAAR E) '%LAPLACE) (DIFFLAPLACE E X))
	((EQ (CAAR E) '%AT) (DIFF-%AT E X))
	((MEMQ (CAAR E) '(%REALPART %IMAGPART))
	 (LIST (cons (CAAR E) nil) (SDIFF (CADR E) X)))
	(T (SDIFFGRAD E X))))

(DEFUN SDIFFGRAD (E X)
 (LET ((FUN (CAAR E)) GRAD ARGS)
      (COND ((AND (EQ FUN 'MQAPPLY) (OLDGET (CAAADR E) 'GRAD))
	     (SDIFFGRAD (CONS (cons (CAAADR E) nil) (APPEND (CDADR E) (CDDR E)))
			X))
	    ((OR (EQ FUN 'MQAPPLY) (NULL (SETQ GRAD (OLDGET FUN 'GRAD))))
	     (IF (NOT (DEPENDS E X)) 0 (DIFF%DERIV (LIST E X 1))))
	    ((NOT (= (LENGTH (CDR E)) (LENGTH (CAR GRAD))))
	     (MERROR "Wrong number of arguments for ~:M" FUN))
	    (T (SETQ ARGS (SDIFFMAP (CDR E) X))
	       (ADDN (MAPCAR
		      #'MUL2
		      (CDR (SUBSTITUTEL
			    (CDR E) (CAR GRAD)
			    (DO ((L1 (CDR GRAD) (CDR L1))
				 (ARGS ARGS (CDR ARGS)) (L2))
				((NULL L1) (CONS '(MLIST) (NREVERSE L2)))
				(SETQ L2 (CONS (COND ((EQUAL (CAR ARGS) 0) 0)
						     (T (CAR L1)))
					       L2)))))
		      ARGS)
		     T)))))

(DEFUN SDIFFMAP (E X) (MAPCAR #'(LAMBDA (TERM) (SDIFF TERM X)) E))

(DEFUN SDIFFTIMES (L X)
       (PROG (TERM LEFT OUT)
	LOOP (SETQ TERM (CAR L) L (CDR L))
	     (SETQ OUT (CONS (MULN (CONS (SDIFF TERM X) (APPEND LEFT L)) T) OUT))
	     (IF (NULL L) (RETURN OUT))
	     (SETQ LEFT (CONS TERM LEFT))
	     (GO LOOP)))

(DEFUN DIFFEXPT (E X)
 (IF (MNUMP (CADDR E))
     (MUL3 (CADDR E) (POWER (CADR E) (ADDK (CADDR E) -1)) (SDIFF (CADR E) X))
     (MUL2 E (ADD2 (MUL3 (POWER (CADR E) -1) (CADDR E) (SDIFF (CADR E) X))
		   (MUL2 (SIMPLIFYA (LIST '(%LOG) (CADR E)) T)
			 (SDIFF (CADDR E) X))))))

(DEFUN DIFF%DERIV (E) (LET (DERIVFLAG) (SIMPLIFYA (CONS '(%DERIVATIVE) E) T)))

(PROG1 '(GRAD properties)
 (LET ((HEADER (PURCOPY '(X))))
   (MAPC #'(LAMBDA (Z) (PUTPROP (CAR Z) (CONS HEADER (CDR Z)) 'GRAD))
	; All these GRAD templates have been simplified and then the SIMP flags
	;	 (which are unnecessary) have been removed to save core space.
	 '((%LOG ((MEXPT) X -1)) (%PLOG ((MEXPT) X -1))
	   (%GAMMA ((MTIMES) ((MQAPPLY) (($PSI ARRAY) 0) X) ((%GAMMA) X)))
	   (MFACTORIAL ((MTIMES) ((MQAPPLY) (($PSI ARRAY) 0) ((MPLUS) 1 X))
				 ((MFACTORIAL) X)))
	   (%SIN ((%COS) X))
	   (%COS ((MTIMES) -1 ((%SIN) X)))
	   (%TAN ((MEXPT) ((%SEC) X) 2))
	   (%COT ((MTIMES) -1 ((MEXPT) ((%CSC) X) 2)))
	   (%SEC ((MTIMES) ((%SEC) X) ((%TAN) X)))
	   (%CSC ((MTIMES) -1 ((%COT) X) ((%CSC) X)))
	   (%ASIN ((MEXPT) ((MPLUS) 1 ((MTIMES) -1 ((MEXPT) X 2))) ((RAT) -1 2)))
	   (%ACOS ((MTIMES) -1 ((MEXPT) ((MPLUS) 1 ((MTIMES) -1 ((MEXPT) X 2)))
					((RAT) -1 2))))
	   (%ATAN ((MEXPT) ((MPLUS) 1 ((MEXPT) X 2)) -1))
	   (%ACOT ((MTIMES) -1 ((MEXPT) ((MPLUS) 1 ((MEXPT) X 2)) -1)))
	   (%ACSC ((MTIMES) -1 ((MEXPT) X -1)
			    ((MEXPT) ((MPLUS) -1 ((MEXPT) X 2)) ((RAT) -1 2))))
	   (%ASEC ((MTIMES) ((MEXPT) X -1) ((MEXPT) ((MPLUS) -1 ((MEXPT) X 2)) ((RAT) -1 2))))
	   (%SINH ((%COSH) X))
	   (%COSH ((%SINH) X))
	   (%TANH ((MEXPT) ((%SECH) X) 2))
	   (%COTH ((MTIMES) -1 ((MEXPT) ((%CSCH) X) 2)))
	   (%SECH ((MTIMES) -1 ((%SECH) X) ((%TANH) X)))
	   (%CSCH ((MTIMES) -1 ((%COTH) X) ((%CSCH) X)))
	   (%ASINH ((MEXPT) ((MPLUS) 1 ((MEXPT) X 2)) ((RAT) -1 2)))
	   (%ACOSH ((MEXPT) ((MPLUS) -1 ((MEXPT) X 2)) ((RAT) -1 2)))
	   (%ATANH ((MEXPT) ((MPLUS) 1 ((MTIMES) -1 ((MEXPT) X 2))) -1))
	   (%ACOTH ((MTIMES) -1 ((MEXPT) ((MPLUS) -1 ((MEXPT) X 2)) -1)))
	   (%ASECH ((MTIMES) -1 ((MEXPT) X -1)
			     ((MEXPT) ((MPLUS) 1 ((MTIMES) -1 ((MEXPT) X 2))) ((RAT) -1 2))))
	   (%ACSCH ((MTIMES) -1 ((MEXPT) X -1)
				((MEXPT) ((MPLUS) 1 ((MEXPT) X 2)) ((RAT) -1 2))))
	   (MABS ((MTIMES) X ((MEXPT) ((MABS) X) -1)))
	   (%ERF ((MTIMES) 2 ((MEXPT) $%PI ((RAT) -1 2))
			     ((MEXPT) $%E ((MTIMES) -1 ((MEXPT) X 2)))))
;	   ($LI2 ((MTIMES) -1 ((%LOG) ((MPLUS) 1 ((MTIMES) -1 X))) ((MEXPT) X -1)))
	   ($EI ((MTIMES) ((MEXPT) X -1) ((MEXPT) $%E X)))))) 

 (DEFPROP $ATAN2 ((X Y) ((MTIMES) Y ((MEXPT) ((MPLUS) ((MEXPT) X 2) ((MEXPT) Y 2)) -1))
			((MTIMES) -1 X ((MEXPT) ((MPLUS) ((MEXPT) X 2) ((MEXPT) Y 2)) -1)))
	  GRAD)

 (DEFPROP $%J ((N X) ((%DERIVATIVE) ((MQAPPLY) (($%J ARRAY) N) X) N 1)
		     ((MPLUS) ((MQAPPLY) (($%J ARRAY) ((MPLUS) -1 N)) X)
			      ((MTIMES) -1 N ((MQAPPLY) (($%J ARRAY) N) X) ((MEXPT) X -1))))
	  GRAD)

 (DEFPROP $LI ((N X) ((%DERIVATIVE) ((MQAPPLY) (($LI ARRAY) N) X) N 1)
		     ((MTIMES) ((MQAPPLY) (($LI ARRAY) ((MPLUS) -1 N)) X) ((MEXPT) X -1)))
	  GRAD)

 (DEFPROP $PSI ((N X) ((%DERIVATIVE) ((MQAPPLY) (($PSI ARRAY) N) X) N 1)
		      ((MQAPPLY) (($PSI ARRAY) ((MPLUS) 1 N)) X))
	  GRAD))

(DEFMFUN ATVARSCHK (ARGL)
  (DO ((LARGL (LENGTH ARGL) (f1- LARGL)) (LATVRS (LENGTH ATVARS)) (L))
      ((NOT (< LATVRS LARGL)) (NCONC ATVARS L))
    (SETQ L (CONS (IMPLODE (CONS '& (CONS '@ (MEXPLODEN LARGL)))) L))))

(DEFMFUN NOTLOREQ (X)
  (OR (ATOM X)
      (NOT (MEMQ (CAAR X) '(MLIST MEQUAL)))
      (AND (EQ (CAAR X) 'MLIST)
	   (DOLIST (U (CDR X)) (IF (NOT (MEQUALP U)) (RETURN T))))))

(DEFMFUN SUBSTITUTEL (L1 L2 E)
  (DO ((L1 L1 (CDR L1)) (L2 L2 (CDR L2))) ((NULL L1) E)
    (SETQ E (MAXIMA-SUBSTITUTE (CAR L1) (CAR L2) E))))

(DEFMFUN UNION* (A B)
  (DO ((A A (CDR A)) (X B)) ((NULL A) X)
    (IF (NOT (MEMALIKE (CAR A) B)) (SETQ X (CONS (CAR A) X)))))

(DEFMFUN INTERSECT* (A B)
  (DO ((A A (CDR A)) (X)) ((NULL A) X)
    (IF (MEMALIKE (CAR A) B) (SETQ X (CONS (CAR A) X)))))

(DEFMFUN NTHELEM (N E) (CAR (NTHCDR (f1- N) E)))

(DEFMFUN DELSIMP (E) (DELQ 'SIMP (copy-top-level E) 1))

(DEFMFUN REMSIMP (E)
  (IF (ATOM E) E (CONS (DELSIMP (CAR E)) (MAPCAR #'REMSIMP (CDR E)))))

(DEFMFUN $TRUNC (E)
  (COND ((ATOM E) E)
	((EQ (CAAR E) 'MPLUS) (CONS (APPEND (CAR E) '(TRUNC)) (CDR E)))
	((MBAGP E) (CONS (CAR E) (MAPCAR #'$TRUNC (CDR E))))
	((SPECREPP E) ($TRUNC (SPECDISREP E)))
	(T E)))

(DEFMFUN NONVARCHECK (E FN)
  (IF (OR (MNUMP E)
	  (MAXIMA-INTEGERP E)
	  (AND (NOT (ATOM E)) (NOT (EQ (CAAR E) 'MQAPPLY)) (MOPP1 (CAAR E))))
      (MERROR "Non-variable 2nd argument to ~:M:~%~M" FN E)))

(DEFMSPEC $LDISPLAY (FORM) (DISP1 (CDR FORM) T T))

(DEFMFUN $LDISP N (DISP1 (LISTIFY N) T NIL))

(DEFMSPEC $DISPLAY (FORM) (DISP1 (CDR FORM) NIL T))

(DEFMFUN $DISP N (DISP1 (LISTIFY N) NIL NIL))

(DEFUN DISP1 (LL LABLIST EQNSP)
 (IF LABLIST (SETQ LABLIST (cons '(MLIST SIMP) nil)))
 (DO ((LL LL (CDR LL)) (L) (ANS) ($DISPFLAG T) (TIM 0))
     ((NULL LL) (OR LABLIST '$DONE))
     (SETQ L (CAR LL) ANS (IF EQNSP (MEVAL L) L))
     (IF (AND EQNSP (NOT (MEQUALP ANS)))
	 (SETQ ANS (LIST '(MEQUAL SIMP) (DISP2 L) ANS)))
     (IF LABLIST (NCONC LABLIST (cons (ELABEL ANS) nil)))
     (SETQ TIM (RUNTIME))
     (DISPLA (LIST '(MLABLE) (IF LABLIST LINELABLE) ANS))
     (MTERPRI)
     (TIMEORG TIM)))

(DEFUN DISP2 (E)
  (COND ((ATOM E) E)
	((EQ (CAAR E) 'MQAPPLY)
	 (CONS '(MQAPPLY) (CONS (CONS (CAADR E) (MAPCAR #'MEVAL (CDADR E)))
				(MAPCAR #'MEVAL (CDDR E)))))
	((EQ (CAAR E) 'MSETQ) (DISP2 (CADR E)))
	((EQ (CAAR E) 'MSET) (DISP2 (MEVAL (CADR E))))
	((EQ (CAAR E) 'MLIST) (CONS (CAR E) (MAPCAR #'DISP2 (CDR E))))
	((MSPECFUNP (CAAR E)) E)
	(T (CONS (CAR E) (MAPCAR #'MEVAL (CDR E))))))

(DEFMFUN ELABEL (E)
 (IF (NOT (CHECKLABEL $LINECHAR)) (SETQ $LINENUM (f1+ $LINENUM)))
 (MAKELABEL $LINECHAR)
 (IF (NOT $NOLABELS) (SET LINELABLE E))
 LINELABLE)

(DEFMFUN $DISPTERMS (E)
 (COND ((OR (ATOM E) (EQ (CAAR E) 'BIGFLOAT)) (DISPLA E))
       ((SPECREPP E) ($DISPTERMS (SPECDISREP E)))
       (T (LET (($DISPFLAG T))
	       (MTERPRI)
	       (DISPLA (GETOP (MOP E)))
	       (DO ((E (IF (AND (EQ (CAAR E) 'MPLUS) (NOT $POWERDISP))
			 (REVERSE (CDR E))
			 (MARGS E))
		   (CDR E))) ((NULL E)) (MTERPRI) (DISPLA (CAR E)) (MTERPRI)))
	  (MTERPRI)))
 '$DONE)

(DEFMFUN $DISPFORM N
 (IF (NOT (OR (= N 1) (AND (= N 2) (EQ (ARG 2) '$ALL))))
     (MERROR "Incorrect arguments to DISPFORM"))
 (LET ((E (ARG 1)))
      (IF (OR (ATOM E)
	      (ATOM (SETQ E (IF (= N 1) (NFORMAT E) (NFORMAT-ALL E))))
	      (MEMQ 'SIMP (CDAR E)))
	  E
	  (CONS (CONS (CAAR E) (CONS 'SIMP (CDAR E)))
		(IF (AND (EQ (CAAR E) 'MPLUS) (NOT $POWERDISP))
		    (REVERSE (CDR E))
		    (CDR E))))))

(DEFMFUN $PART N (MPART (LISTIFY N) NIL NIL $INFLAG '$PART))

(DEFMFUN $INPART N (MPART (LISTIFY N) NIL NIL T '$INPART))

(DEFMSPEC $SUBSTPART (L) (LET ((SUBSTP T)) (MPART (CDR L) T NIL $INFLAG '$SUBSTPART)))

(DEFMSPEC $SUBSTINPART (L) (LET ((SUBSTP T)) (MPART (CDR L) T NIL T '$SUBSTINPART)))

(DEFMFUN PART1 (ARGLIST SUBSTFLAG DISPFLAG INFLAG)  ; called only by TRANSLATE
 (LET ((SUBSTP T)) (MPART ARGLIST SUBSTFLAG DISPFLAG INFLAG '$SUBSTPART)))

(DEFMFUN MPART (ARGLIST SUBSTFLAG DISPFLAG INFLAG FN)
       (PROG (SUBSTITEM ARG ARG1 EXP EXP1 EXP* SEVLIST COUNT PREVCOUNT N SPECP
	      LASTELEM LASTCOUNT)
	     #-cl(DECLARE (FIXNUM PREVCOUNT LASTELEM LASTCOUNT))
	     (SETQ SPECP (OR SUBSTFLAG DISPFLAG))
	     (IF SUBSTFLAG (SETQ SUBSTITEM (CAR ARGLIST) ARGLIST (CDR ARGLIST)))
	     (IF (NULL ARGLIST) (WNA-ERR '$PART))
	     (SETQ EXP (IF SUBSTFLAG (MEVAL (CAR ARGLIST)) (CAR ARGLIST)))
	     (WHEN (NULL (SETQ ARGLIST (CDR ARGLIST)))
		   (SETQ $PIECE EXP)
		   (RETURN (COND (SUBSTFLAG (MEVAL SUBSTITEM))
				 (DISPFLAG (BOX EXP DISPFLAG))
				 (T EXP))))
	     (COND ((NOT INFLAG)
		    (COND ((OR (AND ($LISTP EXP) (NULL (CDR ARGLIST)))
			       (AND ($MATRIXP EXP)
				    (OR (NULL (CDR ARGLIST)) (NULL (CDDR ARGLIST)))))
			   (SETQ INFLAG T))
			  ((NOT SPECP) (SETQ EXP (NFORMAT EXP)))
			  (T (SETQ EXP (NFORMAT-ALL EXP)))))
		   ((SPECREPP EXP) (SETQ EXP (SPECDISREP EXP))))
	     (IF (AND (ATOM EXP) (NULL $PARTSWITCH))
		 (MERROR "~:M called on atom: ~:M" FN EXP))
	     (IF (AND INFLAG SPECP) (SETQ EXP (copy-all-levels EXP)))
	     (SETQ EXP* EXP)
	START(COND ((OR (ATOM EXP) (EQ (CAAR EXP) 'BIGFLOAT)) (GO ERR))
		   ((EQUAL (SETQ ARG (COND (SUBSTFLAG (MEVAL (CAR ARGLIST)))
					   (T (CAR ARGLIST))))
			   0)
		    (SETQ ARGLIST (CDR ARGLIST))
		    (COND ((MNUMP SUBSTITEM)
			   (MERROR "~M is an invalid operator in ~:M"
				   SUBSTITEM FN))
			  ((AND SPECP ARGLIST)
			   (IF (EQ (CAAR EXP) 'MQAPPLY)
			       (PROG2 (SETQ EXP (CADR EXP)) (GO START))
			       (MERROR "Invalid operator in ~:M" FN)))
			  (T (SETQ $PIECE (GETOP (MOP EXP)))
			     (RETURN
			      (COND (SUBSTFLAG
				     (SETQ SUBSTITEM (GETOPR (MEVAL SUBSTITEM)))
				     (COND ((MNUMP SUBSTITEM)
					    (MERROR "Invalid operator in ~:M:~%~M"
						    FN SUBSTITEM))
					   ((NOT (ATOM SUBSTITEM))
					    (IF (NOT (EQ (CAAR EXP) 'MQAPPLY))
						(RPLACA (RPLACD EXP (CONS (CAR EXP)
									  (CDR EXP)))
							'(MQAPPLY)))
					    (RPLACA (CDR EXP) SUBSTITEM)
					    (RETURN (RESIMPLIFY EXP*)))
					   ((EQ (CAAR EXP) 'MQAPPLY)
					    (RPLACD EXP (CDDR EXP))))
				     (RPLACA EXP (CONS SUBSTITEM
						       (IF (AND (MEMQ 'array (CDAR EXP))
								(NOT (MOPP SUBSTITEM)))
							   '(ARRAY))))
				     (RESIMPLIFY EXP*))
				    (DISPFLAG
				     (RPLACD EXP (CDR (BOX (copy-all-levels EXP) DISPFLAG)))
				     (RPLACA EXP (IF (EQ DISPFLAG T)
						     '(MBOX)
						     '(MLABOX)))
				     (RESIMPLIFY EXP*))
				    (T (WHEN ARGLIST (SETQ EXP $PIECE) (GO A))
				       $PIECE))))))
		   ((NOT (ATOM ARG)) (GO SEVERAL))
		   ((NOT (FIXNUMP ARG))
		    (MERROR "Non-integer argument to ~:M:~%~M" FN ARG))
		   ((< ARG 0) (GO BAD)))
	     (IF (EQ (CAAR EXP) 'MQAPPLY) (SETQ EXP (CDR EXP)))
	LOOP (COND ((NOT (ZEROP ARG)) (SETQ ARG (f1- ARG) EXP (CDR EXP))
				      (IF (NULL EXP) (GO ERR)) (GO LOOP))
		   ((NULL (SETQ ARGLIST (CDR ARGLIST)))
		    (RETURN (COND (SUBSTFLAG (SETQ $PIECE (RESIMPLIFY (CAR EXP)))
					     (RPLACA EXP (MEVAL SUBSTITEM))
					     (RESIMPLIFY EXP*))
				  (DISPFLAG (SETQ $PIECE (RESIMPLIFY (CAR EXP)))
					    (RPLACA EXP (BOX (CAR EXP) DISPFLAG))
					    (RESIMPLIFY EXP*))
				  (INFLAG (SETQ $PIECE (CAR EXP)))
				  (T (SETQ $PIECE (SIMPLIFY (CAR EXP))))))))
	     (SETQ EXP (CAR EXP))
	A    (COND ((AND (NOT INFLAG) (NOT SPECP)) (SETQ EXP (NFORMAT EXP)))
		   ((SPECREPP EXP) (SETQ EXP (SPECDISREP EXP))))
	     (GO START)
	ERR  (COND ((EQ $PARTSWITCH 'MAPPLY)
		    (MERROR "Improper index to list or matrix"))
		   ($PARTSWITCH (RETURN (SETQ $PIECE '$END)))
		   (T (MERROR "~:M fell off end." FN)))
	BAD  (IMPROPER-ARG-ERR ARG FN)
	SEVERAL
	     (IF (OR (NOT (MEMQ (CAAR ARG) '(MLIST $ALLBUT))) (CDR ARGLIST))
		 (GO BAD))
	     (SETQ EXP1 (CONS (CAAR EXP) (IF (MEMQ 'array (CDAR EXP)) '(ARRAY))))
	     (IF (EQ (CAAR EXP) 'MQAPPLY)
		 (SETQ SEVLIST (LIST (CADR EXP) EXP1) EXP (CDDR EXP))
		 (SETQ SEVLIST (NCONS EXP1) EXP (CDR EXP)))
	     (SETQ ARG1 (CDR ARG) PREVCOUNT 0 EXP1 EXP)
	     (DOLIST (ARG* ARG1)
		     (IF (NOT (FIXNUMP ARG*))
			 (MERROR "Non-integer argument to ~:M:~%~M" FN ARG*)))
	     (WHEN (AND SPECP (EQ (CAAR ARG) 'MLIST))
		   (IF SUBSTFLAG (SETQ LASTELEM (CAR (LAST ARG1))))
		   (SETQ ARG1 (SORT (copy-top-level ARG1) #'<)))
	     (WHEN (EQ (CAAR ARG) '$ALLBUT)
		   (SETQ N (LENGTH EXP))
		   (DOLIST (I ARG1)
			   (IF (OR (< I 1) (> I N))
			       (MERROR "Invalid argument to ~:M:~%~M" FN I)))
		   (DO ((I N (f1- I)) (ARG2))
		       ((= I 0) (SETQ ARG1 ARG2))
		       (IF (NOT (zl-MEMBER I ARG1)) (SETQ ARG2 (CONS I ARG2))))
		   (IF SUBSTFLAG (SETQ LASTELEM (CAR (LAST ARG1)))))
	     (IF (NULL ARG1) (IF SPECP (GO BAD) (GO END)))
	     (IF SUBSTFLAG (SETQ LASTCOUNT LASTELEM))
	SEVLOOP
	     (IF SPECP
		 (SETQ COUNT (f- (CAR ARG1) PREVCOUNT) PREVCOUNT (CAR ARG1))
		 (SETQ COUNT (CAR ARG1)))
	     (IF (< COUNT 1) (GO BAD))
	     (IF (AND SUBSTFLAG (< (CAR ARG1) LASTELEM))
		 (SETQ LASTCOUNT (f1- LASTCOUNT)))
	COUNT(COND ((NULL EXP) (GO ERR))
		   ((NOT (= COUNT 1)) (SETQ COUNT (f1- COUNT) EXP (CDR EXP)) (GO COUNT)))
	     (SETQ SEVLIST (CONS (CAR EXP) SEVLIST))
	     (SETQ ARG1 (CDR ARG1))
	END  (COND ((NULL ARG1)
		    (SETQ SEVLIST (NREVERSE SEVLIST))
		    (SETQ $PIECE (IF (OR INFLAG (NOT SPECP))
				     (SIMPLIFY SEVLIST)
				     (RESIMPLIFY SEVLIST)))
		    (RETURN (COND (SUBSTFLAG (RPLACA (NTHCDR (f1- LASTCOUNT) EXP1)
						     (MEVAL SUBSTITEM))
					     (RESIMPLIFY EXP*))
				  (DISPFLAG (RPLACA EXP (BOX (CAR EXP) DISPFLAG))
					    (RESIMPLIFY EXP*))
				  (T $PIECE))))
		   (SUBSTFLAG (IF (NULL (CDR EXP)) (GO ERR))
			      (RPLACA EXP (CADR EXP)) (RPLACD EXP (CDDR EXP)))
		   (DISPFLAG (RPLACA EXP (BOX (CAR EXP) DISPFLAG))
			     (SETQ EXP (CDR EXP)))
		   (T (SETQ EXP EXP1)))
	     (GO SEVLOOP)))

(DEFMFUN GETOP (X) (OR (AND (SYMBOLP X) (GET X 'OP)) X))

(DEFMFUN GETOPR (X) (OR (AND (SYMBOLP X) (GET X 'OPR)) x))
			

#-Franz
(DEFMFUN $LISTP (X) (AND (NOT (ATOM X))
			 (not (atom (car x)))
			 (EQ (CAAR X) 'MLIST)))

#+Franz  ;; -Franz uses a macro definition in MAXMAC.
(defmfun mlistp (x)
  (and (not (atom x))
       (or (eq (caar x) 'mlist) ($featurep (caar x) '$list))))

#+Franz
(putd '$listp (getd 'mlistp))

(DEFMFUN $CONS (X E)
  (ATOMCHK (SETQ E (SPECREPCHECK E)) '$CONS T)
  (MCONS-EXP-ARGS E (CONS X (MARGS E))))

(DEFMFUN $ENDCONS (X E)
  (ATOMCHK (SETQ E (SPECREPCHECK E)) '$ENDCONS T)
  (MCONS-EXP-ARGS E (APPEND (MARGS E) (NCONS X))))

(DEFMFUN $REVERSE (E)
  (ATOMCHK (SETQ E (FORMAT1 E)) '$REVERSE NIL)
  (MCONS-EXP-ARGS E (REVERSE (MARGS E))))

(DEFMFUN $APPEND N
  (IF (= N 0)
      '((MLIST SIMP))
      (LET ((ARG1 (SPECREPCHECK (ARG 1))) OP ARRP)
	(ATOMCHK ARG1 '$APPEND NIL)
	(SETQ OP (MOP ARG1) ARRP (IF (MEMQ 'array (CDAR ARG1)) T))
	(MCONS-EXP-ARGS
	 ARG1
	 (APPLY #'APPEND
		(MAPCAR #'(LAMBDA (U)
			   (ATOMCHK (SETQ U (SPECREPCHECK U)) '$APPEND NIL)
			   (IF (OR (NOT (ALIKE1 OP (MOP U)))
				   (NOT (EQ ARRP (IF (MEMQ 'array (CDAR U)) T))))
			       (MERROR "Arguments to APPEND are not compatible."))
			   (MARGS U))
			(LISTIFY N)))))))

(DEFUN MCONS-EXP-ARGS (E ARGS)
  (IF (EQ (CAAR E) 'MQAPPLY)
      (LIST* (DELSIMP (CAR E)) (CADR E) ARGS)
      (CONS (IF (MLISTP E) (CAR E) (DELSIMP (CAR E))) ARGS)))

(DEFMFUN $MEMBER (X E)
  (ATOMCHK (SETQ E ($TOTALDISREP E)) '$MEMBER T)
  (IF (MEMALIKE ($TOTALDISREP X) (MARGS E)) T))

(DEFMFUN ATOMCHK (E FUN 2NDP)
  (IF (OR (ATOM E) (EQ (CAAR E) 'BIGFLOAT))
      (MERROR "~Margument value `~M' to ~:M was not a list"
	      (IF 2NDP '|2nd | "") E FUN)))

(DEFMFUN FORMAT1 (E)
  (COND (($LISTP E) E) ($INFLAG (SPECREPCHECK E)) (T (NFORMAT E))))

(DEFMFUN $FIRST (E)
  (ATOMCHK (SETQ E (FORMAT1 E)) '$FIRST NIL)
  (IF (NULL (CDR E)) (MERROR "Argument to FIRST is empty."))
  (CAR (MARGS E)))

(DEFMFUN $REST N
  (PROG (M FUN FUN1 REVP)
	(IF (AND (= N 2) (EQUAL (ARG 2) 0)) (RETURN (ARG 1)))
	(ATOMCHK (SETQ M (FORMAT1 (ARG 1))) '$REST NIL)
	(COND ((= N 1))
	      ((NOT (= N 2)) (WNA-ERR '$REST))
	      ((NOT (FIXNUMP (ARG 2)))
	       (MERROR "2nd argument to REST must be an integer:~%~M"
		       (ARG 2)))
	      ((MINUSP (SETQ N (ARG 2))) (SETQ N (f- N) REVP T)))
	(IF (< (LENGTH (MARGS M)) N)
	    (IF $PARTSWITCH (RETURN '$END) (MERROR "REST fell off end.")))
	(SETQ FUN (CAR M))
	(IF (EQ (CAR FUN) 'MQAPPLY) (SETQ FUN1 (CADR M) M (CDR M)))
	(SETQ M (CDR M))
	(IF REVP (SETQ M (REVERSE M)))
	(DO ((N N (f1- N))) ((ZEROP N)) (SETQ M (CDR M)))
	(SETQ M (CONS (IF (EQ (CAR FUN) 'MLIST) FUN (DELSIMP FUN))
		      (IF REVP (NREVERSE M) M)))
	(IF (EQ (CAR FUN) 'MQAPPLY)
	    (RETURN (CONS (CAR M) (CONS FUN1 (CDR M)))))
	(RETURN M)))

(DEFMFUN $LAST (E)
  (ATOMCHK (SETQ E (FORMAT1 E)) '$LAST NIL)
  (IF (NULL (CDR E)) (MERROR "Argument to LAST is empty."))
  (CAR (LAST E)))

(DEFMFUN $ARGS (E) (ATOMCHK (SETQ E (FORMAT1 E)) '$ARGS NIL)
		   (CONS '(MLIST) (MARGS E)))

(DEFMFUN $DELETE N
  (COND ((= N 2) (SETQ N -1))
	((NOT (= N 3)) (WNA-ERR '$DELETE))
	((OR (NOT (FIXNUMP (ARG 3))) (MINUSP (SETQ N (ARG 3))))
	 (MERROR "Improper 3rd argument to DELETE:~%~M" (ARG 3))))
  (LET ((X (ARG 1)) (L (ARG 2)))
    (ATOMCHK (SETQ L (SPECREPCHECK L)) '$DELETE T)
    (SETQ X (SPECREPCHECK X) L (CONS (DELSIMP (CAR L)) (copy-top-level (CDR L))))
    (PROG (L1)
	  (SETQ L1 (IF (EQ (CAAR L) 'MQAPPLY) (CDR L) L))
     LOOP (COND ((OR (NULL (CDR L1)) (ZEROP N)) (RETURN L))
		((ALIKE1 X (SPECREPCHECK (CADR L1)))
		 (SETQ N (f1- N)) (RPLACD L1 (CDDR L1)))
		(T (SETQ L1 (CDR L1))))
	  (GO LOOP))))

(DEFMFUN $LENGTH (E)
 (SETQ E (COND (($LISTP E) E)
	       ((OR $INFLAG (NOT ($RATP E))) (SPECREPCHECK E))
	       (T ($RATDISREP E))))
 (COND ((SYMBOLP E) (MERROR "LENGTH called on atomic symbol ~:M" E))
       ((OR (NUMBERP E) (EQ (CAAR E) 'BIGFLOAT))
	(IF (AND (NOT $INFLAG) (MNEGP E))
	    1
	    (MERROR "LENGTH called on number ~:M" E)))
       ((OR $INFLAG (NOT (MEMQ (CAAR E) '(MTIMES MEXPT)))) (LENGTH (MARGS E)))
       ((EQ (CAAR E) 'MEXPT)
	(IF (AND (ALIKE1 (CADDR E) '((RAT SIMP) 1 2)) $SQRTDISPFLAG) 1 2))
       (T (LENGTH (CDR (NFORMAT E))))))

(DEFMFUN $ATOM (X)
 (SETQ X (SPECREPCHECK X)) (OR (ATOM X) (EQ (CAAR X) 'BIGFLOAT)))

(DEFMFUN $SYMBOLP (X) (SETQ X (SPECREPCHECK X)) (SYMBOLP X))

(DEFMFUN $NUM (E)
 (LET (X)
      (COND ((ATOM E) E)
	    ((EQ (CAAR E) 'MRAT) ($RATNUMER E))
	    ((EQ (CAAR E) 'RAT) (CADR E))
	    ((EQ (CAAR (SETQ X (NFORMAT E))) 'MQUOTIENT) (SIMPLIFY (CADR X)))
	    ((AND (EQ (CAAR X) 'MMINUS) (NOT (ATOM (SETQ X (CADR X))))
		  (EQ (CAAR X) 'MQUOTIENT))
	     (SIMPLIFY (LIST '(MTIMES) -1 (CADR X))))
	    (T E))))

(DEFMFUN $DENOM (E)
 (COND ((ATOM E) 1)
       ((EQ (CAAR E) 'MRAT) ($RATDENOM E))
       ((EQ (CAAR E) 'RAT) (CADDR E))
       ((OR (EQ (CAAR (SETQ E (NFORMAT E))) 'MQUOTIENT)
	    (AND (EQ (CAAR E) 'MMINUS) (NOT (ATOM (SETQ E (CADR E))))
		 (EQ (CAAR E) 'MQUOTIENT)))
	(SIMPLIFY (CADDR E)))
       (T 1)))


(DEFMFUN $FIX (E) ($ENTIER E))

(DEFMFUN $ENTIER (E) 
 (LET ((E1 (SPECREPCHECK E)))
      (COND ((NUMBERP E1) (FIX E1))
	    ((RATNUMP E1) (SETQ E (QUOTIENT (CADR E1) (CADDR E1)))
			  (IF (MINUSP (CADR E1)) (SUB1 E) E))
	    (($BFLOATP E1)
	     (SETQ E (FPENTIER E1))
	     (IF (AND (MINUSP (CADR E1)) (NOT (ZEROP1 (SUB E E1))))
		 (SUB1 E)
		 E))
	    (T (LIST '($ENTIER) E)))))

(DEFMFUN $FLOAT (E) 
 (COND ((NUMBERP E) (FLOAT E))
       ((and (symbolp e) (mget e '$numer)))
       ((OR (ATOM E) (MEMQ 'array (CDAR E))) E)
       ((EQ (CAAR E) 'RAT) (FPCOFRAT E))
       ((EQ (CAAR E) 'BIGFLOAT) (FP2FLO E))
       ((MEMQ (CAAR E) '(MEXPT MNCEXPT))
	(LIST (NCONS (CAAR E)) ($FLOAT (CADR E)) (CADDR E)))
       (T (RECUR-APPLY #'$FLOAT E))))

(DEFMFUN $COEFF N
 (COND ((= N 3) (IF (EQUAL (ARG 3) 0)
		    (COEFF (ARG 1) (ARG 2) (ARG 3))
		    (COEFF (ARG 1) (POWER (ARG 2) (ARG 3)) 1)))
       ((= N 2) (COEFF (ARG 1) (ARG 2) 1))
       (T (WNA-ERR '$COEFF))))

(DEFMFUN COEFF (E VAR POW)
 (SIMPLIFY
  (COND ((ALIKE1 E VAR) (IF (EQUAL POW 1) 1 0))
	((ATOM E) (IF (EQUAL POW 0) E 0))
	((EQ (CAAR E) 'MEXPT)
	 (COND ((ALIKE1 (CADR E) VAR)
		(IF (OR (EQUAL POW 0) (NOT (ALIKE1 (CADDR E) POW))) 0 1))
	       ((EQUAL POW 0) E)
	       (T 0)))
	((OR (EQ (CAAR E) 'MPLUS) (MBAGP E))
	 (CONS (IF (EQ (CAAR E) 'MPLUS) '(MPLUS) (CAR E))
	       (MAPCAR #'(LAMBDA (E) (COEFF E VAR POW)) (CDR E))))
	((EQ (CAAR E) 'MRAT) (RATCOEFF E VAR POW))
	((EQUAL POW 0) (IF (FREE E VAR) E 0))
	((EQ (CAAR E) 'MTIMES)
	 (LET ((TERM (IF (EQUAL POW 1) VAR (POWER VAR POW))))
	      (IF (MEMALIKE TERM (CDR E)) ($DELETE TERM E 1) 0)))
	(T 0))))

(DECLARE-TOP (SPECIAL POWERS VAR HIFLG NUM FLAG))

(DEFMFUN $HIPOW (E VAR) (FINDPOWERS E T))
			; These work best on expanded "simple" expressions.

(DEFMFUN $LOPOW (E VAR) (FINDPOWERS E NIL))

(DEFUN FINDPOWERS (E HIFLG)
 (LET (POWERS NUM FLAG)
      (FINDPOWERS1 E)
      (COND ((NULL POWERS) (IF (NULL NUM) 0 NUM))
	    (T (IF NUM (SETQ POWERS (CONS NUM POWERS)))
	       (MAXIMIN POWERS (IF HIFLG '$MAX '$MIN))))))

(DEFUN FINDPOWERS1 (E)
 (COND ((ALIKE1 E VAR) (CHECKPOW 1))
       ((ATOM E))
       ((EQ (CAAR E) 'MPLUS)
	(COND ((NOT (FREEL (CDR E) VAR))
	       (DO ((E (CDR E) (CDR E))) ((NULL E))
		   (SETQ FLAG NIL) (FINDPOWERS1 (CAR E))
		   (IF (NULL FLAG) (CHECKPOW 0))))))
       ((AND (EQ (CAAR E) 'MEXPT) (ALIKE1 (CADR E) VAR)) (CHECKPOW (CADDR E)))
       ((SPECREPP E) (FINDPOWERS1 (SPECDISREP E)))
       (T (MAPC #'FINDPOWERS1 (CDR E)))))

(DEFUN CHECKPOW (POW)
 (SETQ FLAG T)
 (COND ((NOT (NUMBERP POW)) (SETQ POWERS (CONS POW POWERS)))
       ((NULL NUM) (SETQ NUM POW))
       (HIFLG (IF (GREATERP POW NUM) (SETQ NUM POW)))
       ((LESSP POW NUM) (SETQ NUM POW))))

(DECLARE-TOP (UNSPECIAL POWERS VAR HIFLG NUM FLAG))


; Undeclarations for the file:
(DECLARE-TOP (NOTYPE I N LARGL LVRS COUNT TIM))