293 lines
8.0 KiB
Scheme
293 lines
8.0 KiB
Scheme
(load "shared/util.scm")
|
|
|
|
(display "\nexample - propagation of constraints\n")
|
|
|
|
(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)
|
|
|
|
(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)))
|
|
(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 -- 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 (inform-about-value constraint)
|
|
(constraint 'I-have-a-value))
|
|
(define (inform-about-no-value constraint)
|
|
(constraint 'I-lost-my-value))
|
|
|
|
(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))
|
|
|
|
(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 C (make-connector))
|
|
(define F (make-connector))
|
|
(celsius-fahrenheit-converter C F)
|
|
(set-value! C 25 'user)
|
|
(assert (get-value F) 77)
|
|
(forget-value! C 'user)
|
|
(set-value! F 212 'user)
|
|
(assert (get-value C) 100)
|
|
|
|
|
|
(display "\nex-3.33 - averager\n")
|
|
|
|
(define (averager a b c)
|
|
(let ((sum (make-connector))
|
|
(half (make-connector)))
|
|
(constant (/ 1 2) half)
|
|
(adder a b sum)
|
|
(multiplier sum half c)
|
|
'ok))
|
|
|
|
(define A (make-connector))
|
|
(define B (make-connector))
|
|
(define C (make-connector))
|
|
|
|
(averager A B C)
|
|
(set-value! A 20 'user)
|
|
(set-value! B 40 'user)
|
|
(assert (get-value C) 30)
|
|
(forget-value! B 'user)
|
|
(set-value! C 100 'user)
|
|
(assert (get-value B) 180)
|
|
|
|
(display "\nex-3.34 - flawed squarer\n")
|
|
|
|
; The flaw is that getting the root is not going to work, because the
|
|
; multiplier will never calculate two a's from only one b. In other words the
|
|
; squarer only works into one direction.
|
|
|
|
(define A (make-connector))
|
|
(define B (make-connector))
|
|
|
|
(define (squarer a b)
|
|
(multiplier a a b))
|
|
|
|
(squarer A B)
|
|
|
|
(set-value! A 10 'user)
|
|
(assert (get-value B) 100)
|
|
|
|
(display "\nex-3.35 - fixed squarer\n")
|
|
|
|
(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))
|
|
(let ((a-val (get-value a)))
|
|
(set-value! a a-val me))))
|
|
(define (process-forget-value)
|
|
(forget-value! a me)
|
|
(forget-value! b 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 -- SQUARER" request))))
|
|
(connect a me)
|
|
(connect b me)
|
|
me)
|
|
|
|
(define A (make-connector))
|
|
(define B (make-connector))
|
|
|
|
(squarer A B)
|
|
(set-value! B 100 'user)
|
|
(assert (get-value A) 10)
|
|
|
|
(display "\nex-3.36\n")
|
|
(display "[skip]\n")
|
|
|
|
(define a (make-connector))
|
|
(define b (make-connector))
|
|
(set-value! a 10 'user)
|
|
|
|
(display "\nex-3.37 - expression-oriented converter\n")
|
|
|
|
(define (celsius-fahrenheit-converter x)
|
|
(c+ (c* (c/ (cv 9) (cv 5))
|
|
x)
|
|
(cv 32)))
|
|
|
|
(define (c+ x y)
|
|
(let ((z (make-connector)))
|
|
(adder x y z)
|
|
z))
|
|
|
|
(define (c* x y)
|
|
(let ((z (make-connector)))
|
|
(multiplier x y z)
|
|
z))
|
|
|
|
(define (cv v)
|
|
(let ((z (make-connector)))
|
|
(constant v z)
|
|
z))
|
|
|
|
(define (c/ x y)
|
|
(let ((z (make-connector)))
|
|
(multiplier z y x)
|
|
z))
|
|
|
|
(define C (make-connector))
|
|
(define F (celsius-fahrenheit-converter C))
|
|
(set-value! C 25 'user)
|
|
(assert (get-value F) 77)
|
|
|