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 
14 (define (deriv exp var)
15   (cond ((number? exp) 0)
16 	((variable? exp) (if (same-variable? exp var) 1 0))
17 	((sum? exp) (make-sum (deriv (addend exp) var)
18 			      (deriv (augend exp) var)))
19 	((product? exp) (make-sum
20 			 (make-product (multiplier exp)
21 				       (deriv (multiplicand exp) var))
22 			 (make-product (deriv (multiplier exp) var)
23 				       (multiplicand exp))))
24 	(error "unknown expression type -- DERIV" exp)))
25 
26 ;; b. The problem becomes substantially harder if we allow standard algebraic notation, such as (x + 3 * (x + y + 2)), which drops unnecessary parentheses and assumes that multiplication is done before addition. Can you design appropriate predicates, selectors, and constructors for this notation such that our derivative program still works? 
27 
28 (define (sum? x)
29   (and (not (number? x))
30        (not (variable? x))
31        (not (null? (cdr x)))
32        (or (eq? (cadr x) '+)
33 	   (sum? (cddr x)))))
34 ;; sum?
35 ;; (newline)
36 ;; (display "sum??")
37 ;; (newline)
38 ;; (test-case (sum? '(5 + x)) #t)
39 ;; (test-case (sum? '(5 * x + 3)) #t)
40 ;; (test-case (sum? '(8 * x)) #f)
41 ;; (test-case (sum? 5) #f)
42 ;; (test-case (sum? '(5 * x + 8 * y)) #t)
43 ;; (test-case (sum? '(y * ((5 * x) + 3) + 2)) #t)
44 
45 ;; an expression is a product if it is not a sum and contains a * sign somewhere in the top 'level' of a list
46 (define (product? x)
47   (and (not (number? x))
48        (not (variable? x))
49        (not (sum? x))
50        (not (null? (cdr x)))
51        (or (eq? (cadr x) '*)
52 	   (product? (cddr x)))))
53 ;; (newline)
54 ;; (display "product?")
55 ;; (newline)
56 ;; (test-case (product? '(2 * x * y + 4)) #f)
57 ;; (test-case (product? '(x * y * z)) #t)
58 ;; (test-case (product? '((x + 1) * y)) #t)
59 ;; (test-case (product? '((x + (3 * z) * y) + (5 * z * (3 * y + 5)))) #f)
60 ;; (test-case (product? '((x + 3 * z * y) * y + 5)) #f)
61 
62 ;; If the first operation is +, we return the first element in the list
63 ;; Otherwise, we join the first two elements to the addend of the rest
64 ;; of the list.
65 (define (addend s) 
66   (if (eq? '+ (cadr s)) 
67       (car s)
68 ;; we do not test if (cadddr s) is a number or variable because it might
69 ;; be a single nested list
70       (if (eq? (cadddr s) '+) 
71 	  (list (car s) (cadr s) (addend (cddr s)))
72 	  (cons (car s)
73 		(cons (cadr s)
74 		      (addend (cddr s)))))))
75 ;; (newline)
76 ;; (display "addend")
77 ;; (newline)
78 ;; (test-case (addend '(a + b + c)) 'a)
79 ;; (test-case (addend '(3 * x + 4 * y)) '(3 * x))
80 ;; (test-case (addend '(x * y * (z + 1) + (2 * 2))) '(x * y * (z + 1)))
81 ;; (test-case (addend '(2 * x * y + 4)) '(2 * x * y))
82 ;; (test-case (addend '((y + 1) * (y + 2) + 2 * ((3 * y) * 2) + 1)) 
83 ;; 	   '((y + 1) * (y + 2)))
84 ;; (test-case (addend '((y + 1) * (y + 2) * (y + 3) + 2 * ((3 * y) * 2) + 1))
85 ;; 	   '((y + 1) * (y + 2) * (y + 3)))
86 
87 ;; If the first operation is +, we return the either the third element of the list if it is a single expression, or the rest of the list if there are more elements.
88 (define (augend s)
89   (if (eq? '+ (cadr s))
90       (if (null? (cdddr s))
91 	  (caddr s)
92 	  (cddr s))
93       (augend (cddr s))))
94 ;; (newline)
95 ;; (display "augend")
96 ;; (newline)
97 ;; (test-case (augend '(x + 6)) '6)
98 ;; (test-case (augend '(x + y + 6)) '(y + 6))
99 ;; (test-case (augend '(x + y * x)) '(y * x))
100 ;; (test-case (augend '(a + b + c + d + 5)) '(b + c + d + 5))
101 ;; (test-case (augend '(5 * x + 3 * y + 3))
102 ;; 	   '(3 * y + 3))
103 ;; (test-case (augend '(5 * x + (y + 1) * (y + 2) + 2 * ((3 * y) * 2) + 1)) 
104 ;; 	   '((y + 1) * (y + 2) + 2 * ((3 * y) * 2) + 1))
105 
106 (define (multiplier p) 
107   (car p))
108 ;; (newline)
109 ;; (display "multiplier")
110 ;; (newline)
111 ;; (test-case (multiplier '(5 * x)) 5)
112 ;; (test-case (multiplier '(x * (x + 2))) 'x)
113 ;; (test-case (multiplier '((x + 1) * (x + 2) * (x + 3))) '(x + 1))
114 ;; (test-case (multiplier '((5 * x + 2) * 3)) '(5 * x + 2))
115 ;; (test-case (multiplier '((((x + 1) * (x + 2)) + 5) * (x + 3))) '(((x + 1) * (x + 2)) + 5))
116 ;; (test-case (multiplier '((y * (x + 5 * (y + 2)) + 4) * x * z)) '(y * (x + 5 * (y + 2)) + 4))
117 ;; (test-case (multiplier '((x + y + z) * (x + y))) '(x + y + z))
118 
119 (define (multiplicand p) 
120   (if (null? (cdddr p))
121       (caddr p)
122       (cddr p)))
123 ;; (newline)
124 ;; (display "multiplicand")
125 ;; (newline)
126 ;; (test-case (multiplicand '(5 * x)) 'x)
127 ;; (test-case (multiplicand '(x * (x + 2))) '(x + 2))
128 ;; (test-case (multiplicand '((x + 1) * (x + 2) * (x + 3))) '((x + 2) * (x + 3)))
129 ;; (test-case (multiplicand '((5 * x + 2) * y)) 'y)
130 ;; (test-case (multiplicand '((((x + 1) * (x + 2)) + 5) * (x + 3 * (x + 4 * (x + 4))) * (x + 3) * (x + 1))) '((x + 3 * (x + 4 * (x + 4))) * (x + 3) * (x + 1)))
131 ;; (test-case (multiplicand '((y * (x + 5 * (y + 2)) + 4) * x * z)) '(x * z))
132 ;; (test-case (multiplicand '((x + y + z) * (x + y))) '(x + y))
133 
134 ;; given a list of items to sum, check to see if any of the items are sums. 
135 ;; If they are, return a new list with the addend and augends as separate expressions
136 (define (break-sums exps)
137   (if (null? exps)
138       '()
139       (let ((x (car exps)))
140 	(if (sum? x)
141 	    (cons (addend x)
142 		  (break-sums (cons (augend x) (cdr exps))))
143 	    (cons x (break-sums (cdr exps)))))))
144 
145 ;; (newline)
146 ;; (display "break-sums")
147 ;; (newline)
148 ;; (test-case (break-sums '((x + 5) x 3)) '(x 5 x 3))
149 ;; (test-case (break-sums '((x + (x + 5)) x 3)) '(x x 5 x 3))
150 ;; (test-case (break-sums '((x + 5 + 2 * x * y) (x * y + 5) (a + 2 + 3 * x) (x + a * b * c + 7))) '(x 5 (2 * x * y) (x * y) 5 a 2 (3 * x) x (a * b * c) 7))
151 
152 ;; interpolate '+ signs between expressions
153 (define (add-plus-signs exps)
154   (if (null? exps) 
155       '() ;; this should never execute
156       (let ((x (car exps))
157 	    (remnant (cdr exps)))
158 	(cond ((null? remnant) (if (or (number? x)
159 				       (variable? x))
160 				   (list x)
161 				   x)) ;; when x is a one-element list like '((x * y))
162 	      ((or (number? x)
163 		   (variable? x)) (cons x (cons '+ (add-plus-signs remnant))))
164 	      ((sum? x) (error "unexpected sum"))
165 ;; if x is a product or some other complicated expression
166 	      ((product? x) (cons (multiplier x)
167 				  (cons '*
168 					(add-plus-signs (cons (multiplicand x) remnant)))))
169 					;; (cons (multiplicand x)
170 					;;       (cons '+ (add-plus-signs remnant))))))
171 	      (else (error "expression type not yet implemented"))))))
172 ;; (newline)
173 ;; (display "add-plus-signs")
174 ;; (newline)
175 ;; (test-case (add-plus-signs '()) '())
176 ;; (test-case (add-plus-signs '(1)) '(1))
177 ;; (test-case (add-plus-signs '(x y z 4)) '(x + y + z + 4))
178 ;; (test-case (add-plus-signs '((x * y))) '(x * y))
179 ;; (test-case (add-plus-signs '((x * y) 5)) '(x * y + 5))
180 ;; (test-case (add-plus-signs '(((x * y) * (x + 1)) (5 * (x + 1)))) '((x * y) * (x + 1) + 5 * (x + 1)))
181 ;; (test-case (add-plus-signs '(((x * y + 2) * (y + 5)) a b (((a * b + 2) * c * (d + 1)) * (e + 4))))
182 ;; 	   '((x * y + 2) * (y + 5) + a + b + ((a * b + 2) * c * (d + 1)) * (e + 4)))
183 
184 ;; If the term is:
185 ;;    a number or a variable: we deal with it is without adding or removing any parentheses
186 ;;    a product: we must remove the parentheses around the product but not tamper with parentheses within the multiplier or multiplicand. We must deal with the product as a single term.
187 ;;    a sum: we must remove the parentheses around the sum (but we can optionally leave the addend's and potentially multiple augends' existing parentheses intact). We must then deal with the addend and potentially multiple augends individually.
188 
189 (define (make-sum . exps)
190   (let* ((terms (break-sums exps))
191 	 (nums (filter number? terms))
192 	 (non-nums (filter (lambda (exp) (not (number? exp))) terms))
193 	 (sum-of-nums (fold-right + 0 nums)))
194     (cond ((null? non-nums) sum-of-nums)
195 	  ((and (= sum-of-nums 0)
196 		(null? (cdr non-nums))) (car non-nums))
197 	  ((= sum-of-nums 0) (add-plus-signs non-nums))
198 	  (else (add-plus-signs (append non-nums (list sum-of-nums)))))))
199 (newline)
200 (display "make-sum")
201 (newline)
202 (test-case (make-sum 0 'x) 'x)
203 (test-case (make-sum 1 2) 3)
204 (test-case (make-sum 1 'x) '(x + 1))
205 (test-case (make-sum 'x 'y) '(x + y))
206 (test-case (make-sum (make-sum -3 'y)
207 		     (make-sum 3 'x)) '(y + x))
208 (make-sum '(y + -3) '(x + 3))
209 (make-sum 'y -3 'x 3)
210 (test-case (make-sum -3 'y 3 'x) '(y + x))
211 (test-case (make-sum (make-sum 'a (make-sum 'b (make-sum 'c 'd)))) '(a + b + c + d))
212 (test-case (make-sum (make-sum 'a 3) (make-sum 4 5 (make-sum 'x 'y)) (make-sum 'z (make-sum 1 'x)) 'x 'y) '(a + x + y + z + x + x + y + 13)) ;; we're not able to add variables/polynomials
213 (test-case (make-sum 4 '(2 * x * y)) '(2 * x * y + 4))
214 (test-case (make-sum '(3 * z) '(2 * x * y)) '(3 * z + 2 * x * y))
215 (test-case (make-sum '(a * b) '(c * (d + 1) * e) '((f + 2) * (g + 3) * h)) '(a * b + c * (d + 1) * e + (f + 2) * (g + 3) * h))
216 
217 ;; (test-case (make-product (make-sum 5 'x)
218 ;; 			 (make-product 'x 'y)
219 ;; 			 (make-sum 'z 2)) 
220 ;; 	   '((5 + x) * x * y * (z + 2)))
221 ;; ;; if we are dealing with sums, then we must add parentheses; otherwise, omit parentheses
222 ;; (test-case (make-sum (make-sum -5 6 'x) 
223 ;; 		     'y
224 ;; 		     (make-sum -3 3))
225 ;; 	   '(x + 1 + y)) ;; notice that the constant 1 is not right-most
226 ;; (test-case (make-product (make-sum 2 4 (make-product 3 -2)) 
227 ;; 			 (make-product 4 'y)) 0)
228 ;; (test-case (make-sum (make-product 5 'x)
229 ;; 		     (make-product 3 'y)
230 ;; 		     (make-product 2 'y)
231 ;; 		     (make-product 2 3))
232 ;; 	   '(5 * x + 3 * y + 2 * y + 6))
233 ;; (test-case (make-sum (make-product 5 'x 'y)
234 ;; 		     (make-product 4 'a 'b 'c))
235 ;; 	   '(5 * x * y + 4 * a * b * c))
236 
237 
238 (define (make-product . exps)
239   (let* ((nums (filter number? exps))
240 	 (non-nums (filter (lambda (exp) (not (number? exp))) exps))
241 	 (product-of-nums (fold-right * 1 nums)))
242     (cond ((null? non-nums) product-of-nums)
243 	  ((= product-of-nums 0) 0)
244 	  ((and (= product-of-nums 1)
245 		(null? (cdr non-nums))) (car non-nums))
246 	  ((= product-of-nums 1) (add-mult-signs non-nums))
247 	  (else (add-mult-signs (cons product-of-nums non-nums))))))
248 
249 (test-case (make-product 5 'x) '(5 * x))
250 (test-case (make-product 5 2) 10)
251 (test-case (make-product 0 'x) 0)
252 (test-case (make-product 5 2 'x) '(10 * x))
253 (test-case (make-product 5 1/5 'x 'y) '(x * y))
254 (test-case (make-product (make-product 'x 5) (make-product 'x 3 (make-product 1/15 'y 'z)) 'x) '(x * x * y * z * x))
255 (test-case (make-product '(x + 3) 'y) '((x + 3) * y))
256 (test-case
257 
258 If the exp is a:
259 variable or number, we just multiply without adding any extra parentheses
260 sum, then we must put parentheses around it and then multiply
261 product, then we just multiply without adding any extra parentheses
262 a complex expression, we just multiply without adding any extra parenthese around it
263 
264 ;; (define (add-mult-signs exps)
265 ;;   (cond ((null? exps) '())
266 ;; 	((null? (cdr exps)) exps)
267 ;; 	(else (cons (car exps)
268 ;; 		    (cons '*
269 ;; 			  (add-mult-signs (cdr exps)))))))
270 
271 
272 
273 
274 '((2 * y + 3 * x) (4 * z + 5 * a))
275 ;; if there is no sum in exp, remove the parentheses
276 
277 
278 
279 
280 
281 
282 
283 
284 
285 
286 
287 
288 
289 ;; make-sum
290 (test-case (make-sum (make-product 2 'x 'y) 4) '(2 * x * y + 4))
291 (test-case (make-sum 4 (make-product 2 'x 'y)) '(4 + 2 * x * y))
292 (test-case (make-sum (make-product 3 'z) (make-product 2 'x 'y)) '(3 * z + 2 * x * y))
293 (test-case (make-sum (make-product 'a 'b) 
294 		     (make-product 'c (make-sum 'd 1) 'e) 
295 		     (make-product (make-sum 'f 2) (make-sum 'g 3) 'h))
296 	   '(a * b + c * (d + 1) * e + (f + 2) * (g + 3) * h))
297 (test-case (make-product 5 'x) '(5 * x))
298 (test-case (make-product 5 2) 10)
299 (test-case (make-product 0 'x) 0)
300 (test-case (make-product 5 2 'x) '(10 * x))
301 (test-case (make-product 5 1/5 'x 'y) '(x * y))
302 (test-case (make-product 5 (make-product 'x 'y) 'z) '(5 * x * y * z))
303 (test-case (make-product (make-sum 5 'x)
304 			 (make-product 'x 'y)
305 			 (make-sum 'z 2)) 
306 	   '((5 + x) * x * y * (z + 2)))
307 ;; if we are dealing with sums, then we must add parentheses; otherwise, omit parentheses
308 (test-case (make-sum (make-sum -5 6 'x) 
309 		     'y
310 		     (make-sum -3 3))
311 	   '(x + 1 + y)) ;; notice that the constant 1 is not right-most
312 (test-case (make-product (make-sum 2 4 (make-product 3 -2)) 
313 			 (make-product 4 'y)) 0)
314 (test-case (make-sum (make-product 5 'x)
315 		     (make-product 3 'y)
316 		     (make-product 2 'y)
317 		     (make-product 2 3))
318 	   '(5 * x + 3 * y + 2 * y + 6))
319 (test-case (make-sum (make-product 5 'x 'y)
320 		     (make-product 4 'a 'b 'c))
321 	   '(5 * x * y + 4 * a * b * c))
322 
323 
324 (test-case (multiplier '(20 * x * ( (make-product (make-product 5 4 'x (make-sum 1 'y))
325 				     (make-sum 2 'z)))
326 	   '(20 * x * (y + 1)))
327 (test-case (multiplier (make-product (make-sum 5 6 4 -2)
328 				     'x 'y 
329 				     (make-sum 1 -3 3)))
330 	   13)
331 (test-case (multiplicand (make-product 5 'x)) 'x)
332 (test-case (multiplicand (make-product 5 'x 'y 'z)) '(x * y * z))
333 (test-case (multiplicand (make-product 5 'x 2 -3 'y)) '(x * y))
334 (test-case (multiplicand (make-product (make-sum 5 6 4 -2)
335 				       'x 'y 
336 				       (make-sum 1 -3 3)))
337 	   '(x * y))
338 
339 (test-case (deriv '(* x y (+ x 3)) 'x) '(+ (* x y) (* y (+ x 3))))
340 
341 
342 ;; (define (make-sum . exps)
343 ;;   (let* ((nums (filter number? exps))
344 ;; 	 (non-nums (filter (lambda (exp) (not (number? exp))) exps))
345 ;; 	 (sum-of-nums (fold-right + 0 nums)))
346 ;;     (cond ((null? non-nums) sum-of-nums)
347 ;; 	  ((and (= sum-of-nums 0)
348 ;; 		(null? (cdr non-nums))) (car non-nums))
349 ;; 	  ((= sum-of-nums 0) (add-plus-signs non-nums))
350 ;; 	  (else (add-plus-signs (append non-nums (list sum-of-nums)))))))
351 
352 
353 
354 
355 
356 
357 
358 (define (remove-parens exps)
359   (cond ((sum? exps) ...)
360 	...))
361 (newline)
362 (display "remove-parens")
363 (newline)
364 (test-case (remove-parens '(0 x)) '(0 x))
365 (test-case (remove-parents
366 (make-sum '(y + -3)
367 	  '(x + 3)
368 	  '(y + x + 3))
369 (test-case (make-sum -3 'y 3 'x) '(y + x))
370 (test-case (make-sum (make-sum 'a (make-sum 'b (make-sum 'c 'd)))) '(a + b + c + d))
371 (test-case (make-sum (make-sum 'a 3) (make-sum 4 5 (make-sum 'x 'y)) (make-sum z (make-sum 1 x)) 'x 'y) '(a + x + y + z + x + x + y + 13)) ;; we're not able to add variables/polynomials
372 
373 ;; (test-case (remove-parens '((
374 
375 ;; (define (make-sum . exps)
376 ;;   (let* ((terms (append exps))
377 ;; 	 (nums (filter number? terms))
378 ;; 	 (non-nums (filter (lambda (exp) (not (number? exp))) terms))
379 ;; 	 (sum-of-nums (fold-right + 0 nums)))
380 ;;     (cond ((null? non-nums) sum-of-nums)
381 ;; 	  ((and (= sum-of-nums 0)
382 ;; 		(null? (cdr non-nums))) (car non-nums))
383 ;; 	  ((= sum-of-nums 0) (add-signs non-nums '+))
384 ;; 	  (else (add-plus-signs (append non-nums (list sum-of-nums)))))))
385 
386 ;;given a list of expressions to add, remove unnecessary groupings
387 (define (extract-terms exps)
388   (if (null? exps) 
389       '()
390       (let ((first-exp (car exps)))
391 	(if (sum? first-exp)
392 	    (cons (addend first-exp)
393 		  (append (extract-terms (augend first-exp))
394 			  (extract-terms (cdr exps))))))))
395 	    (cons first-exp (extract-terms (cdr exprs)))
396 	
397 
398 
399 (test-case (extract-terms '((y + -3) (x + 3))) '(y 
400 
401 (test-case (make-sum (make-sum -3 'y)
402 		     (make-sum 3 'x)) '(y + x + 3))
403 (make-sum '(y + -3) '(x + 3))
404 (make-sum 'y -3 'x 3)
405 (test-case (make-sum -3 'y 3 'x) '(y + x))
406 (test-case (make-sum (make-sum 'a (make-sum 'b (make-sum 'c 'd)))) '(a + b + c + d))
407 (test-case (make-sum (make-sum 'a 3) (make-sum 4 5 (make-sum 'x 'y)) (make-sum z (make-sum 1 x)) 'x 'y) '(a + x + y + z + x + x + y + 13)) ;; we're not able to add variables/polynomials
408 
409 (test-case (make-sum (make-product 2 'x 'y) 4) '(2 * x * y + 4))
410 (test-case (make-sum 4 (make-product 2 'x 'y)) '(4 + 2 * x * y))
411 (test-case (make-sum (make-product 3 'z) (make-product 2 'x 'y)) '(3 * z + 2 * x * y))
412 (test-case (make-sum (make-product 'a 'b) 
413 		     (make-product 'c (make-sum 'd 1) 'e) 
414 		     (make-product (make-sum 'f 2) (make-sum 'g 3) 'h))
415 	   '(a * b + c * (d + 1) * e + (f + 2) * (g + 3) * h))
416 (test-case (make-product 5 'x) '(5 * x))
417 (test-case (make-product 5 2) 10)
418 (test-case (make-product 0 'x) 0)
419 (test-case (make-product 5 2 'x) '(10 * x))
420 (test-case (make-product 5 1/5 'x 'y) '(x * y))
421 (test-case (make-product 5 (make-product 'x 'y) 'z) '(5 * x * y * z))
422 (test-case (make-product (make-sum 5 'x)
423 			 (make-product 'x 'y)
424 			 (make-sum 'z 2)) 
425 	   '((5 + x) * x * y * (z + 2)))
426 ;; if we are dealing with sums, then we must add parentheses; otherwise, omit parentheses
427 (test-case (make-sum (make-sum -5 6 'x) 
428 		     'y
429 		     (make-sum -3 3))
430 	   '(x + 1 + y)) ;; notice that the constant 1 is not right-most
431 (test-case (make-product (make-sum 2 4 (make-product 3 -2)) 
432 			 (make-product 4 'y)) 0)
433 (test-case (make-sum (make-product 5 'x)
434 		     (make-product 3 'y)
435 		     (make-product 2 'y)
436 		     (make-product 2 3))
437 	   '(5 * x + 3 * y + 2 * y + 6))
438 (test-case (make-sum (make-product 5 'x 'y)
439 		     (make-product 4 'a 'b 'c))
440 	   '(5 * x * y + 4 * a * b * c))