計算機プログラムの構造と解釈 第二版 P174 問題3.33

平均を制約を使って解く問題。(日本語正しいか不安。)

数式にすると平均はこうなる。

(a + b) / 2 = c

だので

a + b = 2 * c

と、ということで、P169の図3.28っぽい絵を妄想してみる。
ここまでくると余裕。
あとは、p169のcelsius-fahrenheit-converterを参考にして書いてみるだけだ。

constraint.scm(書いてあったのを写経)

(define nil '())
(define disp display)
(define nl newline)

;;加算器
(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 (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? 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)
    (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)



;;コネクタを作る
(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))


;;コネクタが値を持つかどうか？
(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))

次にこの問題の答えの部分
3-33.scm

#!/usr/local/bin/gosh
;; -*- coding: utf-8 -*-

(use ggc.debug.trace)
(use math.mt-random)

(load "./constraints.scm")

;;;
; 実行
;;;
(define (averager a b c)
  (let ((x (make-connector))
        (y (make-connector)))
    (adder a b x)
    (multiplier c y x)
    (constant 2 y)
    'ok))

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

(averager a b c)

(probe "input1" a)
(probe "input2" b)
(probe "Average" c)


;; main
(define (main args)

  (print "(set-value! a 5 'user)")
  (set-value! a 5 'user)
  (newline)
  (newline)


  (print "(set-value! b 15 'user)")
  (set-value! b 15 'user)
  (newline)
  (newline)


  (print "(forget-value! b 'user)")
  (forget-value! b 'user)
  (newline)
  (newline)


  (print "(set-value! c 15 'user)")
  (set-value! c 15 'user)
  (newline)
  (newline)


  (print "(forget-value! a 'user)")
  (forget-value! a 'user)
  (newline)
  (newline)

  (print "(set-value! b 8 'user)")
  (set-value! b 8 'user)
  (newline)
  (newline)

  0)

んで出力

(set-value! a 5 'user)

Probe: input1 = 5

(set-value! b 15 'user)

Probe: input2 = 15
Probe: Average = 10

(forget-value! b 'user)

Probe: input2 = ?
Probe: Average = ?

(set-value! c 15 'user)

Probe: Average = 15
Probe: input2 = 25

(forget-value! a 'user)

Probe: input1 = ?
Probe: input2 = ?

(set-value! b 8 'user)

Probe: input2 = 8
Probe: input1 = 22

できていると思う。