1 665c255d 2023-08-04 jrmu (define (celsius-fahrenheit-converter c f)
  2 665c255d 2023-08-04 jrmu   (let ((u (make-connector))
  3 665c255d 2023-08-04 jrmu         (v (make-connector))
  4 665c255d 2023-08-04 jrmu         (w (make-connector))
  5 665c255d 2023-08-04 jrmu         (x (make-connector))
  6 665c255d 2023-08-04 jrmu         (y (make-connector)))
  7 665c255d 2023-08-04 jrmu     (multiplier c w u)
  8 665c255d 2023-08-04 jrmu     (multiplier v x u)
  9 665c255d 2023-08-04 jrmu     (adder v y f)
 10 665c255d 2023-08-04 jrmu     (constant 9 w)
 11 665c255d 2023-08-04 jrmu     (constant 5 x)
 12 665c255d 2023-08-04 jrmu     (constant 32 y)
 13 665c255d 2023-08-04 jrmu     'ok))
 14 665c255d 2023-08-04 jrmu 
 15 665c255d 2023-08-04 jrmu (define (adder a1 a2 sum)
 16 665c255d 2023-08-04 jrmu   (define (process-new-value)
 17 665c255d 2023-08-04 jrmu     (cond ((and (has-value? a1) (has-value? a2))
 18 665c255d 2023-08-04 jrmu            (set-value! sum
 19 665c255d 2023-08-04 jrmu                        (+ (get-value a1) (get-value a2))
 20 665c255d 2023-08-04 jrmu                        me))
 21 665c255d 2023-08-04 jrmu           ((and (has-value? a1) (has-value? sum))
 22 665c255d 2023-08-04 jrmu            (set-value! a2
 23 665c255d 2023-08-04 jrmu                        (- (get-value sum) (get-value a1))
 24 665c255d 2023-08-04 jrmu                        me))
 25 665c255d 2023-08-04 jrmu           ((and (has-value? a2) (has-value? sum))
 26 665c255d 2023-08-04 jrmu            (set-value! a1
 27 665c255d 2023-08-04 jrmu                        (- (get-value sum) (get-value a2))
 28 665c255d 2023-08-04 jrmu                        me))))
 29 665c255d 2023-08-04 jrmu   (define (process-forget-value)
 30 665c255d 2023-08-04 jrmu     (forget-value! sum me)
 31 665c255d 2023-08-04 jrmu     (forget-value! a1 me)
 32 665c255d 2023-08-04 jrmu     (forget-value! a2 me)
 33 665c255d 2023-08-04 jrmu     (process-new-value))
 34 665c255d 2023-08-04 jrmu   (define (me request)
 35 665c255d 2023-08-04 jrmu     (cond ((eq? request 'I-have-a-value)  
 36 665c255d 2023-08-04 jrmu            (process-new-value))
 37 665c255d 2023-08-04 jrmu           ((eq? request 'I-lost-my-value) 
 38 665c255d 2023-08-04 jrmu            (process-forget-value))
 39 665c255d 2023-08-04 jrmu           (else 
 40 665c255d 2023-08-04 jrmu            (error "Unknown request -- ADDER" request))))
 41 665c255d 2023-08-04 jrmu   (connect a1 me)
 42 665c255d 2023-08-04 jrmu   (connect a2 me)
 43 665c255d 2023-08-04 jrmu   (connect sum me)
 44 665c255d 2023-08-04 jrmu   me)
 45 665c255d 2023-08-04 jrmu 
 46 665c255d 2023-08-04 jrmu (define (inform-about-value constraint)
 47 665c255d 2023-08-04 jrmu   (constraint 'I-have-a-value))
 48 665c255d 2023-08-04 jrmu (define (inform-about-no-value constraint)
 49 665c255d 2023-08-04 jrmu   (constraint 'I-lost-my-value))
 50 665c255d 2023-08-04 jrmu 
 51 665c255d 2023-08-04 jrmu (define (multiplier m1 m2 product)
 52 665c255d 2023-08-04 jrmu   (define (process-new-value)
 53 665c255d 2023-08-04 jrmu     (cond ((or (and (has-value? m1) (= (get-value m1) 0))
 54 665c255d 2023-08-04 jrmu                (and (has-value? m2) (= (get-value m2) 0)))
 55 665c255d 2023-08-04 jrmu            (set-value! product 0 me))
 56 665c255d 2023-08-04 jrmu           ((and (has-value? m1) (has-value? m2))
 57 665c255d 2023-08-04 jrmu            (set-value! product
 58 665c255d 2023-08-04 jrmu                        (* (get-value m1) (get-value m2))
 59 665c255d 2023-08-04 jrmu                        me))
 60 665c255d 2023-08-04 jrmu           ((and (has-value? product) (has-value? m1))
 61 665c255d 2023-08-04 jrmu            (set-value! m2
 62 665c255d 2023-08-04 jrmu                        (/ (get-value product) (get-value m1))
 63 665c255d 2023-08-04 jrmu                        me))
 64 665c255d 2023-08-04 jrmu           ((and (has-value? product) (has-value? m2))
 65 665c255d 2023-08-04 jrmu            (set-value! m1
 66 665c255d 2023-08-04 jrmu                        (/ (get-value product) (get-value m2))
 67 665c255d 2023-08-04 jrmu                        me))))
 68 665c255d 2023-08-04 jrmu   (define (process-forget-value)
 69 665c255d 2023-08-04 jrmu     (forget-value! product me)
 70 665c255d 2023-08-04 jrmu     (forget-value! m1 me)
 71 665c255d 2023-08-04 jrmu     (forget-value! m2 me)
 72 665c255d 2023-08-04 jrmu     (process-new-value))
 73 665c255d 2023-08-04 jrmu   (define (me request)
 74 665c255d 2023-08-04 jrmu     (cond ((eq? request 'I-have-a-value)
 75 665c255d 2023-08-04 jrmu            (process-new-value))
 76 665c255d 2023-08-04 jrmu           ((eq? request 'I-lost-my-value)
 77 665c255d 2023-08-04 jrmu            (process-forget-value))
 78 665c255d 2023-08-04 jrmu           (else
 79 665c255d 2023-08-04 jrmu            (error "Unknown request -- MULTIPLIER" request))))
 80 665c255d 2023-08-04 jrmu   (connect m1 me)
 81 665c255d 2023-08-04 jrmu   (connect m2 me)
 82 665c255d 2023-08-04 jrmu   (connect product me)
 83 665c255d 2023-08-04 jrmu   me)
 84 665c255d 2023-08-04 jrmu 
 85 665c255d 2023-08-04 jrmu (define (constant value connector)
 86 665c255d 2023-08-04 jrmu   (define (me request)
 87 665c255d 2023-08-04 jrmu     (error "Unknown request -- CONSTANT" request))
 88 665c255d 2023-08-04 jrmu   (connect connector me)
 89 665c255d 2023-08-04 jrmu   (set-value! connector value me)
 90 665c255d 2023-08-04 jrmu   me)
 91 665c255d 2023-08-04 jrmu 
 92 665c255d 2023-08-04 jrmu (define (probe name connector)
 93 665c255d 2023-08-04 jrmu   (define (print-probe value)
 94 665c255d 2023-08-04 jrmu     (newline)
 95 665c255d 2023-08-04 jrmu     (display "Probe: ")
 96 665c255d 2023-08-04 jrmu     (display name)
 97 665c255d 2023-08-04 jrmu     (display " = ")
 98 665c255d 2023-08-04 jrmu     (display value))
 99 665c255d 2023-08-04 jrmu   (define (process-new-value)
100 665c255d 2023-08-04 jrmu     (print-probe (get-value connector)))
101 665c255d 2023-08-04 jrmu   (define (process-forget-value)
102 665c255d 2023-08-04 jrmu     (print-probe "?"))
103 665c255d 2023-08-04 jrmu   (define (me request)
104 665c255d 2023-08-04 jrmu     (cond ((eq? request 'I-have-a-value)
105 665c255d 2023-08-04 jrmu            (process-new-value))
106 665c255d 2023-08-04 jrmu           ((eq? request 'I-lost-my-value)
107 665c255d 2023-08-04 jrmu            (process-forget-value))
108 665c255d 2023-08-04 jrmu           (else
109 665c255d 2023-08-04 jrmu            (error "Unknown request -- PROBE" request))))
110 665c255d 2023-08-04 jrmu   (connect connector me)
111 665c255d 2023-08-04 jrmu   me)
112 665c255d 2023-08-04 jrmu 
113 665c255d 2023-08-04 jrmu (define (make-connector)
114 665c255d 2023-08-04 jrmu   (let ((value false) (informant false) (constraints '()))
115 665c255d 2023-08-04 jrmu     (define (set-my-value newval setter)
116 665c255d 2023-08-04 jrmu       (cond ((not (has-value? me))
117 665c255d 2023-08-04 jrmu              (set! value newval)
118 665c255d 2023-08-04 jrmu              (set! informant setter)
119 665c255d 2023-08-04 jrmu              (for-each-except setter
120 665c255d 2023-08-04 jrmu                               inform-about-value
121 665c255d 2023-08-04 jrmu                               constraints))
122 665c255d 2023-08-04 jrmu             ((not (= value newval))
123 665c255d 2023-08-04 jrmu              (error "Contradiction" (list value newval)))
124 665c255d 2023-08-04 jrmu             (else 'ignored)))
125 665c255d 2023-08-04 jrmu     (define (forget-my-value retractor)
126 665c255d 2023-08-04 jrmu       (if (eq? retractor informant)
127 665c255d 2023-08-04 jrmu           (begin (set! informant false)
128 665c255d 2023-08-04 jrmu                  (for-each-except retractor
129 665c255d 2023-08-04 jrmu                                   inform-about-no-value
130 665c255d 2023-08-04 jrmu                                   constraints))
131 665c255d 2023-08-04 jrmu           'ignored))
132 665c255d 2023-08-04 jrmu     (define (connect new-constraint)
133 665c255d 2023-08-04 jrmu       (if (not (memq new-constraint constraints))
134 665c255d 2023-08-04 jrmu           (set! constraints 
135 665c255d 2023-08-04 jrmu                 (cons new-constraint constraints)))
136 665c255d 2023-08-04 jrmu       (if (has-value? me)
137 665c255d 2023-08-04 jrmu           (inform-about-value new-constraint))
138 665c255d 2023-08-04 jrmu       'done)
139 665c255d 2023-08-04 jrmu     (define (me request)
140 665c255d 2023-08-04 jrmu       (cond ((eq? request 'has-value?)
141 665c255d 2023-08-04 jrmu              (if informant true false))
142 665c255d 2023-08-04 jrmu             ((eq? request 'value) value)
143 665c255d 2023-08-04 jrmu             ((eq? request 'set-value!) set-my-value)
144 665c255d 2023-08-04 jrmu             ((eq? request 'forget) forget-my-value)
145 665c255d 2023-08-04 jrmu             ((eq? request 'connect) connect)
146 665c255d 2023-08-04 jrmu             (else (error "Unknown operation -- CONNECTOR"
147 665c255d 2023-08-04 jrmu                          request))))
148 665c255d 2023-08-04 jrmu     me))
149 665c255d 2023-08-04 jrmu 
150 665c255d 2023-08-04 jrmu (define (for-each-except exception procedure list)
151 665c255d 2023-08-04 jrmu   (define (loop items)
152 665c255d 2023-08-04 jrmu     (cond ((null? items) 'done)
153 665c255d 2023-08-04 jrmu           ((eq? (car items) exception) (loop (cdr items)))
154 665c255d 2023-08-04 jrmu           (else (procedure (car items))
155 665c255d 2023-08-04 jrmu                 (loop (cdr items)))))
156 665c255d 2023-08-04 jrmu   (loop list))
157 665c255d 2023-08-04 jrmu 
158 665c255d 2023-08-04 jrmu (define (has-value? connector)
159 665c255d 2023-08-04 jrmu   (connector 'has-value?))
160 665c255d 2023-08-04 jrmu (define (get-value connector)
161 665c255d 2023-08-04 jrmu   (connector 'value))
162 665c255d 2023-08-04 jrmu (define (set-value! connector new-value informant)
163 665c255d 2023-08-04 jrmu   ((connector 'set-value!) new-value informant))
164 665c255d 2023-08-04 jrmu (define (forget-value! connector retractor)
165 665c255d 2023-08-04 jrmu   ((connector 'forget) retractor))
166 665c255d 2023-08-04 jrmu (define (connect connector new-constraint)
167 665c255d 2023-08-04 jrmu   ((connector 'connect) new-constraint))
168 665c255d 2023-08-04 jrmu 
169 665c255d 2023-08-04 jrmu (define (test-case actual expected)
170 665c255d 2023-08-04 jrmu   (newline)
171 665c255d 2023-08-04 jrmu   (display "Actual:   ")
172 665c255d 2023-08-04 jrmu   (display actual)
173 665c255d 2023-08-04 jrmu   (newline)
174 665c255d 2023-08-04 jrmu   (display "Expected: ")
175 665c255d 2023-08-04 jrmu   (display expected)
176 665c255d 2023-08-04 jrmu   (newline))
177 665c255d 2023-08-04 jrmu 
178 665c255d 2023-08-04 jrmu (define (averager a b c)
179 665c255d 2023-08-04 jrmu   (let ((sum (make-connector))
180 665c255d 2023-08-04 jrmu 	(two (make-connector)))
181 665c255d 2023-08-04 jrmu     (adder a b sum)
182 665c255d 2023-08-04 jrmu     (constant 2 two)
183 665c255d 2023-08-04 jrmu     (multiplier two c sum)))
184 665c255d 2023-08-04 jrmu 
185 665c255d 2023-08-04 jrmu (define (squarer a b)
186 665c255d 2023-08-04 jrmu   (define (process-new-value)
187 665c255d 2023-08-04 jrmu     (if (has-value? b)
188 665c255d 2023-08-04 jrmu         (if (< (get-value b) 0)
189 665c255d 2023-08-04 jrmu             (error "square less than 0 -- SQUARER" (get-value b))
190 665c255d 2023-08-04 jrmu             (set-value! a 
191 665c255d 2023-08-04 jrmu 			(sqrt (get-value b))
192 665c255d 2023-08-04 jrmu 			me))
193 665c255d 2023-08-04 jrmu         (if (has-value? a)
194 665c255d 2023-08-04 jrmu 	    (set-value! b 
195 665c255d 2023-08-04 jrmu 			(square (get-value a))
196 665c255d 2023-08-04 jrmu 			me))))
197 665c255d 2023-08-04 jrmu   (define (process-forget-value) 
198 665c255d 2023-08-04 jrmu     (forget-value! a me)
199 665c255d 2023-08-04 jrmu     (forget-value! b me)
200 665c255d 2023-08-04 jrmu     (process-new-value))
201 665c255d 2023-08-04 jrmu   (define (me request) 
202 665c255d 2023-08-04 jrmu     (cond ((eq? request 'I-have-a-value) (process-new-value))
203 665c255d 2023-08-04 jrmu 	  ((eq? request 'I-lost-my-value) (process-forget-value))
204 665c255d 2023-08-04 jrmu 	  (else (error "Unknown request -- SQUARER"))))
205 665c255d 2023-08-04 jrmu   (connect a me)
206 665c255d 2023-08-04 jrmu   (connect b me)
207 665c255d 2023-08-04 jrmu   me)
208 665c255d 2023-08-04 jrmu 
209 665c255d 2023-08-04 jrmu ;; Exercise 3.37.  The celsius-fahrenheit-converter procedure is cumbersome when compared with a more expression-oriented style of definition, such as
210 665c255d 2023-08-04 jrmu 
211 665c255d 2023-08-04 jrmu ;; Here c+, c*, etc. are the ``constraint'' versions of the arithmetic operations. For example, c+ takes two connectors as arguments and returns a connector that is related to these by an adder constraint:
212 665c255d 2023-08-04 jrmu 
213 665c255d 2023-08-04 jrmu (define (c+ x y)
214 665c255d 2023-08-04 jrmu   (let ((z (make-connector)))
215 665c255d 2023-08-04 jrmu     (adder x y z)
216 665c255d 2023-08-04 jrmu     z))
217 665c255d 2023-08-04 jrmu 
218 665c255d 2023-08-04 jrmu ;; Define analogous procedures c-, c*, c/, and cv (constant value) that enable us to define compound constraints as in the converter example above.
219 665c255d 2023-08-04 jrmu 
220 665c255d 2023-08-04 jrmu (define (c- x y)
221 665c255d 2023-08-04 jrmu   (let ((z (make-connector)))
222 665c255d 2023-08-04 jrmu     (adder z y x)
223 665c255d 2023-08-04 jrmu     z))
224 665c255d 2023-08-04 jrmu 
225 665c255d 2023-08-04 jrmu (define (c* x y)
226 665c255d 2023-08-04 jrmu   (let ((z (make-connector)))
227 665c255d 2023-08-04 jrmu     (multiplier x y z)
228 665c255d 2023-08-04 jrmu     z))
229 665c255d 2023-08-04 jrmu 
230 665c255d 2023-08-04 jrmu (define (c/ x y)
231 665c255d 2023-08-04 jrmu   (let ((z (make-connector)))
232 665c255d 2023-08-04 jrmu     (multiplier z y x)
233 665c255d 2023-08-04 jrmu     z))
234 665c255d 2023-08-04 jrmu 
235 665c255d 2023-08-04 jrmu (define (cv const)
236 665c255d 2023-08-04 jrmu   (let ((z (make-connector)))
237 665c255d 2023-08-04 jrmu     (constant const z)
238 665c255d 2023-08-04 jrmu     z))
239 665c255d 2023-08-04 jrmu 
240 665c255d 2023-08-04 jrmu (define (celsius-fahrenheit-converter x)
241 665c255d 2023-08-04 jrmu   (c+ (c* (c/ (cv 9) (cv 5))
242 665c255d 2023-08-04 jrmu           x)
243 665c255d 2023-08-04 jrmu       (cv 32)))
244 665c255d 2023-08-04 jrmu (define C (make-connector))
245 665c255d 2023-08-04 jrmu (define F (celsius-fahrenheit-converter C))
246 665c255d 2023-08-04 jrmu 
247 665c255d 2023-08-04 jrmu (set-value! C 35 'user)
248 665c255d 2023-08-04 jrmu (test-case (get-value F) 95)
249 665c255d 2023-08-04 jrmu (forget-value! C 'user)
250 665c255d 2023-08-04 jrmu (set-value! F 302 'user)
251 665c255d 2023-08-04 jrmu (test-case (get-value C) 150)