(SETQ BASE 10.)
(SETQ IBASE 10.)
(SETQ *NOPOINT T)

(PUTPROP @PRIN (GET PRINC SUBR) SUBR)
(PUTPROP @TEREAD (GET CLRBFI SUBR) SUBR)

(DE EVENP (X) (EQ X (MUL 2 (INTEGER (DIV X 2]

(SETQ PERIOD @/.)
(SETQ BLANK @/ )
(SETQ LPAR @/()
(SETQ RPAR @/))
(SETQ DASH @/-)
(SETQ PLUSS @/+)
(SETQ UPARROW @/^)
(SETQ SLASH @//)
(SETQ STAR @/*)
(SETQ COMMA @/,)
(SETQ CR (IASCII 13))

(SETQ DIGITS
      @((/0 0)(/1 1)(/2 2)(/3 3)(/4 4)(/5 5)(/6 6)(/7 7)(/8 8)(/9 9)))


(SETQ ALPHA @(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z))

(DE IN2PRE (E)
  (PROG (X)
	(SETQ X (EXPRESSION E))
	(COND ((OR (NULL X) (CDR X))
	       (PRINT (QUOTE (POORLY FORMED EXPRESSED))))
	      (T (RETURN (CAR X]

(DE DIGIT (E)
  (PROG (X)
	(SETQ X (ASSOC (CAR E) DIGITS))
	(COND ((NULL X) (RETURN NIL))
	      (T (RETURN (CONS (CADR X) (CDR E]

(DE VARIABLE (E)
  (COND ((MEMBER (CAR E) ALPHA) E)
	(T NIL]

(DE CONSTANT (E)
  (PROG (X Y)
	(COND ((NULL (SETQ X (DIGIT E))) (RETURN NIL)))
   A	(SETQ Y (CONS (CAR X) Y))
	(SETQ E (CDR E))
	(COND  ((OR (NULL E) (NULL (SETQ X (DIGIT E))))
		(RETURN (CONS (NUMBER (REVERSE Y)) E))))
	(GO A]

(DE NUMBER (E)
  (PROG (X)
	(SETQ X 0)
   A	(COND ((NULL E) (RETURN X)))
	(SETQ X (PLUS (TIMES X 10) (CAR E)))
	(SETQ E (CDR E))
	(GO A]

(DE PRIMARY (E)
  (PROG (X)
	(COND ((SETQ X (VARIABLE E)) (RETURN X))
	      ((SETQ X (CONSTANT E)) (RETURN X))
	      ((NOT (EQ (CAR E) LPAR)) (RETURN NIL))
	      ((NOT (SETQ X (EXPRESSION (CDR E)))) (RETURN NIL))
	      ((NULL (CDR X)) (RETURN NIL))
	      ((EQ (CADR X) RPAR) (RETURN (CONS (CAR X) (CDDR X))))
	      (T NIL]

(DE SECONDARY (E)
  (PROG (X Y)
	(COND ((NULL (SETQ X (PRIMARY E))) (RETURN NIL))
	      ((NULL (CDR X)) (RETURN X))
	      ((NOT (EQ (CADR X) UPARROW)) (RETURN X))
	      ((SETQ Y (CONSTANT (CDDR X)))
		(RETURN (CONS (LIST (QUOTE EXPT) (CAR X) (CAR Y)) (CDR Y))))
	      (T (RETURN NIL]

(DE TERM (E)
  (PROG (X Y Z)
	(SETQ X (SECONDARY E))
	(COND ((OR (NULL X) (NULL (CDR X))) (RETURN X)))
	(SETQ Z (CDDR X))
	(SETQ Y (QUOTE QUOTIENT))
	(COND ((EQ (CADR X) SLASH) (GO A)))
	(SETQ Y (QUOTE TIMES))
	(COND ((EQ (CADR X) STAR) (GO A)))
	(SETQ Z (CDR X))
   A	(COND ((SETQ Z (TERM Z))
		(RETURN (CONS (LIST Y (CAR X) (CAR Z)) (CDR Z))))
	      (T (RETURN X]

(DE EXPRESSION (E)
  (PROG (EXP X Y OP)
	(COND ((NULL E) (RETURN NIL))
	      ((NULL (SETQ X (TERM E))) (RETURN NIL)))
	(SETQ EXP (CAR X))
   E	(COND ((NULL (CDR X)) (RETURN (NCONS EXP)))
	      ((EQ (CADR X) PLUSS) (SETQ OP (QUOTE PLUS)))
	      ((EQ (CADR X) DASH) (SETQ OP (QUOTE DIFFERENCE)))
	      (T (RETURN (CONS EXP (CDR X)))))
	(COND ((NULL (SETQ Y (TERM (CDDR X)))) (RETURN NIL)))
	(SETQ EXP (LIST OP EXP (CAR Y)))
	(SETQ X Y)
	(GO E))))

(DE DERIV (E X)
  (COND ((ATOM E) (COND ((EQ E X) 1) (T 0)))
	((OR (EQ (CAR E) (QUOTE PLUS)) (EQ (CAR E) (QUOTE DIFFERENCE)))
	  (LIST (CAR E) (DERIV (CADR E) X) (DERIV (CADDR E) X)))
	((EQ (CAR E) (QUOTE TIMES))
	  (LIST (QUOTE PLUS)
	    (LIST (CAR E) (CADDR E) (DERIV (CADR E) X))
	    (LIST (CAR E) (CADR E) (DERIV (CADDR E) X))))
	((EQ (CAR E) (QUOTE QUOTIENT))
	  (LIST (CAR E)
	    (LIST (QUOTE DIFFERENCE)
	      (LIST (QUOTE TIMES) (CADDR E) (DERIV (CADR E) X))
	      (LIST (QUOTE TIMES) (CADR E) (DERIV (CADDR E) X)))
	    (LIST (QUOTE TIMES) (CADDR E) (CADDR E))))
	((EQ (CAR E) (QUOTE EXPT))
	  (LIST (QUOTE TIMES)
	    (LIST (QUOTE TIMES) (CADDR E)
	      (COND ((EQUAL (CADDR E) 2) (CADR E))
		    (T (LIST (CAR E) (CADR E) (SUB1 (CADDR E))))))
	    (DERIV (CADR E) X)))
	(T NIL]

(DE SIMPLIFY (E)
  (PROG (A B C D)
	(COND ((ATOM E) (RETURN E)))
	(SETQ A (SIMPLIFY (CADR E)))
	(COND ((EQ (SETQ C (CAR E)) (QUOTE MINUS))
		(RETURN (SMINUS (LIST C A)))))
	(SETQ B (SIMPLIFY (CADDR E)))
	(COND ((EQ C (QUOTE DIFFERENCE))
		(RETURN (SPLUS (LIST (QUOTE PLUS)
		  (SMINUS (LIST (QUOTE MINUS) B)) A)))))
	(SETQ D (LIST C A B))
	(RETURN (SELECTQ C (PLUS (SPLUS D))
			   (TIMES (STIMES D))
			   (QUOTIENT (SQUOTIENT D))
			   (EXPT (SEXPT D))
			   D]

(DE SPLUS (E)
  (COND ((NUMBERP (CADDR E))
	  (COND ((NUMBERP (CADR E)) (EVAL E))
		((ZEROP (CADDR E)) (CADR E))
		(T (COLLECT (LIST (CAR E) (CADDR E) (CADR E))))))
	((AND (NUMBERP (CADR E)) (ZEROP (CADR E))) (CADDR E))
	((EQUAL (CADR E) (CADDR E))
	  (COLLECT (LIST (QUOTE TIMES) 2 (CADR E))))
	((AND (NOT (ATOM (CADR E))) (EQ (CAADR E) (QUOTE MINUS)))
	  (COND ((AND (NOT (ATOM (CADDR E)))
		      (EQ (CAADDR E) (QUOTE MINUS)))
		  (LIST (QUOTE MINUS)
			(COLLECT (LIST (CAR E)
				       (CADADR E)
				       (CADR (CADDR E))))))
		((EQUAL (CADADR E) (CADDR E)) 0)
		(T (COLLECT (LIST (CAR E) (CADDR E) (CADR E))))))
	((AND (NOT (ATOM (CADDR E))) (EQ (CAADDR E) (QUOTE MINUS)))
	  (COND ((EQUAL (CADR (CADDR E)) (CADR E)) 0)
		(T (COLLECT E))))
	(T (COLLECT E]

(DE STIMES (E)
  (COND ((NUMBERP (CADDR E))
	  (COND ((NUMBERP (CADR E)) (EVAL E))
		((ZEROP (CADDR E)) 0)
		((ONEP (CADDR E)) (CADR E))
		(T (COLLECT (LIST (CAR E) (CADDR E) (CADR E))))))
	((NUMBERP (CADR E))
	  (COND ((ZEROP (CADR E)) 0)
		((ONEP (CADR E)) (CADDR E))
		(T (COLLECT E))))
	((EQUAL (CADR E) (CADDR E))
	  (SEXPT (LIST (QUOTE EXPT) (CADR E) 2)))
	((AND (NOT (ATOM (CADR E))) (EQ (CAADR E) (QUOTE MINUS)))
	  (COND ((AND (NOT (ATOM (CADDR E)))
		      (EQ (CAADDR E) (QUOTE MINUS)))
		  (COLLECT (LIST (CAR E) (CADADR E) (CADR (CADDR E)))))
		((EQUAL (CADADR E) (CADDR E))
		  (LIST (QUOTE MINUS) (LIST (QUOTE EXPT) (CADDR E) 2)))
		(T (COLLECT (LIST (CAR E) (CADDR E) (CADR E))))))
	((AND (NOT (ATOM (CADDR E))) (EQ (CAADDR E) (QUOTE MINUS)))
	  (COND ((EQUAL (CADR (CADDR E)) (CADR E))
		  (LIST (QUOTE MINUS) (LIST (QUOTE EXPT) (CADR E) 2)))
		(T (COLLECT E))))
	(T (COLLECT E]

(DE COLLECT (E)
  (COND ((ATOM E) E)
	((ATOM (CADDR E))
	  (COND ((ATOM (CADR E)) E)
		(T (COLLECT (LIST (CAR E) (CADDR E) (CADR E))))))
	((AND (EQ (CAR E) (CAADDR E)) (NUMBERP (CADR (CADDR E))))
	  (COND ((NUMBERP (CADR E))
		  (LIST (CAR E)
			(EVAL (LIST (CAR E) (CADR E) (CADR (CADDR E))))
			(CADDR (CADDR E))))
		((ATOM (CADR E)) E)
		((AND (EQ (CAR E) (CAADR E)) (NUMBERP (CADADR E)))
		  (LIST (CAR E)
			(EVAL (LIST (CAR E) (CADADR E) (CADR (CADDR E))))
			(LIST (CAR E) (CADDR (CADR E))
			      (CADDR (CADDR E)))))
		(T E)))
	(T E]

(DE SQUOTIENT (E)
  (COND ((EQUAL (CADR E) (CADDR E)) 1)
	((AND (NUMBERP (CADR E)) (ZEROP (CADR E))) 0)
	((AND (NUMBERP (CADR E)) (ONEP (CADR E))) E)
	((NUMBERP (CADDR E))
	  (COND ((NUMBERP (CADR E)) (EVAL E))
		((ONEP (CADDR E)) (CADR E))
		(T (COLLECT (LIST (QUOTE TIMES)
				 (QUOTIENT 1.0 (CADDR E)) (CADR E))))))
	((AND (NOT (ATOM (CADDR E))) (EQ (CAADDR E) (QUOTE MINUS)))
	  (STIMES (LIST (QUOTE TIMES) (CADR E)
			(LIST (QUOTE MINUS)
			      (LIST (QUOTE QUOTIENT)
				    1 (CADR (CADDR E)))))))
	(T (STIMES (LIST (QUOTE TIMES) (CADR E)
			 (LIST (QUOTE QUOTIENT) 1 (CADDR E]

(DE SEXPT (E)
  (COND ((ZEROP (CADDR E)) 1)
	((ONEP (CADDR E)) (CADR E))
	((NUMBERP (CADR E)) (EVAL E))
	((ATOM (CADR E)) E)
	((EQ (CAADR E) (QUOTE EXPT))
	  (LIST (QUOTE EXPT) (CADADR E)
		(TIMES (CADDR E) (CADDR (CADR E)))))
	((NOT (EQ (CAADR E) (QUOTE MINUS))) E)
	((EVENP (CADDR E))
	  (SEXPT (LIST (QUOTE EXPT) (CADADR E) (CADDR E))))
	(T (LIST (QUOTE MINUS)
		 (SEXPT (LIST (QUOTE EXPT) (CADADR E) (CADDR E]

(DE SMINUS (E)
  (COND ((NUMBERP (CADR E)) (EVAL E))
	((AND (NOT (ATOM (CADR E)))
	      (EQ (CAADR E) (QUOTE MINUS))) (CADADR E))
	(T E]

(DE PRE2IN (E)
  (PROG ()
	(COND ((NUMBERP E) (PROG2 (PRIN E) (PRIN BLANK)))
	      ((ATOM E) (PRIN E))
	      (T (SELECTQ (CAR E)
			  (PLUS (XPLUS E))
			  (MINUS (XMINUS E))
			  (TIMES (XTIMES E))
			  (QUOTIENT (XQUOTIENT E))
			  (EXPT (XEXPT E)) E]

(DE XPLUS (E)
  (PROG ()
	(COND ((NUMBERP (CADR E))
		(RETURN (XPLUS (LIST (CAR E) (CADDR E) (CADR E))))))
	(PRE2IN (CADR E))
	(PRIN BLANK)
	(COND ((AND (NOT (ATOM (CADDR E))) (EQ (CAADDR E) (QUOTE MINUS)))
		(GO X))
	      ((AND (NUMBERP (CADDR E)) (MINUSP (CADDR E))) (GO X)))
	(PRIN PLUSS)
	(PRIN BLANK)
   X	(PRE2IN (CADDR E]

(DE XMINUS (E)
  (PROG ()
	(PRIN DASH)
	(PRIN BLANK)
	(PRE2IN (CADR E]

(DE XTIMES (E)
  (PROG (X)
	(SETQ X (QUOTE (PLUS MINUS)))
	(COND ((ATOM (CADR E)) (PRIN (CADR E)))
	      ((MEMBER (CAADR E) X) (WRAP (CADR E)))
	      (T (PRE2IN (CADR E))))
	(COND ((ATOM (CADDR E)) (PRIN (CADDR E)))
	      ((MEMBER (CAADDR E) X) (WRAP (CADDR E)))
	      (T (PRE2IN (CADDR E]

(DE XQUOTIENT (E)
  (PROG (X)
	(SETQ X (QUOTE (PLUS MINUS)))
	(COND ((ATOM (CADR E)) (PRIN (CADR E)))
	      ((MEMBER (CAADR E) X) (WRAP (CADR E)))
	      (T (PRE2IN (CADR E))))
	(PRIN SLASH)
	(COND ((ATOM (CADDR E)) (PRIN (CADDR E)))
	      ((MEMBER (CAADDR E) X) (WRAP (CADDR E)))
	      (T (PRE2IN (CADDR E]

(DE XEXPT (E)
  (PROG ()
	(COND ((ATOM (CADR E)) (PRIN (CADR E)))
	      (T (WRAP (CADR E))))
	(PRIN UPARROW)
	(PRIN (CADDR E]

(DE WRAP (TERM)
  (PROG ()
	(PRIN LPAR)
	(PRE2IN TERM)
	(PRIN RPAR]

(DE DIFF ()
  (PROG (X Y)
   A	(TERPRI)
	(MAPC (FUNCTION (LAMBDA(J) (PROG2 (PRIN J) (PRIN BLANK))))
	      (QUOTE (THE DERIVATIVE OF/-)))
	(TERPRI)
	(TEREAD)
	(SETQ X (READER))
	(COND ((EQUAL X (QUOTE END)) (RETURN (QUOTE FINIS)))
	      ((NULL (SETQ X (IN2PRE X))) (GO A)))
   B	(PRINC "WITH RESPECT TO-")
	(TERPRI)
	(TEREAD)
	(COND ((NOT (ATOM (SETQ Y (CAR (READER))))) (GO B)))
	(PRINC "IS-")
	(TERPRI)
	(PRE2IN (SIMPLIFY (DERIV X Y)))
	(TERPRI)
	(GO A]

(DE READER ()
  (PROG (X Y)
   A	(SETQ X (READCH))
	(COND ((EQ X BLANK) (GO A))
	      ((EQ X PERIOD) (RETURN (QUOTE END)))
	      ((EQ X CR) (RETURN (REVERSE Y)))
	      ((EQ X COMMA) (RETURN (REVERSE Y))))
	(SETQ Y (CONS X Y))
	(GO A]

.