home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 January / usenetsourcesnewsgroupsinfomagicjanuary1994.iso / sources / misc / volume1 / 8707 / 49 / dderiv.cl < prev    next >
Encoding:
Text File  |  1990-07-13  |  2.5 KB  |  79 lines
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ; File:         dderiv.cl
  3. ; Description:  DDERIV benchmark from the Gabriel tests
  4. ; Author:       Vaughan Pratt
  5. ; Created:      8-Apr-85
  6. ; Modified:     10-Apr-85 14:53:29 (Bob Shaw)
  7. ; Language:     Common Lisp
  8. ; Package:      User
  9. ; Status:       Public Domain
  10. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  11.  
  12. ;;; DDERIV -- Symbolic derivative benchmark written by Vaughn Pratt.  
  13.  
  14. ;;; This benchmark is a variant of the simple symbolic derivative program 
  15. ;;; (DERIV). The main change is that it is `table-driven.'  Instead of using a
  16. ;;; large COND that branches on the CAR of the expression, this program finds
  17. ;;; the code that will take the derivative on the property list of the atom in
  18. ;;; the CAR position. So, when the expression is (+ . <rest>), the code
  19. ;;; stored under the atom '+ with indicator DERIV will take <rest> and
  20. ;;; return the derivative for '+. The way that MacLisp does this is with the
  21. ;;; special form: (DEFUN (FOO BAR) ...). This is exactly like DEFUN with an
  22. ;;; atomic name in that it expects an argument list and the compiler compiles
  23. ;;; code, but the name of the function with that code is stored on the
  24. ;;; property list of FOO under the indicator BAR, in this case. You may have
  25. ;;; to do something like:
  26.  
  27. ;;; :property keyword is not Common Lisp.
  28.  
  29. (defun dderiv-aux (a) 
  30.   (list '/ (dderiv a) a))
  31.  
  32. (defun +dderiv (a)
  33.   (cons '+ (mapcar 'dderiv a)))
  34.  
  35. (setf (get '+ 'dderiv) '+dderiv)    ; install function on the property list
  36.  
  37. (defun -dderiv (a)
  38.   (cons '- (mapcar 'dderiv a)))
  39.  
  40. (setf (get '- 'dderiv) '-dderiv)    ; install function on the property list
  41.  
  42. (defun *dderiv (a)
  43.   (list '* (cons '* a)
  44.     (cons '+ (mapcar 'dderiv-aux a))))
  45.  
  46. (setf (get '* 'dderiv) '*dderiv)    ; install function on the property list
  47.  
  48. (defun /dderiv (a)
  49.   (list '- 
  50.     (list '/ 
  51.           (dderiv (car a)) 
  52.           (cadr a))
  53.     (list '/ 
  54.           (car a) 
  55.           (list '*
  56.             (cadr a)
  57.             (dderiv (cadr a))))))
  58.  
  59. (setf (get '/ 'dderiv) '/dderiv)    ; install function on the property list
  60.  
  61. (defun dderiv (a)
  62.   (cond 
  63.     ((atom a)
  64.      (cond ((eq a 'x) 1) (t 0)))
  65.     (t (let ((dderiv (get (car a) 'dderiv)))
  66.      (cond (dderiv (funcall dderiv (cdr a)))
  67.            (t 'error))))))
  68.  
  69. (defun run ()
  70.   (do ((i 0 (1+ i)))
  71.       ((= i 1000))
  72.     (declare (fixnum i))
  73.     (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))
  74.     (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))))
  75.  
  76. ;;; call:  (run)
  77.  
  78. (run-benchmark "Dderiv" '(run))
  79.