1 (define (test-case actual expected)
2   (newline)
3   (display "Actual:   ")
4   (display actual)
5   (newline)
6   (display "Expected: ")
7   (display expected)
8   (newline))
9 
10 (define (variable? x) (symbol? x))
11 (define (same-variable? v1 v2)
12   (and (variable? v1) (variable? v2) (eq? v1 v2)))
13 (define (make-sum a1 a2) (list '+ a1 a2))
14 (define (make-product m1 m2) (list '* m1 m2))
15 (define (sum? x)
16   (and (pair? x) (eq? (car x) '+)))
17 (define (addend s) (cadr s))
18 (define (augend s) (caddr s))
19 (define (product? x)
20   (and (pair? x) (eq? (car x) '*)))
21 (define (multiplier p) (cadr p))
22 (define (multiplicand p) (caddr p))
23 
24 (define (make-sum a1 a2)
25   (cond ((=number? a1 0) a2)
26 	((=number? a2 0) a1)
27 	((and (number? a1) (number? a2)) (+ a1 a2))
28 	(else (list '+ a1 a2))))
29 (define (=number? exp num)
30   (and (number? exp) (= exp num)))
31 
32 (define (make-product m1 m2)
33   (cond ((or (=number? m1 0) (=number? m2 0)) 0)
34 	((=number? m1 1) m2)
35 	((=number? m2 1) m1)
36 	((and (number? m1) (number? m2)) (* m1 m2))
37 	(else (list '* m1 m2))))
38 
39 (define (deriv exp var)
40   (cond ((number? exp) 0)
41 	((variable? exp) (if (same-variable? exp var) 1 0))
42 	((sum? exp) (make-sum (deriv (addend exp) var)
43 			      (deriv (augend exp) var)))
44 	((product? exp) (make-sum
45 			 (make-product (multiplier exp)
46 				       (deriv (multiplicand exp) var))
47 			 (make-product (deriv (multiplier exp) var)
48 				       (multiplicand exp))))
49 	((and (exponentiation? exp) 
50 	      (number? (exponent exp)))
51 	 (make-product
52 	  (make-product (exponent exp)
53 			(make-exponentiation (base exp)
54 					     (make-sum (exponent exp) -1)))
55 ;; or (- (exponent exp) 1)
56 	  (deriv (base exp) var))) 
57 	(error "unknown expression type -- DERIV" exp)))
58 
59 (define (exponentiation? exp)
60   (and (pair? exp) (eq? (car exp) '**)))
61 (define (base exp)
62   (cadr exp))
63 (define (exponent exp)
64   (caddr exp))
65 
66 (define (make-exponentiation base exponent)
67   (cond ((and (=number? base 0) (=number? exponent 0)) (error "0^0 undefined"))
68 	((=number? exponent 0) 1)
69 	((=number? base 0) 0)
70 	((=number? base 1) 1)
71 	((and (number? base) (number? exponent)) (expt base exponent))
72 	((=number? exponent 1) base)
73 	(else (list '** base exponent))))
74 ;; warning, does not warn if x = 0 for 0^x
75 
76 ;; (test-case (make-exponentiation 0 0) "0^0 undefined")
77 ;; (test-case (make-exponentiation 0 1) 0)
78 ;; (test-case (make-exponentiation 1 0) 1)
79 ;; (test-case (make-exponentiation 5 5) 3125)
80 ;; (test-case (make-exponentiation 'x 0) 1) ;; bug -- what if x = 0?
81 ;; (test-case (make-exponentiation 'x 1) 'x)
82 ;; (test-case (make-exponentiation 1 'x) 1)
83 ;; (test-case (make-exponentiation 'x 5) '(** x 5))
84 ;; (test-case (make-exponentiation 0 'x) 0) ;; bug -- what if x = 0?
85 ;; (test-case (make-exponentiation 5 'x) '(** 5 x))
86 ;; (test-case (make-exponentiation 'x 'x) '(** x x))
87 
88 (test-case (deriv (make-sum (make-sum (make-exponentiation 'x 3)
89 				      (make-product 3 (make-exponentiation 'x 2)))
90 			    (make-product 2 'x)) 
91 		  'x)
92 	   '(+ (+ (* 3 (** x 2))
93 		  (* 6 x))
94 	       2))
95 
96 ;;  Exercise 2.57.  Extend the differentiation program to handle sums and products of arbitrary numbers of (two or more) terms. Then the last example above could be expressed as
97 
98 ;; (deriv '(* x y (+ x 3)) 'x)
99 
100 ;; Try to do this by changing only the representation for sums and products, without changing the deriv procedure at all. For example, the addend of a sum would be the first term, and the augend would be the sum of the rest of the terms. 
101 
102 (define (make-sum . exps)
103   (let* ((nums (filter number? exps))
104 	 (non-nums (filter (lambda (exp) (not (number? exp))) exps))
105 	 (num (fold-right + 0 nums)))
106     (cond ((= num 0) (cond ((null? non-nums) 0)
107 			   ((null? (cdr non-nums)) (car non-nums))
108 			   (else (append (list '+) non-nums))))
109 	  ((null? non-nums) num)
110 	  (else (append (list '+)
111 			non-nums
112 			(list num))))))
113 (define (make-sum . exps)
114   (let* ((nums (filter number? exps))
115 	 (non-nums (filter (lambda (exp) (not (number? exp))) exps))
116 	 (num (fold-right + 0 nums)))
117     (cond ((= num 0) (cond ((null? non-nums) 0)
118 			   ((null? (cdr non-nums)) (car non-nums))
119 			   (else (append (list '+) non-nums))))
120 	  ((null? non-nums) num)
121 	  (else (append (list '+)
122 			non-nums
123 			(list num))))))
124 (define (make-product . exps)
125   (let* ((nums (filter number? exps))
126 	 (non-nums (filter (lambda (exp) (not (number? exp))) exps))
127 	 (num (fold-right * 1 nums)))
128     (cond ((null? exps) 1)
129 	  ((= num 0) 0)
130 	  ((null? non-nums) num)
131 	  ((null? (cdr non-nums)) (if (= num 1)
132 				      (car non-nums)
133 				      (append (list '* num) non-nums)))
134 	  (else (if (= num 1)
135 		    (cons '* non-nums)
136 		    (append (list '* num) non-nums))))))
137 	    
138 	  ;; ((= nums 1) (cond ((null? non-nums) 1)
139 	  ;; 		    ((null? (cdr non-nums)) (car non-nums))
140 	  ;; 		    (else (append (list '*) non-nums))))
141 	  ;; (else
142 
143 (test-case (make-sum) 0)
144 (test-case (make-sum 0) 0)
145 (test-case (make-sum 0 'x) 'x)
146 (test-case (make-sum 1 2 3 4 5) 15)
147 (test-case (make-sum 1 'x) '(+ x 1))
148 (test-case (make-sum 1 5 'x) '(+ x 6))
149 (test-case (make-sum 1 5 'x 'y) '(+ x y 6))
150 (test-case (make-sum -3 3 'x 'y) '(+ x y))
151 (test-case (make-sum -3 3 'x) 'x)
152 (test-case (make-sum 'a 'b 'c 'd 1 2 3 -6 -7 5) '(+ a b c d -2))
153 (test-case (make-sum 'a 'b 'c 'd 1 2 3 -6 -7 4 3) '(+ a b c d))
154 (test-case (make-sum (make-product 5 'x)
155 		     (make-product 3 'y)
156 		     2 5 -4) 
157 	   '(+ (* 5 x) (* 3 y) 3))
158 (test-case (make-sum (make-product 5 'x)
159 		     (make-product 2 0 'y)
160 		     (make-product (make-sum 5 -5) 'x)
161 		     (make-product (make-sum 2 4 -6) 'y)
162 		     (make-product (make-product 0 1) 'z)
163 		     (make-product 4 'z)
164 		     -3 -2 -1
165 		     (make-product 2 3))
166 	   '(+ (* 5 x) (* 4 z)))
167 
168 (test-case (make-product) 1)
169 (test-case (make-product 1) 1)
170 (test-case (make-product 5) 5)
171 (test-case (make-product 'x) 'x)
172 (test-case (make-product 5 'x) '(* 5 x))
173 (test-case (make-product 5 2) 10)
174 (test-case (make-product 0) 0)
175 (test-case (make-product 0 1 3 2) 0)
176 (test-case (make-product 0 'x) 0)
177 (test-case (make-product 5 2 'x) '(* 10 x))
178 (test-case (make-product 5 'x 'y 'z 0) 0)
179 (test-case (make-product 5 'x 'y 'z) '(* 5 x y z))
180 (test-case (make-product 5 'x 2 -3 'y) '(* -30 x y))
181 (test-case (make-product 5 1/5 'x) 'x)
182 (test-case (make-product 5 1/5 'x 'y) '(* x y))
183 (test-case (make-product (make-sum 5 6 4 -2)
184 			 'x 'y 
185 			 (make-sum 1 -3 3))
186 	   '(* 13 x y))
187 (test-case (make-product (make-sum (make-sum 2 4)
188 				   (make-product 3 -2))
189 			 (make-product 4 'y))
190 	   0)
191 	   
192 
193 (define (addend s) (cadr s))
194 (define (augend s) (apply make-sum (cddr s)))
195 ;; alternatively,
196 ;;  (if (null? (cdddr s))
197 ;;      (caddr s)
198 ;;      (apply make-sum (cddr s))))
199 
200 (define (multiplier p) (cadr p))
201 (define (multiplicand p) (apply make-product (cddr p)))
202 
203 (test-case (augend (make-sum 1 'x)) 1)
204 (test-case (augend (make-sum 1 5 'x)) 6)
205 (test-case (augend (make-sum 1 5 'x 'y)) '(+ y 6))
206 (test-case (augend (make-sum -3 3 'x 'y)) 'y)
207 (test-case (augend (make-sum 'a 'b 'c 'd 1 2 3 -6 -7 5)) '(+ b c d -2))
208 (test-case (augend (make-sum 'a 'b 'c 'd 1 2 3 -6 -7 4 3)) '(+ b c d))
209 (test-case (augend (make-sum (make-product 5 'x)
210 			     (make-product 3 'y)
211 			     2 5 -4)) 
212 	   '(+ (* 3 y) 3))
213 (test-case (augend (make-sum (make-product 5 'x)
214 			     (make-product 2 0 'y)
215 			     (make-product (make-sum 5 -5) 'x)
216 			     (make-product (make-sum 2 4 -6) 'y)
217 			     (make-product (make-product 0 1) 'z)
218 			     (make-product 4 'z)
219 			     -3 -2 -1
220 			     (make-product 2 3)))
221 	   '(* 4 z))
222 
223 (test-case (multiplicand (make-product 5 'x)) 'x)
224 (test-case (multiplicand (make-product 5 'x 'y 'z)) '(* x y z))
225 (test-case (multiplicand (make-product 5 'x 2 -3 'y)) '(* x y))
226 (test-case (multiplicand (make-product (make-sum 5 6 4 -2)
227 				       'x 'y 
228 				       (make-sum 1 -3 3)))
229 	   '(* x y))
230 (test-case (deriv '(* x y (+ x 3)) 'x) '(+ (* x y) (* y (+ x 3))))
231 ;; (make-sum (make-product 'x (deriv '(* y (+ x 3)) 'x))
232 ;; 	  '(* y (+ x 3))))
233 ;; (make-sum (make-product 'x 'y)
234 ;; 	  '(* y (+ x 3)))
235 ;; (make-sum '(* x y)
236 ;; 	  '(* y (+ x 3)))
237 ;; '(+ (* x y) (* y (+ x 3)))
238