1 (define (celsius-fahrenheit-converter c f)
2   (let ((nine (make-connector))
3 	(five (make-connector))
4 	(three-two (make-connector))
5 	(product (make-connector))
6 	(difference (make-connector)))
7     (constant 9 nine)
8     (constant 5 five)
9     (constant 32 three-two)
10     (adder three-two difference f)
11     (multiplier c nine product)
12     (multiplier five difference product))
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)
20 			  (get-value a2))
21 		       me))
22 	  ((and (has-value? a1) (has-value? sum))
23 	   (set-value! a2
24 		       (- (get-value sum)
25 			  (get-value a1))
26 		       me))
27 	  ((and (has-value? a2) (has-value? sum))
28 	   (set-value! a1
29 		       (- (get-value sum)
30 			  (get-value a2))
31 		       me))))
32   (define (process-forget-value)
33     (forget-value! a1 me)
34     (forget-value! a2 me)
35     (forget-value! sum me)
36     (process-new-value))
37   (define (me request)
38     (cond ((eq? 'I-have-a-value) (process-new-value))
39 	  ((eq? 'I-lost-my-value) (process-forget-value))
40 	  (else (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)
59 			  (get-value m2))
60 		       me))
61 	  ((and (has-value? m1) (has-value? product))
62 	   (set-value! m2
63 		       (/ (get-value product)
64 			  (get-value m1))
65 		       me))
66 	  ((and (has-value? m2) (has-value? product))
67 	   (set-value! m1
68 		       (/ (get-value product)
69 			  (get-value m2))
70 		       me))))
71   (define (process-forget-value)
72     (forget-value! m1 me)
73     (forget-value! m2 me)
74     (forget-value! product me)
75     (process-new-value))
76   (define (me request)
77     (cond ((eq? request 'I-have-a-value) (process-new-value))
78 	  ((eq? request 'I-lost-my-value) (process-forget-value))
79 	  (else (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 name)
96     (display ": ")
97     (display value))
98   (define (process-new-value)
99     (print-probe (get-value connector)))
100   (define (process-forget-value)
101     (print-probe "?"))
102   (define (me request)
103     (cond ((eq? 'I-have-a-value) (process-new-value))
104 	  ((eq? 'I-lost-my-value) (process-forget-value))
105 	  (else (error "Unknown request -- PROBE" request))))
106   (connect connector me)
107   me)
108 
109 (define (for-each-except exception proc items)
110   (cond ((null? items) 'done)
111 	((eq? (car items) exception) 
112 	 (for-each-except exception proc (cdr items)))
113 	(else (proc (car items))
114 	      (for-each-except exception proc (cdr items)))))
115 
116 (define (make-connector)
117   (let ((value false) (informant false) (constraints '()))
118     (define (set-my-value newval setter)
119       (if informant
120 	  (if (= value newval)
121 	      'ignored
122 	      (error "Contradictory values: " (list value newval)))
123 	  (begin (set-value! informant setter)
124 		 (set-value! value newval)
125 		 (for-each-except setter 
126 				  inform-about-value
127 				  constraints))))
128     (define (forget-my-value retractor)
129       (if (eq? retractor informant)
130 	  (begin (set-value! informant false)
131 		 (for-each-except retractor
132 				  inform-about-no-value
133 				  constraints))
134 	  'ignored))
135     (define (connect constraint)
136       (if (memq constraint constraints)
137 	  'ignored
138 	  (begin (set! constraints (cons constraint constraints))
139 		 (if (has-value? me)
140 		     (inform-about-value constraint)))))
141     (define (me request)
142       (cond ((eq? request 'has-value?) (if informant true false))
143 	    ((eq? request 'value) value)
144 	    ((eq? request 'set-value!) set-my-value)
145 	    ((eq? request 'forget) forget-my-value)
146 	    ((eq? request 'connect) connect)
147 	    (else (error "Unknown operation -- CONNECTOR" request))))
148     me))
149 
150 (define (has-value? connector)
151   (connector 'has-value))
152 (define (get-value connector)
153   (connector 'value))
154 (define (set-value! connector newval informant)
155   ((connector 'set-value!) newval informant))
156 (define (forget-value! connector retractor)
157   ((connector 'forget) retractor))
158 (define (connect connector constraint)
159   ((connector 'connect) constraint))
160