1 665c255d 2023-08-04 jrmu (define (deriv exp var)
  2 665c255d 2023-08-04 jrmu   (cond ((number? exp) 0)
  3 665c255d 2023-08-04 jrmu 	((variable? exp) (if (same-variable? exp var) 1 0))
  4 665c255d 2023-08-04 jrmu 	((sum? exp)
  5 665c255d 2023-08-04 jrmu 	 (make-sum (deriv (addend exp) var)
  6 665c255d 2023-08-04 jrmu 		   (deriv (augend exp) var)))
  7 665c255d 2023-08-04 jrmu 	((product? exp)
  8 665c255d 2023-08-04 jrmu 	 (make-sum
  9 665c255d 2023-08-04 jrmu 	  (make-product (multiplier exp)
 10 665c255d 2023-08-04 jrmu 			(deriv (multiplicand exp) var))
 11 665c255d 2023-08-04 jrmu 	  (make-product (deriv (multiplier exp) var)
 12 665c255d 2023-08-04 jrmu 			(multiplicand exp))))
 13 665c255d 2023-08-04 jrmu 	(else (error "unknown expression type -- DERIV" exp))))
 14 665c255d 2023-08-04 jrmu 
 15 665c255d 2023-08-04 jrmu (define (deriv exp var)
 16 665c255d 2023-08-04 jrmu   (cond ((number? exp) 0)
 17 665c255d 2023-08-04 jrmu 	((variable? exp) (if (same-variable? exp var) 1 0))
 18 665c255d 2023-08-04 jrmu 	(else ((get 'deriv (operator exp)) (operands exp) var))))
 19 665c255d 2023-08-04 jrmu (define (operator exp) (car exp))
 20 665c255d 2023-08-04 jrmu (define (operands exp) (cdr exp))
 21 665c255d 2023-08-04 jrmu 
 22 665c255d 2023-08-04 jrmu #lang racket
 23 665c255d 2023-08-04 jrmu (require rnrs/base-6)
 24 665c255d 2023-08-04 jrmu (require rnrs/mutable-pairs-6)
 25 665c255d 2023-08-04 jrmu 
 26 665c255d 2023-08-04 jrmu (define (assoc key records)
 27 665c255d 2023-08-04 jrmu   (cond ((null? records) #f)
 28 665c255d 2023-08-04 jrmu 	((equal? key (caar records)) (car records))
 29 665c255d 2023-08-04 jrmu 	(else (assoc key (cdr records)))))
 30 665c255d 2023-08-04 jrmu (define (make-table)
 31 665c255d 2023-08-04 jrmu   (let ((local-table (list '*table*)))
 32 665c255d 2023-08-04 jrmu     (define (lookup key-1 key-2)
 33 665c255d 2023-08-04 jrmu       (let ((subtable (assoc key-1 (cdr local-table))))
 34 665c255d 2023-08-04 jrmu 	(if subtable
 35 665c255d 2023-08-04 jrmu 	    (let ((record (assoc key-2 (cdr subtable))))
 36 665c255d 2023-08-04 jrmu 	      (if record
 37 665c255d 2023-08-04 jrmu 		  (cdr record)
 38 665c255d 2023-08-04 jrmu 		  #f))
 39 665c255d 2023-08-04 jrmu 	    #f)))
 40 665c255d 2023-08-04 jrmu     (define (insert! key-1 key-2 value)
 41 665c255d 2023-08-04 jrmu       (let ((subtable (assoc key-1 (cdr local-table))))
 42 665c255d 2023-08-04 jrmu 	(if subtable
 43 665c255d 2023-08-04 jrmu 	    (let ((record (assoc key-2 (cdr subtable))))
 44 665c255d 2023-08-04 jrmu 	      (if record
 45 665c255d 2023-08-04 jrmu 		  (set-cdr! record value)
 46 665c255d 2023-08-04 jrmu 		  (set-cdr! subtable
 47 665c255d 2023-08-04 jrmu 			    (cons (cons key-2 value)
 48 665c255d 2023-08-04 jrmu 				  (cdr subtable)))))
 49 665c255d 2023-08-04 jrmu 	    (set-cdr! local-table
 50 665c255d 2023-08-04 jrmu 		      (cons (list key-1
 51 665c255d 2023-08-04 jrmu 				  (cons key-2 value))
 52 665c255d 2023-08-04 jrmu 			    (cdr local-table)))))
 53 665c255d 2023-08-04 jrmu       'ok)
 54 665c255d 2023-08-04 jrmu     (define (dispatch m)
 55 665c255d 2023-08-04 jrmu       (cond ((eq? m 'lookup-proc) lookup)
 56 665c255d 2023-08-04 jrmu 	    ((eq? m 'insert-proc!) insert!)
 57 665c255d 2023-08-04 jrmu 	    (else (error "Unknown operation -- TABLE" m))))
 58 665c255d 2023-08-04 jrmu     dispatch))
 59 665c255d 2023-08-04 jrmu (define operation-table (make-table))
 60 665c255d 2023-08-04 jrmu (define get (operation-table 'lookup-proc))
 61 665c255d 2023-08-04 jrmu (define put (operation-table 'insert-proc!))
 62 665c255d 2023-08-04 jrmu 
 63 665c255d 2023-08-04 jrmu (define (deriv exp var)
 64 665c255d 2023-08-04 jrmu   ((get 'deriv (operator exp)) (operands exp) var))
 65 665c255d 2023-08-04 jrmu (define (operator exp)
 66 665c255d 2023-08-04 jrmu   (cond ((number? exp) 'number)
 67 665c255d 2023-08-04 jrmu 	((variable? exp) 'variable)
 68 665c255d 2023-08-04 jrmu 	(else (car exp))))
 69 665c255d 2023-08-04 jrmu (define (operands exp)
 70 665c255d 2023-08-04 jrmu   (if (pair? exp)
 71 665c255d 2023-08-04 jrmu       (cdr exp)
 72 665c255d 2023-08-04 jrmu       (list exp)))
 73 665c255d 2023-08-04 jrmu (define (install-number-routines)
 74 665c255d 2023-08-04 jrmu   (define (derivative ops var) 0)
 75 665c255d 2023-08-04 jrmu   (put 'deriv 'number derivative))
 76 665c255d 2023-08-04 jrmu (define (install-variable-routines)
 77 665c255d 2023-08-04 jrmu   (define (derivative ops var)
 78 665c255d 2023-08-04 jrmu     (if (same-variable? (car ops) var) 1 0))
 79 665c255d 2023-08-04 jrmu   (put 'deriv 'variable derivative))
 80 665c255d 2023-08-04 jrmu (install-number-routines)
 81 665c255d 2023-08-04 jrmu (install-variable-routines)
 82 665c255d 2023-08-04 jrmu 
 83 665c255d 2023-08-04 jrmu (define (install-sum-routines)
 84 665c255d 2023-08-04 jrmu   (define (derivative ops var)
 85 665c255d 2023-08-04 jrmu     (make-sum
 86 665c255d 2023-08-04 jrmu      (deriv (car ops) var)
 87 665c255d 2023-08-04 jrmu      (deriv (cadr ops) var)))
 88 665c255d 2023-08-04 jrmu   (put 'deriv '+ derivative))
 89 665c255d 2023-08-04 jrmu (define (install-product-routines)
 90 665c255d 2023-08-04 jrmu   (define (derivative ops var)
 91 665c255d 2023-08-04 jrmu     (make-sum
 92 665c255d 2023-08-04 jrmu      (make-product (car ops)
 93 665c255d 2023-08-04 jrmu 		   (deriv (cadr ops) var))
 94 665c255d 2023-08-04 jrmu      (make-product (deriv (car ops) var)
 95 665c255d 2023-08-04 jrmu 		   (cadr ops))))
 96 665c255d 2023-08-04 jrmu   (put 'deriv '* derivative))
 97 665c255d 2023-08-04 jrmu (install-sum-routines)
 98 665c255d 2023-08-04 jrmu (install-product-routines)
 99 665c255d 2023-08-04 jrmu 
100 665c255d 2023-08-04 jrmu ((exponentiation? exp)
101 665c255d 2023-08-04 jrmu  (make-product
102 665c255d 2023-08-04 jrmu   (make-product (exponent exp)
103 665c255d 2023-08-04 jrmu 		(make-exponentiation (base exp)
104 665c255d 2023-08-04 jrmu 				     (make-sum (exponent exp) -1)))
105 665c255d 2023-08-04 jrmu   (deriv (base exp) var)))
106 665c255d 2023-08-04 jrmu 
107 665c255d 2023-08-04 jrmu (define (install-exponent-routines)
108 665c255d 2023-08-04 jrmu   (define (derivative ops var)
109 665c255d 2023-08-04 jrmu     (make-product
110 665c255d 2023-08-04 jrmu      (make-product (cadr ops)
111 665c255d 2023-08-04 jrmu 		   (make-exponentiation (car ops)
112 665c255d 2023-08-04 jrmu 					(make-sum (cadr ops) -1)))
113 665c255d 2023-08-04 jrmu      (deriv (car ops) var)))
114 665c255d 2023-08-04 jrmu   (put 'deriv '** derivative))
115 665c255d 2023-08-04 jrmu 
116 665c255d 2023-08-04 jrmu ((get (operator exp) 'deriv) (operands exp) var)
117 665c255d 2023-08-04 jrmu 
118 665c255d 2023-08-04 jrmu (define (install-derivative-routines)
119 665c255d 2023-08-04 jrmu   (define (sum ops var)
120 665c255d 2023-08-04 jrmu     (make-sum
121 665c255d 2023-08-04 jrmu      (deriv (car ops) var)
122 665c255d 2023-08-04 jrmu      (deriv (cadr ops) var)))
123 665c255d 2023-08-04 jrmu   (define (product ops var)
124 665c255d 2023-08-04 jrmu     (make-sum
125 665c255d 2023-08-04 jrmu      (make-product (car ops)
126 665c255d 2023-08-04 jrmu 		   (deriv (cadr ops) var))
127 665c255d 2023-08-04 jrmu      (make-product (deriv (car ops) var)
128 665c255d 2023-08-04 jrmu 		   (cadr ops))))
129 665c255d 2023-08-04 jrmu   (define (exponent ops var)
130 665c255d 2023-08-04 jrmu     (make-product
131 665c255d 2023-08-04 jrmu      (make-product (cadr ops)
132 665c255d 2023-08-04 jrmu 		   (make-exponentiation (car ops)
133 665c255d 2023-08-04 jrmu 					(make-sum (cadr ops) -1)))
134 665c255d 2023-08-04 jrmu      (deriv (car ops) var)))
135 665c255d 2023-08-04 jrmu   (put '+ 'deriv sum)
136 665c255d 2023-08-04 jrmu   (put '* 'deriv product)
137 665c255d 2023-08-04 jrmu   (put '** 'deriv exponent))
138 665c255d 2023-08-04 jrmu