1 665c255d 2023-08-04 jrmu (define (test-case actual expected)
3 665c255d 2023-08-04 jrmu (display "Actual: ")
4 665c255d 2023-08-04 jrmu (display actual)
6 665c255d 2023-08-04 jrmu (display "Expected: ")
7 665c255d 2023-08-04 jrmu (display expected)
10 665c255d 2023-08-04 jrmu (define (variable? x) (symbol? x))
11 665c255d 2023-08-04 jrmu (define (same-variable? v1 v2)
12 665c255d 2023-08-04 jrmu (and (variable? v1) (variable? v2) (eq? v1 v2)))
13 665c255d 2023-08-04 jrmu (define (make-sum a1 a2) (list '+ a1 a2))
14 665c255d 2023-08-04 jrmu (define (make-product m1 m2) (list '* m1 m2))
15 665c255d 2023-08-04 jrmu (define (sum? x)
16 665c255d 2023-08-04 jrmu (and (pair? x) (eq? (car x) '+)))
17 665c255d 2023-08-04 jrmu (define (addend s) (cadr s))
18 665c255d 2023-08-04 jrmu (define (augend s) (caddr s))
19 665c255d 2023-08-04 jrmu (define (product? x)
20 665c255d 2023-08-04 jrmu (and (pair? x) (eq? (car x) '*)))
21 665c255d 2023-08-04 jrmu (define (multiplier p) (cadr p))
22 665c255d 2023-08-04 jrmu (define (multiplicand p) (caddr p))
24 665c255d 2023-08-04 jrmu (define (make-sum a1 a2)
25 665c255d 2023-08-04 jrmu (cond ((=number? a1 0) a2)
26 665c255d 2023-08-04 jrmu ((=number? a2 0) a1)
27 665c255d 2023-08-04 jrmu ((and (number? a1) (number? a2)) (+ a1 a2))
28 665c255d 2023-08-04 jrmu (else (list '+ a1 a2))))
29 665c255d 2023-08-04 jrmu (define (=number? exp num)
30 665c255d 2023-08-04 jrmu (and (number? exp) (= exp num)))
32 665c255d 2023-08-04 jrmu (define (make-product m1 m2)
33 665c255d 2023-08-04 jrmu (cond ((or (=number? m1 0) (=number? m2 0)) 0)
34 665c255d 2023-08-04 jrmu ((=number? m1 1) m2)
35 665c255d 2023-08-04 jrmu ((=number? m2 1) m1)
36 665c255d 2023-08-04 jrmu ((and (number? m1) (number? m2)) (* m1 m2))
37 665c255d 2023-08-04 jrmu (else (list '* m1 m2))))
39 665c255d 2023-08-04 jrmu (define (deriv exp var)
40 665c255d 2023-08-04 jrmu (cond ((number? exp) 0)
41 665c255d 2023-08-04 jrmu ((variable? exp) (if (same-variable? exp var) 1 0))
42 665c255d 2023-08-04 jrmu ((sum? exp) (make-sum (deriv (addend exp) var)
43 665c255d 2023-08-04 jrmu (deriv (augend exp) var)))
44 665c255d 2023-08-04 jrmu ((product? exp) (make-sum
45 665c255d 2023-08-04 jrmu (make-product (multiplier exp)
46 665c255d 2023-08-04 jrmu (deriv (multiplicand exp) var))
47 665c255d 2023-08-04 jrmu (make-product (deriv (multiplier exp) var)
48 665c255d 2023-08-04 jrmu (multiplicand exp))))
49 665c255d 2023-08-04 jrmu ((and (exponentiation? exp)
50 665c255d 2023-08-04 jrmu (number? (exponent exp)))
51 665c255d 2023-08-04 jrmu (make-product
52 665c255d 2023-08-04 jrmu (make-product (exponent exp)
53 665c255d 2023-08-04 jrmu (make-exponentiation (base exp)
54 665c255d 2023-08-04 jrmu (make-sum (exponent exp) -1)))
55 665c255d 2023-08-04 jrmu ;; or (- (exponent exp) 1)
56 665c255d 2023-08-04 jrmu (deriv (base exp) var)))
57 665c255d 2023-08-04 jrmu (error "unknown expression type -- DERIV" exp)))
59 665c255d 2023-08-04 jrmu (define (exponentiation? exp)
60 665c255d 2023-08-04 jrmu (and (pair? exp) (eq? (car exp) '**)))
61 665c255d 2023-08-04 jrmu (define (base exp)
63 665c255d 2023-08-04 jrmu (define (exponent exp)
64 665c255d 2023-08-04 jrmu (caddr exp))
66 665c255d 2023-08-04 jrmu (define (make-exponentiation base exponent)
67 665c255d 2023-08-04 jrmu (cond ((and (=number? base 0) (=number? exponent 0)) (error "0^0 undefined"))
68 665c255d 2023-08-04 jrmu ((=number? exponent 0) 1)
69 665c255d 2023-08-04 jrmu ((=number? base 0) 0)
70 665c255d 2023-08-04 jrmu ((=number? base 1) 1)
71 665c255d 2023-08-04 jrmu ((and (number? base) (number? exponent)) (expt base exponent))
72 665c255d 2023-08-04 jrmu ((=number? exponent 1) base)
73 665c255d 2023-08-04 jrmu (else (list '** base exponent))))
74 665c255d 2023-08-04 jrmu ;; warning, does not warn if x = 0 for 0^x
76 665c255d 2023-08-04 jrmu ;; (test-case (make-exponentiation 0 0) "0^0 undefined")
77 665c255d 2023-08-04 jrmu ;; (test-case (make-exponentiation 0 1) 0)
78 665c255d 2023-08-04 jrmu ;; (test-case (make-exponentiation 1 0) 1)
79 665c255d 2023-08-04 jrmu ;; (test-case (make-exponentiation 5 5) 3125)
80 665c255d 2023-08-04 jrmu ;; (test-case (make-exponentiation 'x 0) 1) ;; bug -- what if x = 0?
81 665c255d 2023-08-04 jrmu ;; (test-case (make-exponentiation 'x 1) 'x)
82 665c255d 2023-08-04 jrmu ;; (test-case (make-exponentiation 1 'x) 1)
83 665c255d 2023-08-04 jrmu ;; (test-case (make-exponentiation 'x 5) '(** x 5))
84 665c255d 2023-08-04 jrmu ;; (test-case (make-exponentiation 0 'x) 0) ;; bug -- what if x = 0?
85 665c255d 2023-08-04 jrmu ;; (test-case (make-exponentiation 5 'x) '(** 5 x))
86 665c255d 2023-08-04 jrmu ;; (test-case (make-exponentiation 'x 'x) '(** x x))
88 665c255d 2023-08-04 jrmu (test-case (deriv (make-sum (make-sum (make-exponentiation 'x 3)
89 665c255d 2023-08-04 jrmu (make-product 3 (make-exponentiation 'x 2)))
90 665c255d 2023-08-04 jrmu (make-product 2 'x))
92 665c255d 2023-08-04 jrmu '(+ (+ (* 3 (** x 2))
96 665c255d 2023-08-04 jrmu ;; 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
98 665c255d 2023-08-04 jrmu ;; (deriv '(* x y (+ x 3)) 'x)
100 665c255d 2023-08-04 jrmu ;; 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.
102 665c255d 2023-08-04 jrmu (define (make-sum . exps)
103 665c255d 2023-08-04 jrmu (let* ((nums (filter number? exps))
104 665c255d 2023-08-04 jrmu (non-nums (filter (lambda (exp) (not (number? exp))) exps))
105 665c255d 2023-08-04 jrmu (num (fold-right + 0 nums)))
106 665c255d 2023-08-04 jrmu (cond ((= num 0) (cond ((null? non-nums) 0)
107 665c255d 2023-08-04 jrmu ((null? (cdr non-nums)) (car non-nums))
108 665c255d 2023-08-04 jrmu (else (append (list '+) non-nums))))
109 665c255d 2023-08-04 jrmu ((null? non-nums) num)
110 665c255d 2023-08-04 jrmu (else (append (list '+)
112 665c255d 2023-08-04 jrmu (list num))))))
113 665c255d 2023-08-04 jrmu (define (make-sum . exps)
114 665c255d 2023-08-04 jrmu (let* ((nums (filter number? exps))
115 665c255d 2023-08-04 jrmu (non-nums (filter (lambda (exp) (not (number? exp))) exps))
116 665c255d 2023-08-04 jrmu (num (fold-right + 0 nums)))
117 665c255d 2023-08-04 jrmu (cond ((= num 0) (cond ((null? non-nums) 0)
118 665c255d 2023-08-04 jrmu ((null? (cdr non-nums)) (car non-nums))
119 665c255d 2023-08-04 jrmu (else (append (list '+) non-nums))))
120 665c255d 2023-08-04 jrmu ((null? non-nums) num)
121 665c255d 2023-08-04 jrmu (else (append (list '+)
123 665c255d 2023-08-04 jrmu (list num))))))
124 665c255d 2023-08-04 jrmu (define (make-product . exps)
125 665c255d 2023-08-04 jrmu (let* ((nums (filter number? exps))
126 665c255d 2023-08-04 jrmu (non-nums (filter (lambda (exp) (not (number? exp))) exps))
127 665c255d 2023-08-04 jrmu (num (fold-right * 1 nums)))
128 665c255d 2023-08-04 jrmu (cond ((null? exps) 1)
129 665c255d 2023-08-04 jrmu ((= num 0) 0)
130 665c255d 2023-08-04 jrmu ((null? non-nums) num)
131 665c255d 2023-08-04 jrmu ((null? (cdr non-nums)) (if (= num 1)
132 665c255d 2023-08-04 jrmu (car non-nums)
133 665c255d 2023-08-04 jrmu (append (list '* num) non-nums)))
134 665c255d 2023-08-04 jrmu (else (if (= num 1)
135 665c255d 2023-08-04 jrmu (cons '* non-nums)
136 665c255d 2023-08-04 jrmu (append (list '* num) non-nums))))))
138 665c255d 2023-08-04 jrmu ;; ((= nums 1) (cond ((null? non-nums) 1)
139 665c255d 2023-08-04 jrmu ;; ((null? (cdr non-nums)) (car non-nums))
140 665c255d 2023-08-04 jrmu ;; (else (append (list '*) non-nums))))
143 665c255d 2023-08-04 jrmu (test-case (make-sum) 0)
144 665c255d 2023-08-04 jrmu (test-case (make-sum 0) 0)
145 665c255d 2023-08-04 jrmu (test-case (make-sum 0 'x) 'x)
146 665c255d 2023-08-04 jrmu (test-case (make-sum 1 2 3 4 5) 15)
147 665c255d 2023-08-04 jrmu (test-case (make-sum 1 'x) '(+ x 1))
148 665c255d 2023-08-04 jrmu (test-case (make-sum 1 5 'x) '(+ x 6))
149 665c255d 2023-08-04 jrmu (test-case (make-sum 1 5 'x 'y) '(+ x y 6))
150 665c255d 2023-08-04 jrmu (test-case (make-sum -3 3 'x 'y) '(+ x y))
151 665c255d 2023-08-04 jrmu (test-case (make-sum -3 3 'x) 'x)
152 665c255d 2023-08-04 jrmu (test-case (make-sum 'a 'b 'c 'd 1 2 3 -6 -7 5) '(+ a b c d -2))
153 665c255d 2023-08-04 jrmu (test-case (make-sum 'a 'b 'c 'd 1 2 3 -6 -7 4 3) '(+ a b c d))
154 665c255d 2023-08-04 jrmu (test-case (make-sum (make-product 5 'x)
155 665c255d 2023-08-04 jrmu (make-product 3 'y)
157 665c255d 2023-08-04 jrmu '(+ (* 5 x) (* 3 y) 3))
158 665c255d 2023-08-04 jrmu (test-case (make-sum (make-product 5 'x)
159 665c255d 2023-08-04 jrmu (make-product 2 0 'y)
160 665c255d 2023-08-04 jrmu (make-product (make-sum 5 -5) 'x)
161 665c255d 2023-08-04 jrmu (make-product (make-sum 2 4 -6) 'y)
162 665c255d 2023-08-04 jrmu (make-product (make-product 0 1) 'z)
163 665c255d 2023-08-04 jrmu (make-product 4 'z)
165 665c255d 2023-08-04 jrmu (make-product 2 3))
166 665c255d 2023-08-04 jrmu '(+ (* 5 x) (* 4 z)))
168 665c255d 2023-08-04 jrmu (test-case (make-product) 1)
169 665c255d 2023-08-04 jrmu (test-case (make-product 1) 1)
170 665c255d 2023-08-04 jrmu (test-case (make-product 5) 5)
171 665c255d 2023-08-04 jrmu (test-case (make-product 'x) 'x)
172 665c255d 2023-08-04 jrmu (test-case (make-product 5 'x) '(* 5 x))
173 665c255d 2023-08-04 jrmu (test-case (make-product 5 2) 10)
174 665c255d 2023-08-04 jrmu (test-case (make-product 0) 0)
175 665c255d 2023-08-04 jrmu (test-case (make-product 0 1 3 2) 0)
176 665c255d 2023-08-04 jrmu (test-case (make-product 0 'x) 0)
177 665c255d 2023-08-04 jrmu (test-case (make-product 5 2 'x) '(* 10 x))
178 665c255d 2023-08-04 jrmu (test-case (make-product 5 'x 'y 'z 0) 0)
179 665c255d 2023-08-04 jrmu (test-case (make-product 5 'x 'y 'z) '(* 5 x y z))
180 665c255d 2023-08-04 jrmu (test-case (make-product 5 'x 2 -3 'y) '(* -30 x y))
181 665c255d 2023-08-04 jrmu (test-case (make-product 5 1/5 'x) 'x)
182 665c255d 2023-08-04 jrmu (test-case (make-product 5 1/5 'x 'y) '(* x y))
183 665c255d 2023-08-04 jrmu (test-case (make-product (make-sum 5 6 4 -2)
185 665c255d 2023-08-04 jrmu (make-sum 1 -3 3))
186 665c255d 2023-08-04 jrmu '(* 13 x y))
187 665c255d 2023-08-04 jrmu (test-case (make-product (make-sum (make-sum 2 4)
188 665c255d 2023-08-04 jrmu (make-product 3 -2))
189 665c255d 2023-08-04 jrmu (make-product 4 'y))
193 665c255d 2023-08-04 jrmu (define (addend s) (cadr s))
194 665c255d 2023-08-04 jrmu (define (augend s) (apply make-sum (cddr s)))
195 665c255d 2023-08-04 jrmu ;; alternatively,
196 665c255d 2023-08-04 jrmu ;; (if (null? (cdddr s))
197 665c255d 2023-08-04 jrmu ;; (caddr s)
198 665c255d 2023-08-04 jrmu ;; (apply make-sum (cddr s))))
200 665c255d 2023-08-04 jrmu (define (multiplier p) (cadr p))
201 665c255d 2023-08-04 jrmu (define (multiplicand p) (apply make-product (cddr p)))
203 665c255d 2023-08-04 jrmu (test-case (augend (make-sum 1 'x)) 1)
204 665c255d 2023-08-04 jrmu (test-case (augend (make-sum 1 5 'x)) 6)
205 665c255d 2023-08-04 jrmu (test-case (augend (make-sum 1 5 'x 'y)) '(+ y 6))
206 665c255d 2023-08-04 jrmu (test-case (augend (make-sum -3 3 'x 'y)) 'y)
207 665c255d 2023-08-04 jrmu (test-case (augend (make-sum 'a 'b 'c 'd 1 2 3 -6 -7 5)) '(+ b c d -2))
208 665c255d 2023-08-04 jrmu (test-case (augend (make-sum 'a 'b 'c 'd 1 2 3 -6 -7 4 3)) '(+ b c d))
209 665c255d 2023-08-04 jrmu (test-case (augend (make-sum (make-product 5 'x)
210 665c255d 2023-08-04 jrmu (make-product 3 'y)
212 665c255d 2023-08-04 jrmu '(+ (* 3 y) 3))
213 665c255d 2023-08-04 jrmu (test-case (augend (make-sum (make-product 5 'x)
214 665c255d 2023-08-04 jrmu (make-product 2 0 'y)
215 665c255d 2023-08-04 jrmu (make-product (make-sum 5 -5) 'x)
216 665c255d 2023-08-04 jrmu (make-product (make-sum 2 4 -6) 'y)
217 665c255d 2023-08-04 jrmu (make-product (make-product 0 1) 'z)
218 665c255d 2023-08-04 jrmu (make-product 4 'z)
220 665c255d 2023-08-04 jrmu (make-product 2 3)))
223 665c255d 2023-08-04 jrmu (test-case (multiplicand (make-product 5 'x)) 'x)
224 665c255d 2023-08-04 jrmu (test-case (multiplicand (make-product 5 'x 'y 'z)) '(* x y z))
225 665c255d 2023-08-04 jrmu (test-case (multiplicand (make-product 5 'x 2 -3 'y)) '(* x y))
226 665c255d 2023-08-04 jrmu (test-case (multiplicand (make-product (make-sum 5 6 4 -2)
228 665c255d 2023-08-04 jrmu (make-sum 1 -3 3)))
230 665c255d 2023-08-04 jrmu (test-case (deriv '(* x y (+ x 3)) 'x) '(+ (* x y) (* y (+ x 3))))
231 665c255d 2023-08-04 jrmu ;; (make-sum (make-product 'x (deriv '(* y (+ x 3)) 'x))
232 665c255d 2023-08-04 jrmu ;; '(* y (+ x 3))))
233 665c255d 2023-08-04 jrmu ;; (make-sum (make-product 'x 'y)
234 665c255d 2023-08-04 jrmu ;; '(* y (+ x 3)))
235 665c255d 2023-08-04 jrmu ;; (make-sum '(* x y)
236 665c255d 2023-08-04 jrmu ;; '(* y (+ x 3)))
237 665c255d 2023-08-04 jrmu ;; '(+ (* x y) (* y (+ x 3)))
