Finish chapter 3 part 3

1 files changed, 297 insertions, 3 deletions

diff --git a/chap3/part3.rkt b/chap3/part3.rkt
index 7e41231..d04e1e2 100644
--- a/chap3/part3.rkt
+++ b/chap3/part3.rkt
@@ -1006,8 +1006,8 @@
     (inverter nout na2)
     'ok))
 
-(#%provide probe)
-(define (probe name wire)
+(#%provide probe-wire)
+(define (probe-wire name wire)
   (add-action!
     wire
     (lambda ()
@@ -1018,4 +1018,298 @@
       (display "  New-value = ")
       (display (get-signal wire)))))
 
-;; constraints
+(define (inform-about-value constraint)
+  (constraint 'I-have-a-value))
+
+(define (inform-about-no-value constraint)
+  (constraint 'I-lost-my-value))
+
+(#%provide has-value?)
+(define (has-value? connector)
+  (connector 'has-value?))
+
+(#%provide get-value)
+(define (get-value connector)
+  (connector 'value))
+
+(#%provide set-value!)
+(define (set-value! connector new-value informant)
+  ((connector 'set-value) new-value informant))
+
+(#%provide forget-value!)
+(define (forget-value! connector retractor)
+  ((connector 'forget) retractor))
+
+(#%provide connect)
+(define (connect connector new-constraint)
+  ((connector 'connect) new-constraint))
+
+(define (for-each-except exception procedure list)
+  (define (loop items)
+    (cond
+      ((null? items) 'done)
+      ((eq? (car items) exception)
+       (loop (cdr items)))
+      (else
+        (procedure (car items))
+        (loop (cdr items)))))
+  (loop list))
+
+(#%provide make-connector)
+(define (make-connector)
+  (let ((value false) (informant false) (constraints '()))
+    (define (set-my-value newval setter)
+      (cond
+        ((not (has-value? me))
+         (set! value newval)
+         (set! informant setter)
+         (for-each-except
+           setter
+           inform-about-value
+           constraints))
+        ((not (= value newval))
+         (error "Contradiction" (list value newval)))
+        (else 'ignored)))
+    (define (forget-my-value retractor)
+      (if (eq? retractor informant)
+        (begin
+          (set! informant false)
+          (for-each-except
+            retractor
+            inform-about-no-value
+            constraints))
+        'ignored))
+    (define (connect new-constraint)
+      (if (not (memq new-constraint constraints))
+        (set!
+          constraints
+          (cons new-constraint constraints)))
+      (if (has-value? me)
+        (inform-about-value new-constraint))
+      'done)
+    (define (me request)
+      (cond
+        ((eq? request 'has-value?)
+         (if informant true false))
+        ((eq? request 'value) value)
+        ((eq? request 'set-value) set-my-value)
+        ((eq? request 'forget) forget-my-value)
+        ((eq? request 'connect) connect)
+        (else
+          (error
+            "Unknown operation -- CONNECTOR"
+            request))))
+    me))
+
+
+(#%provide adder)
+(define (adder a1 a2 sum)
+  (define (process-new-value)
+    (cond
+      ((and (has-value? a1) (has-value? a2))
+       (set-value!
+         sum
+         (+ (get-value a1) (get-value a2))
+         me))
+      ((and (has-value? a1) (has-value? sum))
+       (set-value!
+         a2
+         (- (get-value sum) (get-value a1))
+         me))
+      ((and (has-value? a2) (has-value? sum))
+       (set-value!
+         a1
+         (- (get-value sum) (get-value a2))
+         me))))
+  (define (process-forget-value)
+    (forget-value! sum me)
+    (forget-value! a1 me)
+    (forget-value! a2 me)
+    (process-new-value))
+  (define (me request)
+    (cond
+      ((eq? request 'I-have-a-value)
+       (process-new-value))
+      ((eq? request 'I-lost-my-value)
+       (process-forget-value))
+      (else
+        (error "Unknown request -- ADDER" request))))
+  (connect a1 me)
+  (connect a2 me)
+  (connect sum me)
+  me)
+
+(#%provide multiplier)
+(define (multiplier m1 m2 product)
+  (define (process-new-value)
+    (cond
+      ((or
+         (and (has-value? m1) (= (get-value m1) 0))
+         (and (has-value? m2) (= (get-value m2) 0)))
+       (set-value! product 0 me))
+      ((and (has-value? m1) (has-value? m2))
+       (set-value!
+         product
+         (* (get-value m1) (get-value m2))
+         me))
+      ((and (has-value? m1) (has-value? product))
+       (set-value!
+         m2
+         (/ (get-value product) (get-value m1))
+         me))
+      ((and (has-value? m2) (has-value? product))
+       (set-value!
+         m1
+         (/ (get-value product) (get-value m2))
+         me))))
+  (define (process-forget-value)
+    (forget-value! product me)
+    (forget-value! m1 me)
+    (forget-value! m2 me)
+    (process-new-value))
+  (define (me request)
+    (cond
+      ((eq? request 'I-have-a-value)
+       (process-new-value))
+      ((eq? request 'I-lost-my-value)
+       (process-forget-value))
+      (else
+        (error "Unknown request -- MULTIPLIER" request))))
+  (connect m1 me)
+  (connect m2 me)
+  (connect product me)
+  me)
+
+(#%provide constant)
+(define (constant value connector)
+  (define (me request)
+    (error "Unknown request -- CONSTANT" request))
+  (connect connector me)
+  (set-value! connector value me)
+  me)
+
+(#%provide probe)
+(define (probe name connector)
+  (define (print-probe value)
+    (display "Probe: ")
+    (display name)
+    (display " = ")
+    (display value)
+    (newline))
+  (define (process-new-value)
+    (print-probe (get-value connector)))
+  (define (process-forget-value)
+    (print-probe "?"))
+  (define (me request)
+    (cond
+      ((eq? request 'I-have-a-value)
+       (process-new-value))
+      ((eq? request 'I-lost-my-value)
+       (process-forget-value))
+      (else
+        (error "Unknown request -- PROBE" request))))
+  (connect connector me)
+  me)
+
+(#%provide celsius-fahrenheit-converter)
+(define (celsius-fahrenheit-converter c f)
+  (let
+    ((u (make-connector))
+     (v (make-connector))
+     (w (make-connector))
+     (x (make-connector))
+     (y (make-connector)))
+    (multiplier c w u)
+    (multiplier v x u)
+    (adder v y f)
+    (constant 9 w)
+    (constant 5 x)
+    (constant 32 y)
+    'ok))
+
+#| 3.33 |#
+
+(#%provide averager)
+(define (averager a b c)
+  (let
+    ((sum (make-connector))
+     (n (make-connector)))
+    (adder a b sum)
+    (multiplier n c sum)
+    (constant 2 n)
+    'ok))
+
+#| 3.34 |#
+
+(#%provide squarer-bad)
+(define (squarer-bad a b)
+  (multiplier a a b))
+
+;; a can't be determined from b
+
+#| 3.35 |#
+
+(#%provide squarer)
+(define (squarer a b)
+  (define (process-new-value)
+    (if (has-value? b)
+      (if (< (get-value b) 0)
+        (error
+          "square less than 0 -- SQUARER"
+          (get-value b))
+        (set-value! a (sqrt (get-value b)) me))
+      (if (has-value? a)
+        (set-value! b (* (get-value a) (get-value a)) me))))
+  (define (process-forget-value)
+    (forget-value! a me)
+    (forget-value! b me)
+    (process-new-value))
+  (define (me request)
+    (cond
+      ((eq? request 'I-have-a-value)
+       (process-new-value))
+      ((eq? request 'I-lost-my-value)
+       (process-forget-value))
+      (else
+        (error "Unknown request -- SQUARER" request))))
+  (connect a me)
+  (connect b me)
+  me)
+
+#| 3.37 |#
+
+(#%provide c+)
+(define (c+ x y)
+  (let ((z (make-connector)))
+    (adder x y z)
+    z))
+
+(#%provide c-)
+(define (c- x y)
+  (let ((z (make-connector)))
+    (adder z y x)
+    z))
+
+(#%provide c*)
+(define (c* x y)
+  (let ((z (make-connector)))
+    (multiplier x y z)
+    z))
+
+(#%provide c/)
+(define (c/ x y)
+  (let ((z (make-connector)))
+    (multiplier z y x)
+    z))
+
+(#%provide cv)
+(define (cv v)
+  (let ((z (make-connector)))
+    (constant v z)
+    z))
+
+(#%provide celsius-fahrenheit-converter-exp)
+(define (celsius-fahrenheit-converter-exp x)
+  (c+
+    (c* (c/ (cv 9) (cv 5)) x)
+    (cv 32)))