sicp-3-3-5-propagation-of-constraints

#lang racket
(require racket/mpair)

;;;;;;;;;;;;;;;;
;; CONNECTORS ;;
;;;;;;;;;;;;;;;;

(define (make-connector)
  (define value false)
  (define informant false)
  (define constraints empty)
  (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)
    (cond [(eq? retractor informant)
           (set! informant false)
           (for-each-except retractor
                            inform-about-no-value
                            constraints)]
          [else 'ignored]))
  (define (connect new-constraint)
    (when (not (memq new-constraint constraints))
      (set! constraints (cons new-constraint constraints)))
    (when (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)

(define (for-each-except exception procedure lst)
  (map procedure (remove exception lst))
  'done)

(define (has-value? connector) (connector 'has-value?))
(define (get-value connector) (connector 'value))
(define (set-value! connector new-value informant)
  ((connector 'set-value!) new-value informant))
(define (forget-value! connector retractor)
  ((connector 'forget) retractor))
(define (connect connector new-constraint)
  ((connector 'connect) new-constraint))

;;;;;;;;;;;;;;;;;
;; CONSTRAINTS ;;
;;;;;;;;;;;;;;;;;

(define (inform-about-value constraint)
  (constraint 'I-have-a-value))
(define (inform-about-no-value constraint)
  (constraint 'I-lost-my-value))

(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)

(define (multiplier m1 m2 product)
  (define (process-new-value)
    (cond [(or (and (has-value? m1) (zero? (get-value m1)))
               (and (has-value? m2) (zero? (get-value m2))))
           (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? product) (has-value? m1))
           (set-value! m2
                       (/ (get-value product) (get-value m1))
                       me)]
          [(and (has-value? product) (has-value? m2))
           (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)

(define (constant value connector)
  (define (me request)
    (error "Unknown request -- CONSTANT" request))
  (connect connector me)
  (set-value! connector value me)
  me)

(define (probe name connector)
  (define (print-probe value)
    (printf "Probe: ~a = ~a ~n" name value))
  (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)

;;;;;;;;;;
;; 3.33 ;;
;;;;;;;;;;

(define (averager a b c)
  (define s (make-connector))
  (define t (make-connector))
  (adder a b s)
  (multiplier t c s)
  (constant 2 t)
  'ok)

;; TEST

(define A (make-connector))
(define B (make-connector))
(define C (make-connector))
(averager A B C)
;; 'ok
(probe "A" A)
;; #<procedure:me>
(probe "B" B)
;; #<procedure:me>
(probe "C" C)
;; #<procedure:me>

(set-value! A 3 'user)
;; Probe: A = 3
;; 'done
(set-value! B 5 'user)
;; Probe: B = 5
;; Probe: C = 4
;; 'done
(forget-value! B 'user)
;; Probe: B = ?
;; Probe: C = ?
;; 'done
(set-value! C 5 'user)
;; Probe: C = 5
;; Probe: B = 7
;; 'done

;;;;;;;;;;
;; 3.34 ;;
;;;;;;;;;;

(define (bad-squarer a b)
  (multiplier a a b)
  'ok)

;; TEST

(define E (make-connector))
(define F (make-connector))
(bad-squarer E F)
;; 'ok
(probe "E" E)
;; #<procedure:me>
(probe "F" F)
;; #<procedure:me>
(set-value! E 3 'user)
;; Probe: E = 3
;; Probe: F = 9
;; 'done
(forget-value! E 'user)
;; Probe: E = ?
;; Probe: F = ?
;; 'done
(set-value! F 25 'user)
;; Probe: F = 25
;; 'done

;; Clearing the value for a also clears the value for b.  If, after that, you set
;; the value for b, multiplier has no way to propagate the value back to a.
;; Multiplier expects to have two of three values in order to propagate to the
;; third, but here it has only one.  So no propagation occurs.

;;;;;;;;;;
;; 3.35 ;;
;;;;;;;;;;

(define (squarer a b)
  (define (process-new-value)
    (cond [(has-value? b)
           (if (negative? (get-value b))
             (error "Square negative -- SQUARER" (get-value b))
             (set-value! a (sqrt (get-value b)) me))]
          [(has-value? a)
           (set-value! b (sqr (get-value a)) me)]))
  (define (process-forget-value)
    (forget-value! b me)
    (forget-value! a 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)

;; TEST

(define G (make-connector))
(define H (make-connector))
(squarer G H)
;; #<procedure:me>
(probe "G" G)
;; #<procedure:me>
(probe "H" H)
;; #<procedure:me>
(set-value! G 3 'user)
;; Probe: G = 3
;; Probe: H = 9
;; 'done
(forget-value! G 'user)
;; Probe: G = ?
;; Probe: H = ?
;; 'done
(set-value! H 25 'user)
;; Probe: H = 25
;; Probe: G = 5
;; 'done

;; Here the constraint does give the square root as expected.

;;;;;;;;;;
;; 3.36 ;;
;;;;;;;;;;

;; Discuss the environments created by:

;; (define a (make-connector))
;; (set-value! a 10 'user)

;; make-connector is defined in the global environment.  So calling it creates a
;; binding frame E1 below the global environment.  It has no formal parameters to
;; bind, but it does create local definitions in E1, including set-my-value.

;; set-value! is defined in the global environment.  Calling it on a, 10, and
;; 'user creates a binding frame E2, below the global environment, where connector
;; is bound to a (which is the me function in E1), new-value is bound to 10, and
;; informant is bound to 'user.  Then the body of set-value! is evaluated in E2.

;; Evaluating the body of set-value! in E2 first calls connector a on 'set-value to
;; get the set-my-value function from E1, and then applies set-my-value to 10 and
;; 'user.

;; Calling set-my-value creates a new binding frame E3 below E1, where newval is
;; bound to 10 and setter is bound to 'user.  Then its body is evaluated in E3,
;; and, as part of that, the for-each-except function is called.

;; Calling for-each-except creates a new binding frame E4, below its enclosing
;; environment, which is the global environment.  Here in E4, the formal
;; parameters exception, procedure, and lst are bound to the setter,
;; inform-about-value, and constraints passed from E3.  Then the body of
;; for-each-except is run in E4, but this means calling inform-about-value on all
;; the constraints involving a.  Since the enclosing environment for
;; inform-about-value is E1, all these evaluations take place in binding frames
;; below E1 and thus have access to all a's local state.

;;;;;;;;;;
;; 3.37 ;;
;;;;;;;;;;

(define (c+ x y)
  (define z (make-connector))
  (adder x y z)
  z)
(define (c* x y)
  (define z (make-connector))
  (multiplier x y z)
  z)
(define (c/ x y)
  (define z (make-connector))
  (multiplier y z x)
  z)
(define (cv value)
  (define z (make-connector))
  (constant value z)
  z)

(define (celsius-fahrenheit-converter x)
  (c+ (c* (c/ (cv 9) (cv 5))
          x)
      (cv 32)))

;; TEST

(define C1 (make-connector))
(define F1 (celsius-fahrenheit-converter C1))
(probe "C1" C1)
;; #<procedure:me>
(probe "F1" F1)
;; #<procedure:me>
(set-value! C1 25 'user)
;; Probe: C1 = 25
;; Probe: F1 = 77
;; 'done
(forget-value! C1 'user)
;; Probe: C1 = ?
;; Probe: F1 = ?
;; 'done
(set-value! F1 212 'user)
;; Probe: F1 = 212
;; Probe: C1 = 100
;; 'done