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