(sicp28)put getを作った。

これからの問題に答えるのに、実行できないと大変。
そんなわけで、http://d.hatena.ne.jp/higepon/20060503/1146317558を参考にputとgetを作りました。(getでhashが生成されるのが不思議な感じがしたのでerrorを返すように変更しました。)*1

(define parent-hash (make-hash-table))

(define (put op type item)
  (if (not (hash-table-exists? parent-hash op))
      (hash-table-put! parent-hash op (make-hash-table)))
  (let ((child (hash-table-get parent-hash op)))
    (hash-table-put! child type item)))

(define (get op type)
  (if (not (hash-table-exists? parent-hash op))
      (error "this operator is not exist" op type)
      (let ((child (hash-table-get parent-hash op)))
        (hash-table-get child type))))

put/getをつくって気づいたこと

昨日の問題2.74の回答は動きませんでした＞＜

理由。

-package内のderivで自身のもつderivを参照していた。
関数定義をトップレベルでしてなかった > -package
(+ addend augend)　が渡される処理のままになっていた。*2
- (実際に-packageに渡されるのは、(addend augend)

こちらが修正したもの

(define (deriv exp var)
  (define (variable? exp)
    (symbol? exp))
  (define (same-variable? v1 v2)
    (and (symbol? v1) (symbol? v2) (eq? v1 v2)))
  (cond ((number? exp) 0)
        ((variable? exp)
         (if (same-variable? exp var) 1 0))
        (else
         ((get 'deriv (operator exp)) (operands exp)
                    var))))

(define (operator exp) (car exp))
(define (operands exp) (cdr exp))

;;a.
;; date-directed-programming style apply make-sum, make-product, and anything else. The reason why is because number and symbol is atomic object.

;;b.
(define (install-sum-package)
  ;;internal procedures
  (define (addend s) (car s))
  (define (augend s)
    (fold-right make-sum 0 (cdr s)))
  (define (=number? target n)
    (and (number? target) (= target n)))
  (define (make-sum a1 a2)
    (cond ((=number? a1 0) a2)
          ((=number? a2 0) a1)
          ((and (number? a1) (number? a2)) (+ a1 a2))
          (else (list '+ a1 a2))))
  (define (deriv-sum exp var)
    (make-sum (deriv (addend exp) var)
              (deriv (augend exp) var)))
  
  ;;interface to the rest of the system
  (define (tag x) (attach-tag '+ x))
  (put 'make '+ make-sum)
  (put 'deriv '+ deriv-sum)
'done)


(define (install-product-package)
  ;; internal procedures
  (define (=number? target n)
    (and (number? target) (= target n)))
  (define (multiplier p) (car p))
  (define (multiplicand p)
    (fold-right make-product 1 (cdr p)))
  (define (make-product m1 m2)
    (cond ((or (=number? m1 0) (=number? m2 0)) 0)
          ((=number? m1 1) m2)
          ((=number? m2 1) m1)
          ((and (number? m1) (number? m2)) (* m1 m2))
          (else (list '* m1 m2))))
  (define (deriv-product exp var)
    ((get 'make '+)
     (make-product (multiplier exp)
                   (deriv (multiplicand exp) var))
     (make-product (deriv (multiplier exp) var)
                   (multiplicand exp))))
  (install-sum-package)
  ;;interface to the rest of the system
  (put 'make '* make-product)
  (put 'deriv '* deriv-product)
  'done)

;;c.
(define (install-exponent-package)
  (define (base e)  (car e))
  (define (exponent e) (cadr e))
  (define (make-exponetiation b e)
    (cond ((= e 0) 1)
          ((= e 1) b)
          (else (list '** b e))))
  (define (deriv-exponentiation exp var)
    ((get 'make '*)
     ((get 'make '*) (exponent exp)
                   (make-exponetiation (base exp) (- (exponent exp) 1)))
     (deriv (base exp) var)))

  (install-product-package)
  ;;interface to the rest of the system
  (put 'make '** make-exponetiation)
  (put 'deriv '** deriv-exponentiation)
  'done)

(define (install-deriv-package)
  (install-exponent-package))

動作確認

(install-deriv-package)
(define (f exp)
  (print "(deriv " exp  ") = " (deriv exp 'x)))
(let ()
(f '(* x 3 4))
(f '(** x 4))
(f '(+ (* 3 (** x 2)) (* 60 x) 12))
(f '(** x 30 ))
)

;; 9:user> (deriv (* x 3 4)) = 12
;; (deriv (** x 4)) = (* 4 (** x 3))
;; (deriv (+ (* 3 (** x 2)) (* 60 x) 12)) = (+ (* 3 (* 2 x)) 60)
;; (deriv (** x 30)) = (* 30 (** x 29))

*1:ハッシュテーブルの名前を変えたのは気分です＞＜

*2:sum-packageに渡される時