読者です 読者をやめる 読者になる 読者になる

計算機プログラムの構造と解釈 第二版 P108 問題2.73

この問題はほとんどコピペで解決できる。
思いつけば簡単だし、思いつかないと苦労しそうな問題。


a, b, c, dと四つ問題がある。

a.
たぶん記号微分の手続きのインターフェースを定義してるんじゃないかと思う。
データの形式が違っても基本これを使う、みたいな。
そんで、number?とvariable?だけどこれは、タグみたいのをつけられない
ネイティブ?っていうとちょっと違うかもしれないけど、
そういうデータ構造だから、振り分けに吸収できないんでないかと思う。


b.
こんなもんはほとんどコピペだ。
まずは、P159の
make-table
operation-table
get
put
手続きをコピる。これだってちゃんと写経してればもう既に書いているはず。


そしたらP106の以下のスクリプトをひたすら眺める。

(define (install-rectangular-package)
  ;;内部手続き
  (define (real-part z) (car z))
  (define (imag-part z) (cdr z))
  (define (make-from-real-imag x y) (cons x y))
  (define (magnitude z)
    (sqrt (+ (square (real-part z))
             (square (imag-part z)))))
  (define (angle z)
    (atan (imag-part z) (real-part z)))
  (define (make-from-mag-ang r a)
    (cons (* r (cos a)) (* r (sin a))))

  ;;システムの他の部分とのインターフェース
  (define (tag x)
    (attach-tag 'rectangular x))
  (put 'real-part '(rectangular) real-part)
  (put 'imag-part '(rectangular) imag-part)

  (put 'magnitude '(rectangular) magnitude)
  (put 'angle '(rectangular) angle)
  (put 'make-from-real-imag 'rectangular
       (lambda (x y) (tag (make-from-real-imag x y))))
  (put 'make-from-mag-ang 'rectangular
       (lambda (r a) (tag (make-from-real-mag-ang r a))))
  'done)

ふんがぁ。

で、それから問題を考える。
そうすると大体やる事が見えてきて、
2.3.2節で出てきた関数をどうやっておき返れば良いか見えてくる。
必要な手続きを内側で宣言して、最後にputと結びつけてやれば良い。


だけど他にもいろいろ微分の為の関数をつかっているので、そいつらもなんとかしないと行けないが、それは、P86, P87にのってるので、写経をしてればコピペでいける。


と、思うのだが単純にはいかなくて、
この問題で定義しないといけないderivの定義は、
P86のderivとは違い、
手続きoperatorに渡しているのが、
(キャラクタ キャラクタ)
を渡しているので、もう一工夫必要。
僕は一瞬ここで詰まったが、がんばれば人間何とかなる。


c
この問題は上のbが出来てて問題2.56を解いていれば、
やはり基本はコピペで、上記bと同様のコツを使う事で何とかなる。


d
P106の図2.22をみるとわかるけど、列名と行名をいれかえてるだけ。
だからgetで手続きの目印を反対にするなら、
対応して、putも手続きの目印を反対にすれば良い。


では実装

#!/usr/local/bin/gosh
;; -*- coding: utf-8 -*-

(use ggc.debug.trace)
(use math.mt-random)


(define nil '())
(define nl newline)
(define disp display)
(define (square x)
  (* x x))


;;; 3.3.3 put & get
(define (make-table)
  (let ((local-table (list '*table*)))
    (define (lookup key-1 key-2)
      (let ((subtable (assoc key-1 (cdr local-table))))
        (if subtable
          (let ((record (assoc key-2 (cdr subtable))))
            (if record
              (cdr record)
              #f))
          #f)))
    (define (insert! key-1 key-2 value)
      (let ((subtable (assoc key-1 (cdr local-table))))
        (if subtable
          (let ((record (assoc key-2 (cdr subtable))))
            (if record
              (set-cdr! record value)
              (set-cdr! subtable
                        (cons (cons key-2 value)
                              (cdr subtable)))))
          (set-cdr! local-table
                    (cons (list key-1
                                (cons key-2 value))
                          (cdr local-table)))))
      'ok)
    (define (dispatch m)
      (cond ((eq? m 'lookup-proc) lookup)
            ((eq? m 'insert-proc!) insert!)
            (else (error "Unknown operation -- TABLE" m))))
    dispatch))

(define operation-table (make-table))

(define get (operation-table 'lookup-proc))
(define put (operation-table 'insert-proc!))


(define (deriv exp var)
  (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))


;;p86-p87
;変数は記号とする、基本手続きsymbol?で識別できる:
(define (variable? x) (symbol? x))

;二つの変数はそれを表現している記号がeq?なら同じである:
(define (same-variable? v1 v2)
  (and (variable? v1) (variable? v2) (eq? v1 v2)))

;和と積はリストとして構成する:
(define (make-sum a1 a2)
  (list '+ a1 a2))

(define (make-product m1 m2)
  (list '* m1 m2))

;和は最初の要素が記号+である:
(define (sum? x)
  (and (pair? x) (eq? (car x) '+)))

;加数は和のリストの第二項である:
;(define (addend s)
;  (cadr s))
(define (addend s)
  (car s))

;被加数は和のリストの第三項である:
;(define (augend s)
;  (caddr s))
(define (augend s)
  (cadr s))

;積は最初の要素が記号*であるリストである:
(define (product? x)
  (and (pair? x) (eq? (car x) '*)))

;乗数は積のリストの第二項である:
;(define (multiplier p)
;  (cadr p))
(define (multiplier p)
  (car p))

;被乗数は積のリストの第三項である:
;(define (multiplicand p)
;  (caddr p))
(define (multiplicand p)
  (cadr p))


(define (install-deriv-package)
  ;;内部手続き
  (define (sum exp var)
    (make-sum (deriv (addend exp) var)
              (deriv (augend exp) var)))
  (define (product exp var)
    (make-sum
      (make-product (multiplier exp)
                    (deriv (multiplicand exp) var))
      (make-product (deriv (multiplier exp) var)
                    (multiplicand exp))))
  ;;問題2.56より
  ;;べき乗
  (define (exponentiation exp var)
    (make-product (exponent exp)
                  (make-product
                    (make-exponentiation (base exp) (- (exponent exp) 1))
                    (deriv (base exp) var))))

  ;;システムの他の部分とのインターフェース
  (put 'deriv '+ sum)
  (put 'deriv '* product)
  ;;べき乗
  (put 'deriv '** exponentiation)
  'done)


;;問題2.56
;基数はべき乗のリストの第二項である。
;(define (base x)
;  (cadr x))
(define (base x)
  (car x))


;乗数はべき乗のリストの第三項である。
;(define (exponent x)
;  (caddr x))
(define (exponent x)
  (cadr x))

(define (=number? exp num)
  (and (number? exp) (= exp num)))

(define (make-exponentiation b e)
  (cond ((=number? b 0) 0)
        ((=number? e 1) b)
        ((=number? e 0) 1)
        ((and (number? b) (number? e)) (expt b e))
        (else (list '** b e))))


;;dの問題
;(define (deriv exp var)
;  (cond ((number? exp) 0)
;        ((variable? exp) (if (same-variable? exp var) 1 0))
;        (else ((get (operator exp) 'deriv) (operands exp)
;                                           var))))

;;(define (install-deriv-package)
  ;;内部手続き
;  (define (sum exp var)
;    (make-sum (deriv (addend exp) var)
;              (deriv (augend exp) var)))
;  (define (product exp var)
;    (make-sum
;      (make-product (multiplier exp)
;                    (deriv (multiplicand exp) var))
;      (make-product (deriv (multiplier exp) var)
;                    (multiplicand exp))))
  ;;問題2.56より
  ;;べき乗
;  (define (exponentiation exp var)
;    (make-product (exponent exp)
;                  (make-product 
;                    (make-exponentiation (base exp) (- (exponent exp) 1))
;                    (deriv (base exp) var))))

  ;;システムの他の部分とのインターフェース
;  (put '+ 'deriv sum)
;  (put '* 'deriv product)
  ;;べき乗
;  (put '** 'deriv exponentiation)
;  'done)



;; main
(define (main args)
  (install-deriv-package)

  (disp "(deriv '(+ x 1) 'x): ")
  (disp (deriv '(+ x 1) 'x))
  (nl)
  
  (disp "(deriv '(* 3 x) 'x): ")
  (disp (deriv '(* 3 x) 'x))
  (nl)
  

  (disp "(deriv '(** x 2) 'x): ")
  (disp (deriv '(** x 2) 'x))
  (nl)

  0)


実行

(deriv '(+ x 1) 'x): (+ 1 0)
(deriv '(* 3 x) 'x): (+ (* 3 1) (* 0 x))
(deriv '(** x 2) 'x): (* 2 (* x 1))

ふんが!