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