1 (define C (make-connector))
2 (define F (make-connector))
3 (celsius-fahrenheit-converter C F)
4 
5 (define (celsius-fahrenheit-converter c f)
6   (let ((u (make-connector))
7         (v (make-connector))
8         (w (make-connector))
9         (x (make-connector))
10         (y (make-connector)))
11     (multiplier c w u)
12     (multiplier v x u)
13     (adder v y f)
14     (constant 9 w)
15     (constant 5 x)
16     (constant 32 y)
17     'ok))
18 
19 (has-value? <connector>)
20 (get-value <connector>)
21 (set-value! <connector> <new-value> <informant>)
22 (forget-value! <connector> <retractor>)
23 (connect <connector> <new-constraint>)
24 
25 (define (adder a1 a2 sum)
26   (define (process-new-value)
27     (cond ((and (has-value? a1) (has-value? a2))
28            (set-value! sum
29                        (+ (get-value a1) (get-value a2))
30                        me))
31           ((and (has-value? a1) (has-value? sum))
32            (set-value! a2
33                        (- (get-value sum) (get-value a1))
34                        me))
35           ((and (has-value? a2) (has-value? sum))
36            (set-value! a1
37                        (- (get-value sum) (get-value a2))
38                        me))))
39   (define (process-forget-value)
40     (forget-value! sum me)
41     (forget-value! a1 me)
42     (forget-value! a2 me)
43     (process-new-value))
44   (define (me request)
45     (cond ((eq? request 'I-have-a-value)  
46            (process-new-value))
47           ((eq? request 'I-lost-my-value) 
48            (process-forget-value))
49           (else 
50            (error "Unknown request -- ADDER" request))))
51   (connect a1 me)
52   (connect a2 me)
53   (connect sum me)
54   me)
55 
56 (define (inform-about-value constraint)
57   (constraint 'I-have-a-value))
58 (define (inform-about-no-value constraint)
59   (constraint 'I-lost-my-value))
60 
61 (define (multiplier m1 m2 product)
62   (define (process-new-value)
63     (cond ((or (and (has-value? m1) (= (get-value m1) 0))
64                (and (has-value? m2) (= (get-value m2) 0)))
65            (set-value! product 0 me))
66           ((and (has-value? m1) (has-value? m2))
67            (set-value! product
68                        (* (get-value m1) (get-value m2))
69                        me))
70           ((and (has-value? product) (has-value? m1))
71            (set-value! m2
72                        (/ (get-value product) (get-value m1))
73                        me))
74           ((and (has-value? product) (has-value? m2))
75            (set-value! m1
76                        (/ (get-value product) (get-value m2))
77                        me))))
78   (define (process-forget-value)
79     (forget-value! product me)
80     (forget-value! m1 me)
81     (forget-value! m2 me)
82     (process-new-value))
83   (define (me request)
84     (cond ((eq? request 'I-have-a-value)
85            (process-new-value))
86           ((eq? request 'I-lost-my-value)
87            (process-forget-value))
88           (else
89            (error "Unknown request -- MULTIPLIER" request))))
90   (connect m1 me)
91   (connect m2 me)
92   (connect product me)
93   me)
94 
95 (define (constant value connector)
96   (define (me request)
97     (error "Unknown request -- CONSTANT" request))
98   (connect connector me)
99   (set-value! connector value me)
100   me)
101 
102 (define (probe name connector)
103   (define (print-probe value)
104     (newline)
105     (display "Probe: ")
106     (display name)
107     (display " = ")
108     (display value))
109   (define (process-new-value)
110     (print-probe (get-value connector)))
111   (define (process-forget-value)
112     (print-probe "?"))
113   (define (me request)
114     (cond ((eq? request 'I-have-a-value)
115            (process-new-value))
116           ((eq? request 'I-lost-my-value)
117            (process-forget-value))
118           (else
119            (error "Unknown request -- PROBE" request))))
120   (connect connector me)
121   me)
122 
123 (define (make-connector)
124   (let ((value false) (informant false) (constraints '()))
125     (define (set-my-value newval setter)
126       (cond ((not (has-value? me))
127              (set! value newval)
128              (set! informant setter)
129              (for-each-except setter
130                               inform-about-value
131                               constraints))
132             ((not (= value newval))
133              (error "Contradiction" (list value newval)))
134             (else 'ignored)))
135     (define (forget-my-value retractor)
136       (if (eq? retractor informant)
137           (begin (set! informant false)
138                  (for-each-except retractor
139                                   inform-about-no-value
140                                   constraints))
141           'ignored))
142     (define (connect new-constraint)
143       (if (not (memq new-constraint constraints))
144           (set! constraints 
145                 (cons new-constraint constraints)))
146       (if (has-value? me)
147           (inform-about-value new-constraint))
148       'done)
149     (define (me request)
150       (cond ((eq? request 'has-value?)
151              (if informant true false))
152             ((eq? request 'value) value)
153             ((eq? request 'set-value!) set-my-value)
154             ((eq? request 'forget) forget-my-value)
155             ((eq? request 'connect) connect)
156             (else (error "Unknown operation -- CONNECTOR"
157                          request))))
158     me))
159 
160 (define (for-each-except exception procedure list)
161   (define (loop items)
162     (cond ((null? items) 'done)
163           ((eq? (car items) exception) (loop (cdr items)))
164           (else (procedure (car items))
165                 (loop (cdr items)))))
166   (loop list))
167 
168 (define (has-value? connector)
169   (connector 'has-value?))
170 (define (get-value connector)
171   (connector 'value))
172 (define (set-value! connector new-value informant)
173   ((connector 'set-value!) new-value informant))
174 (define (forget-value! connector retractor)
175   ((connector 'forget) retractor))
176 (define (connect connector new-constraint)
177   ((connector 'connect) new-constraint))