src/sicp/ex3_35.rkt

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