2015年11月22日日曜日

開発環境

  • OS X El Capitan - Apple (OS)
  • Emacs(Text Editor)
  • Scheme (プログラミング言語)
  • kscheme (github) (処理系)

計算機プログラムの構造と解釈[第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.34.を解いてみる。

その他参考書籍

問題3.34.

コード(Emacs)

(begin
  (define print (lambda (x) (display x) (newline)))
  ;; kscheme に error手続き は未実装
  ;; (define (error s obj)
  ;;   (display s)
  ;;   (display " ")
  ;;   (print obj))

  (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 lst)
    (define (loop items)
      (cond ((null? items) 'done)
            ((eq? (car items) exception) (loop (cdr items)))
            (else (procedure (car items))
                  (loop (cdr items)))))
    (loop lst))

  (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 (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 (* (get-value a) (get-value a)) 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))

  (probe "a" A)
  (probe "b" B)

  (squarer A B)
   
  (set-value! A 10 'user)
  (newline)

  (forget-value! A 'user)
  (newline)
  
  (set-value! B 100 'user)
  (newline)
  )

入出力結果(Terminal(kscheme), REPL(Read, Eval, Print, Loop))

$ gosh sample35.scm

Probe: b = 100
Probe: a = 10

Probe: b = ?
Probe: a = ?

Probe: a = 10
Probe: b = 100
$

0 コメント:

コメントを投稿