]> git.rkrishnan.org Git - sicp.git/blob - src/sicp/ch3_3_5.rkt
rewrite `quote->cons' using `match'.
[sicp.git] / src / sicp / ch3_3_5.rkt
1 #lang racket
2
3 ;; implementation
4 (define (celsius-fahrenheit-converter c f)
5   (let ((u (make-connector))
6         (v (make-connector))
7         (w (make-connector))
8         (x (make-connector))
9         (y (make-connector)))
10     (multiplier c w u)
11     (multiplier v x u)
12     (adder v y f)
13     (constant 9 w)
14     (constant 5 x)
15     (constant 32 y)
16     'ok))
17
18 (define (adder a1 a2 sum)
19   (define (process-new-value)
20     (cond ((and (has-value? a1) (has-value? a2))
21            (set-value! sum
22                        (+ (get-value a1) (get-value a2))
23                        me))
24           ((and (has-value? a1) (has-value? sum))
25            (set-value! a2
26                        (- (get-value sum) (get-value a1))
27                        me))
28           ((and (has-value? a2) (has-value? sum))
29            (set-value! a1
30                        (- (get-value sum) (get-value a2))
31                        me))))
32   (define (process-forget-value)
33     (forget-value! sum me)
34     (forget-value! a1 me)
35     (forget-value! a2 me)
36     (process-new-value))
37   (define (me request)
38     (cond ((eq? request 'I-have-a-value)  
39            (process-new-value))
40           ((eq? request 'I-lost-my-value) 
41            (process-forget-value))
42           (else 
43            (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) (get-value m2))
57                        me))
58           ((and (has-value? product) (has-value? m1))
59            (set-value! m2
60                        (/ (get-value product) (get-value m1))
61                        me))
62           ((and (has-value? product) (has-value? m2))
63            (set-value! m1
64                        (/ (get-value product) (get-value m2))
65                        me))))
66   (define (process-forget-value)
67     (forget-value! product me)
68     (forget-value! m1 me)
69     (forget-value! m2 me)
70     (process-new-value))
71   (define (me request)
72     (cond ((eq? request 'I-have-a-value)
73            (process-new-value))
74           ((eq? request 'I-lost-my-value)
75            (process-forget-value))
76           (else
77            (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   (connect connector me)
87   (set-value! connector value me)
88   me)
89
90 (define (probe name connector)
91   (define (print-probe value)
92     (newline)
93     (display "Probe: ")
94     (display name)
95     (display " = ")
96     (display value))
97   (define (process-new-value)
98     (print-probe (get-value connector)))
99   (define (process-forget-value)
100     (print-probe "?"))
101   (define (me request)
102     (cond ((eq? request 'I-have-a-value)
103            (process-new-value))
104           ((eq? request 'I-lost-my-value)
105            (process-forget-value))
106           (else
107            (error "Unknown request -- PROBE" request))))
108   (connect connector me)
109   me)
110
111 (define (inform-about-value constraint)
112   (constraint 'I-have-a-value))
113 (define (inform-about-no-value constraint)
114   (constraint 'I-lost-my-value))
115
116 (define (make-connector)
117   (let ((value false) (informant #f) (constraints '()))
118     (define (set-my-value newval setter)
119       (cond ((not (has-value? me))
120              (set! value newval)
121              (set! informant setter)
122              (for-each-except setter
123                               inform-about-value
124                               constraints))
125             ((not (= value newval))
126              (error "Contradiction" (list value newval)))
127             (else 'ignored)))
128     (define (forget-my-value retractor)
129       (if (eq? retractor informant)
130           (begin (set! informant false)
131                  (for-each-except retractor
132                                   inform-about-no-value
133                                   constraints))
134           'ignored))
135     (define (connect new-constraint)
136       (when (not (memq new-constraint constraints))
137           (set! constraints 
138                 (cons new-constraint constraints)))
139       (when (has-value? me)
140           (inform-about-value new-constraint))
141       'done)
142     (define (me request)
143       (cond ((eq? request 'has-value?)
144              (if informant #t #f))
145             ((eq? request 'value) value)
146             ((eq? request 'set-value!) set-my-value)
147             ((eq? request 'forget) forget-my-value)
148             ((eq? request 'connect) connect)
149             (else (error "Unknown operation -- CONNECTOR"
150                          request))))
151     me))
152
153 (define (for-each-except exception procedure list)
154   (define (loop items)
155     (cond ((null? items) 'done)
156           ((eq? (car items) exception) (loop (cdr items)))
157           (else (procedure (car items))
158                 (loop (cdr items)))))
159   (loop list))
160
161 (define (has-value? connector)
162   (connector 'has-value?))
163 (define (get-value connector)
164   (connector 'value))
165 (define (set-value! connector new-value informant)
166   ((connector 'set-value!) new-value informant))
167 (define (forget-value! connector retractor)
168   ((connector 'forget) retractor))
169 (define (connect connector new-constraint)
170   ((connector 'connect) new-constraint))
171
172
173 ;; celcius to fahrenheit and vice-versa conv
174 (define C (make-connector))
175 (define F (make-connector))
176 (celsius-fahrenheit-converter C F)
177 (probe "Celsius temp" C)
178 (probe "Fahrenheit temp" F)
179