3.3.5约束的传播（代码加注释）

#lang sicp

#|
约束系统有两个对象，约束和连接器。
假定支持以下操作：
has-value:报告连接器是否有值
get-value:得到连接器的值
set-value:设置连接器的值
forget-value:连接器忘记原本的值
connnect:通知连接器参与一个新的约束
inform-about-value:通知各个约束连接器有新值
inform-about-no-value:通知各个约束连接器有新值
|#
(define (adder a1 a2 sum);;构建一个加法约束
  (define (process-my-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-my-value))
  (define (me request);;这里是一种抽象。如果一个东西能完成人支持的任何操作，就认为它是人。这里的me表示加法约束本身
    (cond ((eq? request 'I-have-a-value) (process-my-value))
          ((eq? request 'I-lost-my-value) (process-forget-value))
          (else (error "unknown request" request))))
  (connect a1 me)
  (connect a2 me)
  (connect sum me)
  me);;这里把‘自己’返回，暴露出来可以接受信息（request）
           
(define (inform-about-value constraint);;通知约束连接器有新值
  (constraint 'I-have-a-value))
(define (inform-about-no-value constraint);;通知约束连接器丧失值
  (constraint 'I-lost-my-value))
  
(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" request))))
    (connect m1 me)
    (connect m2 me)
    (connect product me)
    me)

#|
这里构造一个常量约束器
|#
(define (constant value connector);;在初始化常量后，不再接受任何请求
  (define (me request)
    (error "unknown request" ))
    (connect connector me)
  (set-value! connector value me)
  me)

(define (probe name connector);;一个监视器，通过消息传递执行对应过程
  (define (print-probe value)
    (newline)
    (display "probe: ")
    (display name)
    (display " = ")
    (display 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:" request))))
  (connect connector me)
  me)
#|
实现连接器。
连接器要保存有：当前连接器的值value，informant设置连接器值的对象，constraints连接器设计的所有约束的表
实现其支持的操作
|#
(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 "redefined"))
            (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" request))))
    me))

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



;;语法糖，函数式风格包装
(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))








;;测试，实现华氏度与摄氏度的转换
(define (celslius-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))
        
(define c (make-connector))
(define f (make-connector))
(celslius-fahrenheit-converter c f)
(probe "c.temp" c)
(probe "f.temp" f)
(set-value! c 25 'user)
(forget-value! c 'user)
(set-value! f 212 'user)