SICP 3.3.5 制約の拡散の例題 (摂氏・華氏変換器) をSHIMADAさんが Rubyで書いている。
元のSchemeプログラムはメッセージディスパッチを明示的に書いていることもあって、 かなり見にくい。Ruby版はシンプルになっている。
本来、メッセージディスパッチなんて機械的な部分を人間が書くのは まさに「人間コンパイラ」の動作例であって、良いことではない。 (SICPは教科書だし、段階があるから仕方ないけど)。 もっとすっきり書く方法はないだろうか。
SLIBにはYASOS (yet another scheme object systemだっけ) という 簡単なオブジェクトシステムが付いて来る。 原理的には、クロージャを基本にしたメソッドディスパッチシステムを マクロで隠蔽しているだけなんだが、この例のような シングルメソッドディスパッチでかつメソッドが少ない場合は わりとすっきり書ける。
ちなみに下のコードはクラスレス。戯さんの好きな(?) プロトタイプベース オブジェクトシステムになっている。インヘリタンスを使ってないから それとはわからないけど。
書いてて気になった点：
(use slib)
(require 'oop)
;; slibは非互換なprintを上書きするので、改めてgaucheのprintを再定義
(define print (with-module gauche print))
;; Constraints
(define-operation (inform-about-value me))
(define-operation (inform-about-no-value me))
(define (adder a1 a2 sum)
(define me
(object
((inform-about-value me)
(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))))
((inform-about-no-value me)
(forget-value! sum me)
(forget-value! a1 me)
(forget-value! a2 me)
(inform-about-value me))
))
(connect a1 me)
(connect a2 me)
(connect sum me)
me)
(define (multiplier m1 m2 product)
(define me
(object
((inform-about-value me)
(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)))
)
((inform-about-no-value me)
(forget-value! product me)
(forget-value! m1 me)
(forget-value! m2 me)
(inform-about-value me))))
(connect m1 me)
(connect m2 me)
(connect product me)
me)
(define (constant value connector)
(define me (object
((inform-about-value me)
(error "can't change constant constraint"))
((inform-about-no-value me)
(error "can't forget constant constraint"))))
(connect connector me)
(set-value! connector value me)
me)
(define (probe name connector)
(define (print-probe value)
(print #`"Probe: ,name = ,value"))
(define me (object
((inform-about-value me)
(print-probe (get-value connector)))
((inform-about-no-value me)
(print-probe "?"))))
(connect connector me)
me)
;; Connector
(define-operation (has-value? me))
(define-operation (get-value me))
(define-operation (set-value! me newval setter))
(define-operation (forget-value! me retractor))
(define-operation (connect me new-constraint))
(define (make-connector)
(let ((value #f)
(informant #f)
(constraints '()))
(object
((has-value? me) (if informant #t #f))
((get-value me) value)
((set-value! me 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)))
((forget-value! me retractor)
(if (eq? retractor informant)
(begin (set! informant #f)
(for-each-except retractor inform-about-no-value constraints))
'ignored))
((connect me new-constraint)
(unless (memq new-constraint constraints)
(push! constraints new-constraint))
(when (has-value? me) (inform-about-value new-constraint))
'done)
)
))
(define (for-each-except exception proc lis)
(for-each (lambda (elt) (unless (eq? elt exception) (proc elt))) lis))
;; Constraint system
(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))
;; Test
(define-syntax test
(syntax-rules ()
((_ expr)
(with-error-handler
(lambda (e) (print #`"*** ERROR: ,(ref e 'message)"))
(lambda () (format #t "> ~s\n" 'expr) expr)))))
(define (main args)
(define C (make-connector))
(define F (make-connector))
(celsius-fahrenheit-converter C F)
(probe "Celsius temp" C)
(probe "Fahrenheit temp" F)
(test (set-value! C 25 'user))
(test (set-value! F 212 'user))
(test (forget-value! C 'user))
(test (set-value! F 212 'user))
0)
CLOS風な、Gaucheのオブジェクトシステムで書いてみる。 Tiny CLOSでもたぶん似たようなものだと思う。
書いてみて思ったこと：
;; Constraint "adder"
(define-class <adder> ()
((a1 :init-keyword :a1 :accessor a1-of)
(a2 :init-keyword :a2 :accessor a2-of)
(sum :init-keyword :sum :accessor sum-of)
))
(define-method inform-about-value ((me <adder>))
(let ((a1 (a1-of me))
(a2 (a2-of me))
(sum (sum-of me)))
(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-method inform-about-no-value ((me <adder>))
(forget-value! (sum-of me) me)
(forget-value! (a1-of me) me)
(forget-value! (a2-of me) me)
(inform-about-value me))
(define (adder a1 a2 sum)
(let ((me (make <adder> :a1 a1 :a2 a2 :sum sum)))
(connect a1 me)
(connect a2 me)
(connect sum me)
me))
;; Constraint "multiplier"
(define-class <multiplier> ()
((m1 :init-keyword :m1 :accessor m1-of)
(m2 :init-keyword :m2 :accessor m2-of)
(product :init-keyword :product :accessor product-of)
))
(define-method inform-about-value ((me <multiplier>))
(let ((m1 (m1-of me))
(m2 (m2-of me))
(product (product-of me)))
(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-method inform-about-no-value ((me <multiplier>))
(forget-value! (product-of me) me)
(forget-value! (m1-of me) me)
(forget-value! (m2-of me) me)
(inform-about-value me))
(define (multiplier m1 m2 product)
(let ((me (make <multiplier> :m1 m1 :m2 m2 :product product)))
(connect m1 me)
(connect m2 me)
(connect product me)
me))
;; Constraint "constant"
(define-class <constant> ()
())
(define (constant value connector)
(let ((me (make <constant>)))
(connect connector me)
(set-value! connector value me)
me))
;; Constraint "probe"
(define-class <probe> ()
((name :init-keyword :name :accessor name-of)
(connector :init-keyword :connector :accessor connector-of)
))
(define (probe name connector)
(let ((me (make <probe> :name name :connector connector)))
(connect connector me)
me))
(define-method print-probe ((me <probe>) value)
(print #`"Probe: ,(name-of me) = ,value"))
(define-method inform-about-value ((me <probe>))
(print-probe me (get-value (connector-of me))))
(define-method inform-about-no-value ((me <probe>))
(print-probe me "?"))
;; Connector
(define-class <connector> ()
((value :init-value #f :accessor value-of)
(informant :init-value #f :accessor informant-of)
(constraints :init-value '() :accessor constraints-of)
))
(define (make-connector)
(make <connector>))
(define-method has-value? ((me <connector>))
(if (informant-of me) #t #f))
(define-method get-value ((me <connector>))
(value-of me))
(define-method set-value! ((me <connector>) newval setter)
(cond ((not (has-value? me))
(set! (value-of me) newval)
(set! (informant-of me) setter)
(for-each-except setter inform-about-value (constraints-of me)))
((not (= (value-of me) newval))
(error "Contradiction" (list (value-of me) newval)))
(else 'ignored)))
(define-method forget-value! ((me <connector>) retractor)
(if (eq? retractor (informant-of me))
(begin (set! (informant-of me) #f)
(for-each-except retractor inform-about-no-value
(constraints-of me)))
'ignored))
(define-method connect ((me <connector>) new-constraint)
(unless (memq new-constraint (constraints-of me))
(push! (constraints-of me) new-constraint))
(when (has-value? me) (inform-about-value new-constraint))
'done)
(define (for-each-except exception proc lis)
(for-each (lambda (elt) (unless (eq? elt exception) (proc elt))) lis))
;; Constraint system
(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))
;; Test
(define-syntax test
(syntax-rules ()
((_ expr)
(with-error-handler
(lambda (e) (print #`"*** ERROR: ,(ref e 'message)"))
(lambda () (format #t "> ~s\n" 'expr) expr)))))
(define (main args)
(define C (make-connector))
(define F (make-connector))
(celsius-fahrenheit-converter C F)
(probe "Celsius temp" C)
(probe "Fahrenheit temp" F)
(test (set-value! C 25 'user))
(test (set-value! F 212 'user))
(test (forget-value! C 'user))
(test (set-value! F 212 'user))
0)
さて、SICPのプログラムや上のプログラムでは、各制約の中に、
の両方を書かなければならなず、冗長になっている。 特にadderとmultiplierのメソッド群は要注意だ。 こういう、似たようなコードを繰り返し書くというケースは なるべく避けたい。
そこで、共通部分をマクロにしてしまおう。 下のコードは、制約を定義するマクロdefine-constraintを 定義する。
(define-macro (define-constraint name connectors other-slots
enforce-constraint
release-constraint)
`(begin
(define-class ,name ()
(,@(map (lambda (slot)
`(,slot :init-keyword ,(make-keyword slot)
:accessor ,(string->symbol #`",|slot|-of")))
connectors)
,@other-slots))
(define-method initialize ((me ,name) initargs)
(next-method)
,@(map (lambda (slot)
`(connect (ref me ',slot) me))
connectors))
(define-method forget-all! ((me ,name))
,@(map (lambda (slot)
`(forget-value! (ref me ',slot) me))
connectors))
(define-method inform-about-value ((me ,name))
(let ,(map (lambda (slot) `(,slot (ref me ',slot))) connectors)
,enforce-constraint))
(define-method inform-about-no-value ((me ,name))
(let ,(map (lambda (slot) `(,slot (ref me ',slot))) connectors)
,release-constraint))
))
すると、各制約は次のように書ける。制約毎に特有な部分だけを 書ける。新しい制約を追加するのも楽になる。
もし、本格的にこのフレームワークを使った制約プログラミングをするなら、 このようにカスタム化したマクロを一度作れば後はずっと楽になる。
但し、マクロは使い過ぎると理解不能になる。 新しい構文要素を追加するためにマクロを書く、ということは、 言語を拡張してるわけだから、そのマクロが何をするのか、ということが、 言語の組込み要素と同じくらい詳細にドキュメントされていなければ ならないだろう。でないと保守不能なコードを容易に産み出し得る。
;; Constraint "adder"
(define-constraint <adder> (a1 a2 sum)
()
(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)))
(begin
(forget-all! me)
(inform-about-value me)))
(define (adder a1 a2 sum)
(make <adder> :a1 a1 :a2 a2 :sum sum))
;; Constraint "multiplier"
(define-constraint <multiplier> (m1 m2 product)
()
(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)))
(begin
(forget-all! me)
(inform-about-value me)))
(define (multiplier m1 m2 product)
(make <multiplier> :m1 m1 :m2 m2 :product product))
;; Constraint "constant"
(define-constraint <constant> (connector)
()
(error "can't change constant constraint" me)
(error "can't forget constant constraint" me))
(define (constant value connector)
(let ((me (make <constant> :connector connector)))
(set-value! connector value me)
me))
;; Constraint "probe"
(define-constraint <probe> (connector)
((name :init-keyword :name :accessor name-of))
(print #`"Probe: ,(name-of me) = ,(get-value (connector-of me))")
(print #`"Probe: ,(name-of me) = ?"))
(define (probe name connector)
(make <probe> :name name :connector connector))
;; Connector
;; 以下同じ
SHIMADA (2003/06/16 17:22:13 PDT): 上の議論とはちょっとずれてしまうんですが。
個人的には、SICP-3.3.5の白眉はExercise 3.37の"expression-oriented style"
(define (celsius-fahrenheit-converter x)
(c+ (c* (c/ (cv 9) (cv 5))
x)
(cv 32)))
だと思うんですよね。
手元の処理系で実際にc+, c*, c/, cvを定義してちゃんと動いた時は、 中身がわかってるのになにか騙されたような気持ちになりました。:-)
SHIMADA (2003/06/17 20:45:26 PDT): sumimさんがSmalltalk版を書いてます。Ruby版とほぼ同等のコードになっています。
それから、同じSmalltalkによる制約に関する別のアプローチをみつけました。
Proxyとして目立たないように振舞うMediator、といった感じでしょうか。