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 ;; Exercise 3.34.  Louis Reasoner wants to build a squarer, a constraint device with two terminals such that the value of connector b on the second terminal will always be the square of the value a on the first terminal. He proposes the following simple device made from a multiplier:
186 665c255d 2023-08-04 jrmu 
187 665c255d 2023-08-04 jrmu (define (squarer a b)
188 665c255d 2023-08-04 jrmu   (multiplier a a b))
189 665c255d 2023-08-04 jrmu 
190 665c255d 2023-08-04 jrmu ;; There is a serious flaw in this idea. Explain. 
191 665c255d 2023-08-04 jrmu 
192 665c255d 2023-08-04 jrmu ;; This constraint only works in one direction. If a has a value, then the value is propagated to b. But, if b has a value, the value is not propagated to a because a multiplier normally needs to know one product plus one factor in orer to figure out the value of the second factor. The problem is that the multiplier is unaware that the two factors are referring to the same connector.