;;; -*- Mode:LISP; Package:LISP-INTERNALS; Readtable:CL; Base:10 -*-


;;;;;; DERIV ;;;;;;;;

(defun deriv-aux (a)
  (list '/ (deriv a) a))

(defun deriv (a)
  (cond 
    ((atom a)
     (cond ((eq a 'x) 1) (t 0)))
    ((eq (car a) '+)
     (cons '+ (mapcar #'deriv (cdr a))))
    ((eq (car a) '-) 
     (cons '- (mapcar #'deriv 
		      (cdr a))))
    ((eq (car a) '*)
     (list '* 
	   a 
	   (cons '+ (mapcar #'deriv-aux (cdr a)))))
    ((eq (car a) '/)
     (list '- 
	   (list '/ 
		 (deriv (cadr a)) 
		 (caddr a))
	   (list '/ 
		 (cadr a) 
		 (list '*
		       (caddr a)
		       (caddr a)
		       (deriv (caddr a))))))
     (t 'error)))

(defun run-deriv ()
 (declare (fixnum i))
 (do ((i 0 (1+ i)))
     ((= i 1000.))
   (deriv '(+ (* 3 x x) (* a x x) (* b x) 5))
   (deriv '(+ (* 3 x x) (* a x x) (* b x) 5))
   (deriv '(+ (* 3 x x) (* a x x) (* b x) 5))
   (deriv '(+ (* 3 x x) (* a x x) (* b x) 5))
   (deriv '(+ (* 3 x x) (* a x x) (* b x) 5))))

;;;;;; DDERIV ;;;;;;;;


(DEFUN DER1 (A) (LIST '/ (DDERIV A) A))

(DEFUN +DDERIV (A)
       (CONS '+ (MAPCAR #'DDERIV A)))

(DEFUN -DDERIV (A)
       (CONS '- (MAPCAR #'DDERIV 
				 A)))

(DEFUN *DDERIV (A)
	(LIST '* (CONS '* A)
		(CONS '+ (MAPCAR #'DER1 A))))

(DEFUN /DDERIV (A)
       (LIST '-
	     (LIST '/
		   (DDERIV (CAR A)) 
		   (CADR A))
	     (LIST '/
		   (CAR A) 
		   (LIST '*
			 (CADR A)
			 (CADR A)
			 (DDERIV (CADR A))))))

 (DEFUN DDERIV (A)
	(COND 
	 ((ATOM A)
	  (COND ((EQ A 'X) 1) (T 0)))
	 (T (LET ((DDERIV (GET (CAR A) 'DDERIV)))
		 (COND (DDERIV (FUNCALL DDERIV (CDR A)))
		       (T 'ERROR))))))

(DEFUN SETUP-DDERIV ()
  (MAPC
    #'(LAMBDA (OP FUN)
	(SETF (GET OP 'DDERIV)
	      (SYMBOL-FUNCTION FUN)))
    '(+       -       *       /)
    '(+DDERIV -DDERIV *DDERIV /DDERIV)))
    

(DEFUN RUN-DDERIV ()
 (DO ((I 0 (1+ I)))
     ((= I 1000.))
     (DDERIV '(+ (* 3 X X) (* A X X) (* B X) 5))
     (DDERIV '(+ (* 3 X X) (* A X X) (* B X) 5))
     (DDERIV '(+ (* 3 X X) (* A X X) (* B X) 5))
     (DDERIV '(+ (* 3 X X) (* A X X) (* B X) 5))
     (DDERIV '(+ (* 3 X X) (* A X X) (* B X) 5))))

;;;;;;;;;; BENCHMARK the machine ;;;;;;;;;;;;;;

(defmacro run-test (info func)
  `(progn
     (hw:write-microsecond-clock (hw:unboxed-constant 0))
     (li:error
       ,info
       ,func
       (hw:read-microsecond-clock))))
  
(defun test-deriv ()
  (boot-stack-groups)
  (run-test "DERIV" (run-deriv))
  (loop))

(defun test-dderiv ()
  (boot-stack-groups)
  (setup-dderiv)
  (run-test "DDERIV" (run-dderiv))
  (loop))