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