SICP 3.3.5
3.33
avalagerは以下の2パターンが考えられる
;avalager
(define (avalager a b c)
(let ((u (make-connector))
(v (make-connector)))
(adder a b u)
(multiplier u v c)
(constant 0.5 v)
'ok))
;avalager
(define (avalager a b c)
(let ((u (make-connector))
(v (make-connector)))
(adder a b u)
(multiplier c v u)
(constant 2 v)
'ok))
動作確認
#lang racket
;helper
(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 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 "Contradiction" (list value newval)))
(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))
'ignore)
(if (has-value? me)
(inform-about-value new-constraint)
'ignore)
'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 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))
;avalager
(define (avalager a b c)
(let ((u (make-connector))
(v (make-connector)))
(adder a b u)
(multiplier u v c)
(constant 0.5 v)
'ok))
;test
(define (test-avg x y)
(let ((a (make-connector))
(b (make-connector))
(c (make-connector)))
(probe "avalage" c)
(avalager a b c)
(constant x a)
(constant y b)
'ok))
(test-avg 2 3)
3.34
乗算器としては問題ないが、以下のようなコードで平方根がとれない。
;test (define x (make-connector)) (define y (make-connector)) (probe "x" x) (probe "y" y) (squarer x y) (constant 4 y)
結果
#<procedure:me> #<procedure:me> #<procedure:me> Probe: y = 4 #<procedure:me>
(multiplier m1 m2 product) は m1=m2 であることを知らないので、 productしか確定していない状態と解釈してしまう。
3.35
;helper
(define (square x) (* x x))
;squarer
(define (squarer a b)
(define (process-new-value)
(if (has-value? b)
(if (< (get-value b) 0)
(error "square less than 0 -- SQUARER" (get-value b))
(set-value! a (sqrt (get-value b)) me))
(if (has-value? a)
(set-value! b (square (get-value a) me))
'ignore)))
(define (process-forget-value)
(forget-value! a me)
(forget-value! b me))
(define (me request)
(cond ((eq? request 'I-have-a-value)
(process-new-value))
((eq? request 'I-lost-my-value)
(process-forget-value))
(else
(error "Unkown request" request))))
(connect a me)
(connect b me)
me)
;test
(define x (make-connector))
(define y (make-connector))
(probe "x" x)
(probe "y" y)
(squarer x y)
(constant 4 y)
3.37
(define (c+ x y)
(let ((z (make-connector)))
(adder x y z)
z))
(define (c- x y)
(let ((z (make-connector)))
(adder y z x)
z))
(define (c* x y)
(let ((z (make-connector)))
(multiplier x y z)
z))
(define (c/ x y)
(let ((z (make-connector)))
(multiplier y z x)
z))
(define (cv x)
(let ((z (make-connector))
