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