约束的传播

;连接器的表示
;user不需要也不能添加进constraints表里面,并且只有实现connect过的constraint才能进行set-value!
(define (make-connector)
  (let ((value false) (informant false) (constraints '()))
    (define (set-my-value! new-value setter)
      (cond ((not (has-value? me)) (set! value new-value) (set! informant setter) (foreach-except setter inform-about-value constraints))
            ((not (= value new-value)) (error "set-value!: contradiction" (list value new-value)))))
    (define (forget-my-value! retractor)
      (cond ((eq? informant retractor) (set! informant false) (foreach-except retractor inform-about-no-value constraints))
            (else '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 'get-value) value)
            ((eq? request 'set-value!) set-my-value!)
            ((eq? request 'forget-value!) forget-my-value!)
            ((eq? request 'connect) connect)
            (else (error "make-connector: wrong request" request))))
    me))
(define (has-value? connector)
  (connector 'has-value?))
(define (get-value connector)
  (connector 'get-value))
(define (set-value! connector new-value informant)
  ((connector 'set-value!) new-value informant))
(define (forget-value! connector retractor)
  ((connector 'forget-value!) retractor))
(define (connect connector new-constraint)
  ((connector 'connect) new-constraint))
(define (foreach-except exception proc list)
  (cond ((null? list) 'done)
        ((eq? exception (car list))
         (foreach-except exception proc (cdr list)))
        (else (proc (car list))
              (foreach-except exception proc (cdr list)))))
(define (memq? item list)
  (cond ((null? list) false)
        ((eq? item (car list)) true)
        (else (memq? item (cdr list)))))
;约束系统的实现
(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! a1 me)
    (forget-value! a2 me)
    (forget-value! sum me)
    (process-new-value))
  (define (me request)
    (cond ((eq? request 'I-have-a-value) (process-new-value))
          ((eq? request 'I-have-no-value) (process-forget-value))
          (else (error "adder: wrong operation type--" request))))
  (connect a1 me)
  (connect a2 me)
  (connect sum me)
  me)
(define (multiplier a1 a2 product)
  (define (process-new-value)
    (cond ((or (and (has-value? a1) (= (get-value a1) 0)) (and (has-value? a2) (= (get-value a2) 0)))
           (set-value! product 0 me))
          ((and (has-value? a1) (has-value? a2))
              (set-value! product (* (get-value a1) (get-value a2)) me))
          ((and (has-value? a1) (has-value? product))
           (set-value! a2 (/ (get-value product) (get-value a1)) me))
          ((and (has-value? a2) (has-value? product))
           (set-value! a1 (/ (get-value product) (get-value a2)) me))))
  (define (process-forget-value)
    (forget-value! a1 me)
    (forget-value! a2 me)
    (forget-value! product me)
    (process-new-value))
  (define (me request)
    (cond ((eq? request 'I-have-a-value) (process-new-value))
          ((eq? request 'I-have-no-value) (process-forget-value))
          (else
           (error "multiplier: wrong operation type--" request))))
  (connect a1 me)
  (connect a2 me)
  (connect product me)
  me)
(define (constant num connector)
  (define (me request)
    (error "constant: wrong-operation-type--" request))
  (connect connector me)
  (set-value! connector num me)
  me)
(define (probe name connector)
  (define (me request)
    (cond ((eq? request 'I-have-a-value)
           (newline)
           (display "probe: ")
           (display name)
           (display " = ")
           (display (get-value connector)))
          ((eq? request 'I-have-no-value)
           (newline)
           (display "probe: ")
           (display name)
           (display " = ")
           (display "?"))
          (else
           (error "probe: wrong operation type--" request))))
  (connect connector me)
  me)
(define (inform-about-value constraint)
  (constraint 'I-have-a-value))
(define (inform-about-no-value constraint)
  (constraint 'I-have-no-value))
;约束系统的使用
(define (celsius-fahrenheit-converter c f)
  (let ((w (make-connector))
        (u (make-connector))
        (v (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))
(define c (make-connector))
(define f (make-connector))
(celsius-fahrenheit-converter c f)
(probe "Celsius temp" c)
(probe "Fahrenheit temp" f)
(set-value! c 25 'user)
(set-value! f 212 'user)
(forget-value! c 'user)
(set-value! f 212 'user)
;3.33
(define (averager a b c)
  (let ((d (make-connector))
        (e (make-connector)))
    (adder a b d)
    (multiplier c e d)
    (constant 2 e)))
(define a (make-connector))
(define b (make-connector))
(define c (make-connector))
(probe 'a a)
(probe 'b b)
(probe 'c c)
(averager a b c)
(set-value! a 2 'user)
(set-value! b 4 'user)
(forget-value! a 'user)
(set-value! c 10 'user)
;3.34
(define (cv num)
  (let ((a (make-connector)))
    (constant num a)
    a))
(define (c+ a1 a2)
  (let ((sum (make-connector)))
    (adder a1 a2 sum)
    sum))
(define (c* m1 m2)
  (let ((product (make-connector)))
    (multiplier m1 m2 product)
    product))
(define (c- a b)
  (let ((c (make-connector)))
    (adder c b a)
    c))
(define (c/ a b)
  (let ((c (make-connector)))
    (multiplier c b a)
    c))
(define (celsius-fahrenheit-converter-2 c)
  (c+ (cv 32) (c* c (c/ (cv 9) (cv 5)))))
(define c (make-connector))
(probe 'c c)
(define f (celsius-fahrenheit-converter-2 c))
(probe 'f f)
(set-value! c 25 'user)
(forget-value! c 'user)