Blame


1 665c255d 2023-08-04 jrmu (define (test-case actual expected)
2 665c255d 2023-08-04 jrmu (newline)
3 665c255d 2023-08-04 jrmu (display "Actual: ")
4 665c255d 2023-08-04 jrmu (display actual)
5 665c255d 2023-08-04 jrmu (newline)
6 665c255d 2023-08-04 jrmu (display "Expected: ")
7 665c255d 2023-08-04 jrmu (display expected)
8 665c255d 2023-08-04 jrmu (newline))
9 665c255d 2023-08-04 jrmu
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
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)))
25 665c255d 2023-08-04 jrmu
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?
27 665c255d 2023-08-04 jrmu
28 665c255d 2023-08-04 jrmu (define (sum? x)
29 665c255d 2023-08-04 jrmu (and (not (number? x))
30 665c255d 2023-08-04 jrmu (not (variable? x))
31 665c255d 2023-08-04 jrmu (not (null? (cdr x)))
32 665c255d 2023-08-04 jrmu (or (eq? (cadr x) '+)
33 665c255d 2023-08-04 jrmu (sum? (cddr x)))))
34 665c255d 2023-08-04 jrmu ;; sum?
35 665c255d 2023-08-04 jrmu ;; (newline)
36 665c255d 2023-08-04 jrmu ;; (display "sum??")
37 665c255d 2023-08-04 jrmu ;; (newline)
38 665c255d 2023-08-04 jrmu ;; (test-case (sum? '(5 + x)) #t)
39 665c255d 2023-08-04 jrmu ;; (test-case (sum? '(5 * x + 3)) #t)
40 665c255d 2023-08-04 jrmu ;; (test-case (sum? '(8 * x)) #f)
41 665c255d 2023-08-04 jrmu ;; (test-case (sum? 5) #f)
42 665c255d 2023-08-04 jrmu ;; (test-case (sum? '(5 * x + 8 * y)) #t)
43 665c255d 2023-08-04 jrmu ;; (test-case (sum? '(y * ((5 * x) + 3) + 2)) #t)
44 665c255d 2023-08-04 jrmu
45 665c255d 2023-08-04 jrmu ;; an expression is a product if it is not a sum and contains a * sign somewhere in the top 'level' of a list
46 665c255d 2023-08-04 jrmu (define (product? x)
47 665c255d 2023-08-04 jrmu (and (not (number? x))
48 665c255d 2023-08-04 jrmu (not (variable? x))
49 665c255d 2023-08-04 jrmu (not (sum? x))
50 665c255d 2023-08-04 jrmu (not (null? (cdr x)))
51 665c255d 2023-08-04 jrmu (or (eq? (cadr x) '*)
52 665c255d 2023-08-04 jrmu (product? (cddr x)))))
53 665c255d 2023-08-04 jrmu ;; (newline)
54 665c255d 2023-08-04 jrmu ;; (display "product?")
55 665c255d 2023-08-04 jrmu ;; (newline)
56 665c255d 2023-08-04 jrmu ;; (test-case (product? '(2 * x * y + 4)) #f)
57 665c255d 2023-08-04 jrmu ;; (test-case (product? '(x * y * z)) #t)
58 665c255d 2023-08-04 jrmu ;; (test-case (product? '((x + 1) * y)) #t)
59 665c255d 2023-08-04 jrmu ;; (test-case (product? '((x + (3 * z) * y) + (5 * z * (3 * y + 5)))) #f)
60 665c255d 2023-08-04 jrmu ;; (test-case (product? '((x + 3 * z * y) * y + 5)) #f)
61 665c255d 2023-08-04 jrmu
62 665c255d 2023-08-04 jrmu ;; If the first operation is +, we return the first element in the list
63 665c255d 2023-08-04 jrmu ;; Otherwise, we join the first two elements to the addend of the rest
64 665c255d 2023-08-04 jrmu ;; of the list.
65 665c255d 2023-08-04 jrmu (define (addend s)
66 665c255d 2023-08-04 jrmu (if (eq? '+ (cadr s))
67 665c255d 2023-08-04 jrmu (car s)
68 665c255d 2023-08-04 jrmu ;; we do not test if (cadddr s) is a number or variable because it might
69 665c255d 2023-08-04 jrmu ;; be a single nested list
70 665c255d 2023-08-04 jrmu (if (eq? (cadddr s) '+)
71 665c255d 2023-08-04 jrmu (list (car s) (cadr s) (addend (cddr s)))
72 665c255d 2023-08-04 jrmu (cons (car s)
73 665c255d 2023-08-04 jrmu (cons (cadr s)
74 665c255d 2023-08-04 jrmu (addend (cddr s)))))))
75 665c255d 2023-08-04 jrmu ;; (newline)
76 665c255d 2023-08-04 jrmu ;; (display "addend")
77 665c255d 2023-08-04 jrmu ;; (newline)
78 665c255d 2023-08-04 jrmu ;; (test-case (addend '(a + b + c)) 'a)
79 665c255d 2023-08-04 jrmu ;; (test-case (addend '(3 * x + 4 * y)) '(3 * x))
80 665c255d 2023-08-04 jrmu ;; (test-case (addend '(x * y * (z + 1) + (2 * 2))) '(x * y * (z + 1)))
81 665c255d 2023-08-04 jrmu ;; (test-case (addend '(2 * x * y + 4)) '(2 * x * y))
82 665c255d 2023-08-04 jrmu ;; (test-case (addend '((y + 1) * (y + 2) + 2 * ((3 * y) * 2) + 1))
83 665c255d 2023-08-04 jrmu ;; '((y + 1) * (y + 2)))
84 665c255d 2023-08-04 jrmu ;; (test-case (addend '((y + 1) * (y + 2) * (y + 3) + 2 * ((3 * y) * 2) + 1))
85 665c255d 2023-08-04 jrmu ;; '((y + 1) * (y + 2) * (y + 3)))
86 665c255d 2023-08-04 jrmu
87 665c255d 2023-08-04 jrmu ;; 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 665c255d 2023-08-04 jrmu (define (augend s)
89 665c255d 2023-08-04 jrmu (if (eq? '+ (cadr s))
90 665c255d 2023-08-04 jrmu (if (null? (cdddr s))
91 665c255d 2023-08-04 jrmu (caddr s)
92 665c255d 2023-08-04 jrmu (cddr s))
93 665c255d 2023-08-04 jrmu (augend (cddr s))))
94 665c255d 2023-08-04 jrmu ;; (newline)
95 665c255d 2023-08-04 jrmu ;; (display "augend")
96 665c255d 2023-08-04 jrmu ;; (newline)
97 665c255d 2023-08-04 jrmu ;; (test-case (augend '(x + 6)) '6)
98 665c255d 2023-08-04 jrmu ;; (test-case (augend '(x + y + 6)) '(y + 6))
99 665c255d 2023-08-04 jrmu ;; (test-case (augend '(x + y * x)) '(y * x))
100 665c255d 2023-08-04 jrmu ;; (test-case (augend '(a + b + c + d + 5)) '(b + c + d + 5))
101 665c255d 2023-08-04 jrmu ;; (test-case (augend '(5 * x + 3 * y + 3))
102 665c255d 2023-08-04 jrmu ;; '(3 * y + 3))
103 665c255d 2023-08-04 jrmu ;; (test-case (augend '(5 * x + (y + 1) * (y + 2) + 2 * ((3 * y) * 2) + 1))
104 665c255d 2023-08-04 jrmu ;; '((y + 1) * (y + 2) + 2 * ((3 * y) * 2) + 1))
105 665c255d 2023-08-04 jrmu
106 665c255d 2023-08-04 jrmu (define (multiplier p)
107 665c255d 2023-08-04 jrmu (car p))
108 665c255d 2023-08-04 jrmu ;; (newline)
109 665c255d 2023-08-04 jrmu ;; (display "multiplier")
110 665c255d 2023-08-04 jrmu ;; (newline)
111 665c255d 2023-08-04 jrmu ;; (test-case (multiplier '(5 * x)) 5)
112 665c255d 2023-08-04 jrmu ;; (test-case (multiplier '(x * (x + 2))) 'x)
113 665c255d 2023-08-04 jrmu ;; (test-case (multiplier '((x + 1) * (x + 2) * (x + 3))) '(x + 1))
114 665c255d 2023-08-04 jrmu ;; (test-case (multiplier '((5 * x + 2) * 3)) '(5 * x + 2))
115 665c255d 2023-08-04 jrmu ;; (test-case (multiplier '((((x + 1) * (x + 2)) + 5) * (x + 3))) '(((x + 1) * (x + 2)) + 5))
116 665c255d 2023-08-04 jrmu ;; (test-case (multiplier '((y * (x + 5 * (y + 2)) + 4) * x * z)) '(y * (x + 5 * (y + 2)) + 4))
117 665c255d 2023-08-04 jrmu ;; (test-case (multiplier '((x + y + z) * (x + y))) '(x + y + z))
118 665c255d 2023-08-04 jrmu
119 665c255d 2023-08-04 jrmu (define (multiplicand p)
120 665c255d 2023-08-04 jrmu (if (null? (cdddr p))
121 665c255d 2023-08-04 jrmu (caddr p)
122 665c255d 2023-08-04 jrmu (cddr p)))
123 665c255d 2023-08-04 jrmu ;; (newline)
124 665c255d 2023-08-04 jrmu ;; (display "multiplicand")
125 665c255d 2023-08-04 jrmu ;; (newline)
126 665c255d 2023-08-04 jrmu ;; (test-case (multiplicand '(5 * x)) 'x)
127 665c255d 2023-08-04 jrmu ;; (test-case (multiplicand '(x * (x + 2))) '(x + 2))
128 665c255d 2023-08-04 jrmu ;; (test-case (multiplicand '((x + 1) * (x + 2) * (x + 3))) '((x + 2) * (x + 3)))
129 665c255d 2023-08-04 jrmu ;; (test-case (multiplicand '((5 * x + 2) * y)) 'y)
130 665c255d 2023-08-04 jrmu ;; (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 665c255d 2023-08-04 jrmu ;; (test-case (multiplicand '((y * (x + 5 * (y + 2)) + 4) * x * z)) '(x * z))
132 665c255d 2023-08-04 jrmu ;; (test-case (multiplicand '((x + y + z) * (x + y))) '(x + y))
133 665c255d 2023-08-04 jrmu
134 665c255d 2023-08-04 jrmu ;; given a list of items to sum, check to see if any of the items are sums.
135 665c255d 2023-08-04 jrmu ;; If they are, return a new list with the addend and augends as separate expressions
136 665c255d 2023-08-04 jrmu (define (break-sums exps)
137 665c255d 2023-08-04 jrmu (if (null? exps)
138 665c255d 2023-08-04 jrmu '()
139 665c255d 2023-08-04 jrmu (let ((x (car exps)))
140 665c255d 2023-08-04 jrmu (if (sum? x)
141 665c255d 2023-08-04 jrmu (cons (addend x)
142 665c255d 2023-08-04 jrmu (break-sums (cons (augend x) (cdr exps))))
143 665c255d 2023-08-04 jrmu (cons x (break-sums (cdr exps)))))))
144 665c255d 2023-08-04 jrmu
145 665c255d 2023-08-04 jrmu ;; (newline)
146 665c255d 2023-08-04 jrmu ;; (display "break-sums")
147 665c255d 2023-08-04 jrmu ;; (newline)
148 665c255d 2023-08-04 jrmu ;; (test-case (break-sums '((x + 5) x 3)) '(x 5 x 3))
149 665c255d 2023-08-04 jrmu ;; (test-case (break-sums '((x + (x + 5)) x 3)) '(x x 5 x 3))
150 665c255d 2023-08-04 jrmu ;; (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 665c255d 2023-08-04 jrmu
152 665c255d 2023-08-04 jrmu ;; interpolate '+ signs between expressions
153 665c255d 2023-08-04 jrmu (define (add-plus-signs exps)
154 665c255d 2023-08-04 jrmu (if (null? exps)
155 665c255d 2023-08-04 jrmu '() ;; this should never execute
156 665c255d 2023-08-04 jrmu (let ((x (car exps))
157 665c255d 2023-08-04 jrmu (remnant (cdr exps)))
158 665c255d 2023-08-04 jrmu (cond ((null? remnant)
159 665c255d 2023-08-04 jrmu (if (or (number? x)
160 665c255d 2023-08-04 jrmu (variable? x))
161 665c255d 2023-08-04 jrmu (list x)
162 665c255d 2023-08-04 jrmu x)) ;; when x is a one-element list like '((x * y))
163 665c255d 2023-08-04 jrmu ((or (number? x)
164 665c255d 2023-08-04 jrmu (variable? x))
165 665c255d 2023-08-04 jrmu (cons x (cons '+ (add-plus-signs remnant))))
166 665c255d 2023-08-04 jrmu ((sum? x)
167 665c255d 2023-08-04 jrmu (error "unexpected sum"))
168 665c255d 2023-08-04 jrmu ((product? x)
169 665c255d 2023-08-04 jrmu (cons (multiplier x)
170 665c255d 2023-08-04 jrmu (cons '*
171 665c255d 2023-08-04 jrmu (add-plus-signs (cons (multiplicand x) remnant)))))
172 665c255d 2023-08-04 jrmu (else (error "expression type not yet implemented"))))))
173 665c255d 2023-08-04 jrmu ;; (newline)
174 665c255d 2023-08-04 jrmu ;; (display "add-plus-signs")
175 665c255d 2023-08-04 jrmu ;; (newline)
176 665c255d 2023-08-04 jrmu ;; (test-case (add-plus-signs '()) '())
177 665c255d 2023-08-04 jrmu ;; (test-case (add-plus-signs '(1)) '(1))
178 665c255d 2023-08-04 jrmu ;; (test-case (add-plus-signs '(x y z 4)) '(x + y + z + 4))
179 665c255d 2023-08-04 jrmu ;; (test-case (add-plus-signs '((x * y))) '(x * y))
180 665c255d 2023-08-04 jrmu ;; (test-case (add-plus-signs '((x * y) 5)) '(x * y + 5))
181 665c255d 2023-08-04 jrmu ;; (test-case (add-plus-signs '(((x * y) * (x + 1)) (5 * (x + 1)))) '((x * y) * (x + 1) + 5 * (x + 1)))
182 665c255d 2023-08-04 jrmu ;; (test-case (add-plus-signs '(((x * y + 2) * (y + 5)) a b (((a * b + 2) * c * (d + 1)) * (e + 4))))
183 665c255d 2023-08-04 jrmu ;; '((x * y + 2) * (y + 5) + a + b + ((a * b + 2) * c * (d + 1)) * (e + 4)))
184 665c255d 2023-08-04 jrmu
185 665c255d 2023-08-04 jrmu ;; If the term is:
186 665c255d 2023-08-04 jrmu ;; a number or a variable: we deal with it is without adding or removing any parentheses
187 665c255d 2023-08-04 jrmu ;; 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.
188 665c255d 2023-08-04 jrmu ;; 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 as separate terms
189 665c255d 2023-08-04 jrmu (define (make-sum . exps)
190 665c255d 2023-08-04 jrmu (let* ((terms (break-sums exps))
191 665c255d 2023-08-04 jrmu (nums (filter number? terms))
192 665c255d 2023-08-04 jrmu (non-nums (filter (lambda (exp) (not (number? exp))) terms))
193 665c255d 2023-08-04 jrmu (sum-of-nums (fold-right + 0 nums)))
194 665c255d 2023-08-04 jrmu (cond ((null? non-nums) sum-of-nums)
195 665c255d 2023-08-04 jrmu ((and (= sum-of-nums 0)
196 665c255d 2023-08-04 jrmu (null? (cdr non-nums))) (car non-nums))
197 665c255d 2023-08-04 jrmu ((= sum-of-nums 0) (add-plus-signs non-nums))
198 665c255d 2023-08-04 jrmu (else (add-plus-signs (append non-nums (list sum-of-nums)))))))
199 665c255d 2023-08-04 jrmu ;; (newline)
200 665c255d 2023-08-04 jrmu ;; (display "make-sum")
201 665c255d 2023-08-04 jrmu ;; (newline)
202 665c255d 2023-08-04 jrmu ;; (test-case (make-sum 0 'x) 'x)
203 665c255d 2023-08-04 jrmu ;; (test-case (make-sum 1 2) 3)
204 665c255d 2023-08-04 jrmu ;; (test-case (make-sum 1 'x) '(x + 1))
205 665c255d 2023-08-04 jrmu ;; (test-case (make-sum 'x 'y) '(x + y))
206 665c255d 2023-08-04 jrmu ;; (test-case (make-sum (make-sum -3 'y)
207 665c255d 2023-08-04 jrmu ;; (make-sum 3 'x)) '(y + x))
208 665c255d 2023-08-04 jrmu ;; (make-sum '(y + -3) '(x + 3))
209 665c255d 2023-08-04 jrmu ;; (make-sum 'y -3 'x 3)
210 665c255d 2023-08-04 jrmu ;; (test-case (make-sum -3 'y 3 'x) '(y + x))
211 665c255d 2023-08-04 jrmu ;; (test-case (make-sum (make-sum 'a (make-sum 'b (make-sum 'c 'd)))) '(a + b + c + d))
212 665c255d 2023-08-04 jrmu ;; (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 665c255d 2023-08-04 jrmu ;; (test-case (make-sum 4 '(2 * x * y)) '(2 * x * y + 4))
214 665c255d 2023-08-04 jrmu ;; (test-case (make-sum '(3 * z) '(2 * x * y)) '(3 * z + 2 * x * y))
215 665c255d 2023-08-04 jrmu ;; (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 665c255d 2023-08-04 jrmu
217 665c255d 2023-08-04 jrmu ;; given a list of items to multiply, check to see if any of the items are products.
218 665c255d 2023-08-04 jrmu ;; If they are, return a new list with the multiplier and multiplicands as separate expressions
219 665c255d 2023-08-04 jrmu (define (break-products exps)
220 665c255d 2023-08-04 jrmu (if (null? exps)
221 665c255d 2023-08-04 jrmu '()
222 665c255d 2023-08-04 jrmu (let ((x (car exps)))
223 665c255d 2023-08-04 jrmu (if (product? x)
224 665c255d 2023-08-04 jrmu (cons (multiplier x)
225 665c255d 2023-08-04 jrmu (break-products (cons (multiplicand x) (cdr exps))))
226 665c255d 2023-08-04 jrmu (cons x (break-products (cdr exps)))))))
227 665c255d 2023-08-04 jrmu
228 665c255d 2023-08-04 jrmu ;; (newline)
229 665c255d 2023-08-04 jrmu ;; (display "break-products")
230 665c255d 2023-08-04 jrmu ;; (newline)
231 665c255d 2023-08-04 jrmu ;; (test-case (break-products '((5 * x) x 3)) '(5 x x 3))
232 665c255d 2023-08-04 jrmu ;; (test-case (break-products '((x * (5 * x)) x 3)) '(x 5 x x 3))
233 665c255d 2023-08-04 jrmu ;; (test-case (break-products '((5 * a * b + x + y) (x * y + 5) (2 * a * b) (x * y))) '((5 * a * b + x + y) (x * y + 5) 2 a b x y))
234 665c255d 2023-08-04 jrmu
235 665c255d 2023-08-04 jrmu ;; interpolate '* signs between expressions
236 665c255d 2023-08-04 jrmu (define (add-mult-signs exps)
237 665c255d 2023-08-04 jrmu (if (null? exps)
238 665c255d 2023-08-04 jrmu '() ;; this should never execute
239 665c255d 2023-08-04 jrmu (let ((x (car exps))
240 665c255d 2023-08-04 jrmu (remnant (cdr exps)))
241 665c255d 2023-08-04 jrmu (cond ((null? remnant)
242 665c255d 2023-08-04 jrmu (if (or (number? x)
243 665c255d 2023-08-04 jrmu (variable? x)
244 665c255d 2023-08-04 jrmu (sum? x))
245 665c255d 2023-08-04 jrmu (list x)
246 665c255d 2023-08-04 jrmu x)) ;; when x is a one-element list like '((x ** y))
247 665c255d 2023-08-04 jrmu ((or (number? x)
248 665c255d 2023-08-04 jrmu (variable? x)
249 665c255d 2023-08-04 jrmu (sum? x))
250 665c255d 2023-08-04 jrmu (cons x (cons '* (add-mult-signs remnant))))
251 665c255d 2023-08-04 jrmu ((product? x)
252 665c255d 2023-08-04 jrmu (error "unexpected product"))
253 665c255d 2023-08-04 jrmu (else (error "expression type not yet implemented"))))))
254 665c255d 2023-08-04 jrmu ;; (newline)
255 665c255d 2023-08-04 jrmu ;; (display "add-mult-signs")
256 665c255d 2023-08-04 jrmu ;; (newline)
257 665c255d 2023-08-04 jrmu ;; (test-case (add-mult-signs '()) '())
258 665c255d 2023-08-04 jrmu ;; (test-case (add-mult-signs '(1)) '(1))
259 665c255d 2023-08-04 jrmu ;; (test-case (add-mult-signs '(4 x y z)) '(4 * x * y * z))
260 665c255d 2023-08-04 jrmu ;; (test-case (add-mult-signs '((x * y))) '(x * y))
261 665c255d 2023-08-04 jrmu ;; (test-case (add-mult-signs '(5 (x + y))) '(5 * (x + y)))
262 665c255d 2023-08-04 jrmu ;; (test-case (add-mult-signs '((x + y) (x + 1) ((2 * x + 1) + 5 * x))) '((x + y) * (x + 1) * ((2 * x + 1) + 5 * x)))
263 665c255d 2023-08-04 jrmu ;; (test-case (add-mult-signs '((x * y + 2) (y + 5) a b (a * b + 2) c (d + 1) (e + 4)))
264 665c255d 2023-08-04 jrmu ;; '((x * y + 2) * (y + 5) * a * b * (a * b + 2) * c * (d + 1) * (e + 4)))
265 665c255d 2023-08-04 jrmu
266 665c255d 2023-08-04 jrmu ;; If the exp is a:
267 665c255d 2023-08-04 jrmu ;; variable or number, we just multiply without adding any extra parentheses
268 665c255d 2023-08-04 jrmu ;; sum, then we leave the parentheses intact and multiply, treating the sum as a single term
269 665c255d 2023-08-04 jrmu ;; product, then we must remove the parentheses around the product (optionally leaving the multiplier's and potentially multiple multiplicands' parentheses intact). We must deal with the multiplier and potentially multiple multiplicands as separate terms.
270 665c255d 2023-08-04 jrmu ;; (not implemented) a complex expression, we remove the parentheses around the expression and treat it as a single term
271 665c255d 2023-08-04 jrmu
272 665c255d 2023-08-04 jrmu (define (make-product . exps)
273 665c255d 2023-08-04 jrmu (let* ((terms (break-products exps))
274 665c255d 2023-08-04 jrmu (nums (filter number? terms))
275 665c255d 2023-08-04 jrmu (non-nums (filter (lambda (exp) (not (number? exp))) terms))
276 665c255d 2023-08-04 jrmu (product-of-nums (fold-right * 1 nums)))
277 665c255d 2023-08-04 jrmu (cond ((null? non-nums) product-of-nums)
278 665c255d 2023-08-04 jrmu ((= product-of-nums 0) 0)
279 665c255d 2023-08-04 jrmu ((and (= product-of-nums 1)
280 665c255d 2023-08-04 jrmu (null? (cdr non-nums))) (car non-nums))
281 665c255d 2023-08-04 jrmu ((= product-of-nums 1) (add-mult-signs non-nums))
282 665c255d 2023-08-04 jrmu (else (add-mult-signs (cons product-of-nums non-nums))))))
283 665c255d 2023-08-04 jrmu
284 665c255d 2023-08-04 jrmu ;; (test-case (make-product 5 '(5 * x)) '(25 * x))
285 665c255d 2023-08-04 jrmu ;; (test-case (make-product 5 'x) '(5 * x))
286 665c255d 2023-08-04 jrmu ;; (test-case (make-product 5 2) 10)
287 665c255d 2023-08-04 jrmu ;; (test-case (make-product 0 'x) 0)
288 665c255d 2023-08-04 jrmu ;; (test-case (make-product 5 2 'x) '(10 * x))
289 665c255d 2023-08-04 jrmu ;; (test-case (make-product 5 1/5 'x 'y) '(x * y))
290 665c255d 2023-08-04 jrmu ;; (test-case (make-product (make-product 'x 5) (make-product 'x 3 (make-product 1/15 'y 'z)) 'x) '(x * x * y * z * x))
291 665c255d 2023-08-04 jrmu ;; (test-case (make-product '(x + 3) 'y) '((x + 3) * y))
292 665c255d 2023-08-04 jrmu ;; (test-case (make-product (make-sum 5 'x)
293 665c255d 2023-08-04 jrmu ;; (make-product 'x 'y)
294 665c255d 2023-08-04 jrmu ;; (make-sum 'z 2))
295 665c255d 2023-08-04 jrmu ;; '((x + 5) * x * y * (z + 2)))
296 665c255d 2023-08-04 jrmu ;; (test-case (make-product
297 665c255d 2023-08-04 jrmu ;; (make-sum (make-product 5 'x)
298 665c255d 2023-08-04 jrmu ;; (make-product 3 'y))
299 665c255d 2023-08-04 jrmu ;; (make-sum (make-product 2 'y)
300 665c255d 2023-08-04 jrmu ;; (make-product 2 3))
301 665c255d 2023-08-04 jrmu ;; (make-sum (make-sum 'x 4) (make-product 3 'y)))
302 665c255d 2023-08-04 jrmu ;; '((5 * x + 3 * y) * (2 * y + 6) * (x + 3 * y + 4)))
303 665c255d 2023-08-04 jrmu (test-case (make-sum (make-product 'a 'b)
304 665c255d 2023-08-04 jrmu (make-product 'c (make-sum 'd 1) 'e)
305 665c255d 2023-08-04 jrmu (make-product (make-sum 'f 2) (make-sum 'g 3) 'h))
306 665c255d 2023-08-04 jrmu '(a * b + c * (d + 1) * e + (f + 2) * (g + 3) * h))
307 665c255d 2023-08-04 jrmu (test-case (make-product (make-sum 5 'x)
308 665c255d 2023-08-04 jrmu (make-product 'x 'y)
309 665c255d 2023-08-04 jrmu (make-sum 'z 2))
310 665c255d 2023-08-04 jrmu '((x + 5) * x * y * (z + 2)))
311 665c255d 2023-08-04 jrmu
312 665c255d 2023-08-04 jrmu
313 665c255d 2023-08-04 jrmu
314 665c255d 2023-08-04 jrmu
315 665c255d 2023-08-04 jrmu (test-case (deriv '(x * y * (x + 3)) 'x) '(x * y + y * (x + 3)))