SICP問題3.33

基本乗算, 加算, および定数の制約を使い、入力として三つのコネクタa, b, cをとり、cの値がaとbの平均であるような制約を達成する手続きaveragerを定義する。
averagerのネットワークで表した関係 c = 0.5 * (x + y)は以下のようになる。

    ┌────┐ 
a ─┤a1      │x ┌────┐
    │    +  s├─┤m1      │
b ─┤a2      │  │    *  p├─ c
    └────┘┌┤m2      │
               y│└────┘
        ┌──┐│
        │0.5 ├┘
        └──┘

よってaveragerの定義は以下のとおり。

(define (averager a b c)
  (let ((x (make-connector))
        (y (make-connector)))
    (adder a b x)
    (multiplier x y c)
    (constant 0.5 y))
  'ok)

テスト

(define a (make-connector))
; a
(define b (make-connector))
; b
(define c (make-connector))
; c

(probe "a" a)
; <closure (probe me)>
(probe "b" b)
; <closure (probe me)>
(probe "c" c)
; <closure (probe me)>

(averager a b c)
; ok

(set-value! a 20 'user)
; Probe: a = 20done
(set-value! b 10 'user)
; Probe: c = 15.0
; Probe: b = 10done

ok

以下は実行するために必要な教科書で定義された手続き。

; 構文インタフェース
; コネクタに新しい制約に関わるように告げる
(define (inform-about-value constraint)
  (constraint 'I-have-a-value))
; コネクタが値を持たないことを制約に告げる
(define (inform-about-no-value constraint)
  (constraint 'I-lost-my-value))

; probe
(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 -- PROBE" request))))
  (connect connector me)
  me)

; コネクタの基本演算
; (has-value? <connector>)
; コネクタが値を持つかどうかを告げる
; (get-value? <connector>)
; コネクタの現在の値を返す
; (set-value! <connector> <new-value> <informant>)
; 通知者はコネクタに新しい値を設定するように要求していることを示す
; (forget-value! <connector> <retractor>)
; 撤回者がその値を忘れるように要求していることをコネクタに告げる
; (connect <connector> <new-constraint>)

(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 (make-connector)
  (let ((value #f) (informant #f) (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 "Contradiction" (list value newval)))
            (else 'ignored)))
    (define (forget-my-value retractor)
      (if (eq? retractor informant)
          (begin (set! informant #f)
                 (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 #t #f))
          ((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 list)
  (define (loop items)
    (cond ((null? items) 'done)
          ((eq? (car items) exception) (loop (cdr items)))
          (else (procedure (car items))
                (loop (cdr items)))))
  (loop list))

; a1 と a2 の被加算コネクタと sum コネクタの間に加算制約を構成する adder
; 局所状態meを持つ
(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) (= (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? 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)

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

; コネクタの動作
; セ氏とカ氏の制約
(define (celsius-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))