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