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 (add-signs exps sign)
29   (cond ((null? exps) '())
30 	((null? (cdr exps)) exps)
31 	(else (cons (car exps)
32 		    (cons sign
33 			  (add-signs (cdr exps) sign))))))
34 (define (add-plus-signs exps)
35   (cond ((null? exps) '())
36 	((null? (cdr exps)) exps)
37 	((sum? (car exps)) (append (list (addend (car exps))
38 					 (augend (car exps)))
39 				   (add-plus-signs (cdr exps))))
40 	(else (append (list (car exps) '+)
41 		      (add-plus-signs (cdr exps))))))
42 (define (add-mult-signs exps)
43   (cond ((null? exps) '())
44 	((null? (cdr exps)) exps)
45 	(else (cons (car exps)
46 		    (cons '*
47 			  (add-mult-signs (cdr exps)))))))
48 
49 (define (make-sum . exps)
50   (let* ((nums (filter number? exps))
51 	 (non-nums (filter (lambda (exp) (not (number? exp))) exps))
52 	 (sum-of-nums (fold-right + 0 nums)))
53     (cond ((null? non-nums) sum-of-nums)
54 	  ((and (= sum-of-nums 0)
55 		(null? (cdr non-nums))) (car non-nums))
56 	  ((= sum-of-nums 0) (add-plus-signs non-nums))
57 	  (else (add-plus-signs (append non-nums (list sum-of-nums)))))))
58 (define (make-product . exps)
59   (let* ((nums (filter number? exps))
60 	 (non-nums (filter (lambda (exp) (not (number? exp))) exps))
61 	 (product-of-nums (fold-right * 1 nums)))
62     (cond ((null? non-nums) product-of-nums)
63 	  ((= product-of-nums 0) 0)
64 	  ((and (= product-of-nums 1)
65 		(null? (cdr non-nums))) (car non-nums))
66 	  ((= product-of-nums 1) (add-mult-signs non-nums))
67 	  (else (add-mult-signs (cons product-of-nums non-nums))))))
68 (define (addend s) 
69   (if (eq? '+ (cadr s))
70       (list (car x))
71       (cons (car x)
72 	    (cons (cadr x)
73 		  (addend (cddr x))))))
74 
75 (define (augend s)
76   (cond ((and (eq? '+ (cadr s))
77 	      (null? (cdddr s)))
78 	 (caddr s))
79 	((eq? '+ (cadr s)) (cddr s))
80 	((eq? '* (cadr s)) (augend (cddr s)))))
81 
82 (define (sum? x)
83   (and (pair? x) 
84        (not (null? (cdr x)))
85        (or (eq? (cadr x) '+)
86 	   (sum? (cddr x)))))
87 
88 (define (multiplier p) (car p))
89 (define (multiplicand p) (caddr p))
90 
91 (define (product? x)
92   (and (pair? x) (eq? (cadr x) '*)))
93 
94 
95 ;; addend
96 (test-case (addend '(a + b + c)) 'a)
97 (test-case (addend '(3 * x + 4 * y)) '(3 * x))
98 (test-case (addend '(4 + x * y * (1 + z) + (2 * 2))) '(y * x * (z + 1)))
99 (test-case (addend '(2 * x * y + 4)) '(2 * x * y))
100 
101 ;; augend
102 (test-case (augend '(x + 6)) 6)
103 (test-case (augend '(x + y + 6)) '(y + 6))
104 (test-case (augend '(a + b + c + d + 5)) '(b + c + d + 5))
105 (test-case (augend '(5 * x + 3 * y + 3))
106 	   '(3 * y + 3))
107 
108 ;; sum?
109 (test-case (sum? '(5 + x)) #t)
110 (test-case (sum? '(5 * x + 3)) #t)
111 (test-case (sum? '(8 * x)) #f)
112 (test-case (sum? 5) #f)
113 (test-case (sum? '(5 * x + 8 * y)) #t)
114 (test-case (sum? '(((5 * x) + 3) + 2)) #t)
115 (test-case (make-sum 0 'x) 'x)
116 (test-case (make-sum 1 2) 3)
117 (test-case (make-sum 1 'x) '(x + 1))
118 (test-case (make-sum 'x 'y) '(x + y))
119 (test-case (make-sum (make-sum -3 'y)
120 		     (make-sum 3 'x)) '(y + -3 + x + 3)) ;; not the most simplified
121 (test-case (make-sum (make-sum 'a (make-sum 'b (make-sum 'c 'd)))) '(a + b + c + d))
122 (test-case (make-sum -3 'y 3 'x) '(y + x))
123 (test-case (make-sum (make-product 2 'x 'y) 4) '(2 * x * y + 4))
124 (test-case (make-sum 4 (make-product 2 'x 'y)) '(4 + 2 * x * y))
125 (test-case (make-sum (make-product 3 'z) (make-product 2 'x 'y)) '(3 * z + 2 * x * y))
126 (test-case (make-sum (make-product 'a 'b) 
127 		     (make-product 'c (make-sum 'd 1) 'e) 
128 		     (make-product (make-sum 'f 2) (make-sum 'g 3) 'h))
129 	   '(a * b + c * (d + 1) * e + (f + 2) * (g + 3) * h))
130 (test-case (make-product 5 'x) '(5 * x))
131 (test-case (make-product 5 2) 10)
132 (test-case (make-product 0 'x) 0)
133 (test-case (make-product 5 2 'x) '(10 * x))
134 (test-case (make-product 5 1/5 'x 'y) '(x * y))
135 (test-case (make-product 5 (make-product 'x 'y) 'z) '(5 * x * y * z))
136 (test-case (make-product (make-sum 5 'x)
137 			 (make-product 'x 'y)
138 			 (make-sum 'z 2)) 
139 	   '((5 + x) * x * y * (z + 2)))
140 ;; if we are dealing with sums, then we must add parentheses; otherwise, omit parentheses
141 (test-case (make-sum (make-sum -5 6 'x) 
142 		     'y
143 		     (make-sum -3 3))
144 	   '(x + 1 + y)) ;; notice that the constant 1 is not right-most
145 (test-case (make-product (make-sum 2 4 (make-product 3 -2)) 
146 			 (make-product 4 'y)) 0)
147 (test-case (make-sum (make-product 5 'x)
148 		     (make-product 3 'y)
149 		     (make-product 2 'y)
150 		     (make-product 2 3))
151 	   '(5 * x + 3 * y + 2 * y + 6))
152 (test-case (make-sum (make-product 5 'x 'y)
153 		     (make-product 4 'a 'b 'c))
154 	   '(5 * x * y + 4 * a * b * c))
155 
156 
157 (test-case (multiplier '(20 * x * ( (make-product (make-product 5 4 'x (make-sum 1 'y))
158 				     (make-sum 2 'z)))
159 	   '(20 * x * (y + 1)))
160 (test-case (multiplier (make-product (make-sum 5 6 4 -2)
161 				     'x 'y 
162 				     (make-sum 1 -3 3)))
163 	   13)
164 (test-case (multiplicand (make-product 5 'x)) 'x)
165 (test-case (multiplicand (make-product 5 'x 'y 'z)) '(x * y * z))
166 (test-case (multiplicand (make-product 5 'x 2 -3 'y)) '(x * y))
167 (test-case (multiplicand (make-product (make-sum 5 6 4 -2)
168 				       'x 'y 
169 				       (make-sum 1 -3 3)))
170 	   '(x * y))
171 
172 (test-case (deriv '(* x y (+ x 3)) 'x) '(+ (* x y) (* y (+ x 3))))