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