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