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