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