計算機プログラムの構造と解釈[第2版]
(翔泳社)
ハロルド エイブルソン (著) ジュリー サスマン (著)
ジェラルド・ジェイ サスマン (著)
Harold Abelson (原著) Julie Sussman (原著)
Gerald Jay Sussman (原著) 和田 英一 (翻訳)
開発環境
- OS X Mavericks - Apple(OS)
- Emacs (CUI)、BBEdit - Bare Bones Software, Inc. (GUI) (Text Editor)
- Scheme (プログラミング言語)
- Gauche (処理系)
計算機プログラムの構造と解釈[第2版](ハロルド エイブルソン (著)、ジュリー サスマン (著)、ジェラルド・ジェイ サスマン (著)、Harold Abelson (原著)、Julie Sussman (原著)、Gerald Jay Sussman (原著)、和田 英一 (翻訳)、翔泳社、原書: Structure and Interpretation of Computer Programs (MIT Electrical Engineering and Computer Science)(SICP))の3(標準部品化力、オブジェクトおよび状態)、3.3(可変データでのモデル化)、3.3.5(制約の拡散)、制約システムの使い方、制約システムの実装、コネクタの表現、問題 3.33.を解いてみる。
その他参考書籍
- Instructor's Manual to Accompany Structure & Interpretation of Computer Programs
- プログラミングGauche (Kahuaプロジェクト (著), 川合 史朗 (監修), オライリージャパン)
問題 3.33.
コード(BBEdit, Emacs)
constraint_system.scm
;; -*- coding: utf-8 -*-
(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-value!) retractor))
(define (connect connector new-constraint)
((connector 'connect) new-constraint))
(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)
(print "Probe: " name " = " 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 (average a b c)
(define (process-new-value)
(cond ((and (has-value? a) (has-value? b))
(set-value c
(/ (+ (get-value a) (get-value b)) 2)
me))
((and (has-value? a) (has-value? c))
(set-value b
(- (* 2 (get-value c)) a)
me))
((and (has-value? b) (has-value? c))
(set-value a
(- (* 2 (get-value c)) b)
me))))
(define (process-forget-value)
(forget-value! c)
(forget-value! a)
(forget-value! b)
(process-new-value))
(define (me request)
(cond ((eq? request 'I-have-a-value)
(process-new-value))
((eq? request 'I-LOST-MY-VALUE)
(process-new-value))
(else
(error "Unknown request -- AVERAGE" request))))
(connect a me)
(connect b me)
(connect c me)
me)
sample3_33.scm
#!/usr/bin/env gosh
;; -*- coding: utf-8 -*-
(load "./constraint_system.scm")
(define a (make-connector))
(define b (make-connector))
(define c (make-connector))
(probe 'a a)
(probe 'b b)
(probe 'c c)
(average a b c)
(for-each (lambda (connector)
(print a "has-value?: " (has-value? connector)))
(list a b c))
(for-each (lambda (connector)
(print a "get-value: " (get-value connector)))
(list a b c))
(set-value! a 5 'user1)
(set-value! b 10 'user2)
(print '(forget-value! a 'user3))
(print (forget-value! a 'user3))
(print '(forget-value! a 'user1))
(print (forget-value! a 'user1))
(print '(set-value! c 15/2 'user4))
(print (set-value! c 15/2 'user4))
入出力結果(Terminal(gosh), REPL(Read, Eval, Print, Loop))
$ ./sample3_33.scm #<closure (make-connector me)>has-value?: #f #<closure (make-connector me)>has-value?: #f #<closure (make-connector me)>has-value?: #f #<closure (make-connector me)>get-value: #f #<closure (make-connector me)>get-value: #f #<closure (make-connector me)>get-value: #f Probe: a = 5 Probe: c = 15/2 Probe: b = 10 (forget-value! a 'user3) ignored (forget-value! a 'user1) Probe: c = ? Probe: a = ? done (set-value! c 15/2 'user4) Probe: a = 5 Probe: c = 15/2 done $
0 コメント:
コメントを投稿