SICP 読み (52) 2.4.3 データ主導プログラミングと加法性

ようやく問題 2.73 の検討に着手。

問題 2.73

a. について

やった事は、式を微分する手続きを deriv という演算の sum と product という型、という形式で演算表を作ってそれを操作する形に変更、となるのかな。
ちなみに number? とか variable? が振り分けに吸収できないのは、式の形になってない、というか operator と operands で扱える形になってないから、ではないかと。

b. について

とりあえず最初の状態を。まず試験を演算表と関係ない部分のナニが以下。(variable? とか same-variable? は略)

#!/usr/bin/env gosh

(use test.unit)
(require "2.73")

(define-test-suite "2.73"
  ("operator test"
   ("operator test"
    (assert-equal '+ (operator '(+ 2 3 4 5)))
    )
   )

  ("operands test"
   ("operands test"
    (assert-equal '(2 3 4 5) (operands '(+ 2 3 4 5)))
    )
   )

  ("deriv test"
   ("deriv test (first)"
    (assert-equal 0 (deriv '1 'x))
    (assert-equal 0 (deriv 'y 'x))
    (assert-equal 1 (deriv 'x 'x))
    )
   )

  )

実装が以下。まだ演算表関連の手続きはまだ。

(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))
(define (variable? x) (symbol? x))
(define (same-variable? v1 v2)
  (and (variable? v1) (variable? v2) (eq? v1 v2)))

なんかボサっと検討してたら以下のような手続きがでっち上がった。(上への追加分)

(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 (=number? exp num)
  (and (number? exp) (= exp num)))
(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 (assoc key records)
 (cond ((null? records) #f)
       ((equal? key (caar records)) (car records))
       (else (assoc key (cdr records)))))

(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 (attach-tag type-tag contents)
 (cons type-tag contents))
(define (type-tag datum)
 (if (pair? datum)
     (car datum)
     (error "Bad tagged datum -- TYPE TAG" datum)))
(define (contents datum)
 (if (pair? datum)
     (cdr datum)
     (error "Bad tagged datum -- CONTENTS" datum)))

(define (install-deriv-package)
  (define (sum l var)
    (make-sum (deriv (car l) var)
	      (deriv (cadr l) var)))
  (define (product l var)
    (make-sum
     (make-product (car l) (deriv (cadr l) var))
     (make-product (deriv (car l) var) (cadr l))))

  (put 'deriv '+ sum)
  (put 'deriv '* product)
  'done)

とりあえず、deriv の試験を以下のようにして確認してみる。(テキストなナニ)

  ("deriv test"
   (setup (lambda () (install-deriv-package)))
   ("deriv test (first)"
    (assert-equal 0 (deriv '1 'x))
    (assert-equal 0 (deriv 'y 'x))
    (assert-equal 1 (deriv 'x 'x))
    )
   ("deriv test (second)"
    (assert-equal 1 (deriv '(+ x 3) 'x))
    (assert-equal 'y (deriv '(* x y) 'x))
    (assert-equal '(+ (* x y) (* y (+ x 3)))
		  (deriv '(* (* x y) (+ x 3)) 'x))
    )
   )

また install な手続きを呼ぶのを忘れていてオコラれた。(とほほ

c. について

とりあえずカンニングでべき乗を。
てか、その前に可読性という部分で実装を以下に変更した方が良さげ、と思った。

(define (install-deriv-package)
  (define (sum l var)
    (define (addend exp) (car exp))
    (define (augend exp) (cadr exp))
    (make-sum (deriv (addend l) var)
	      (deriv (augend l) var)))
  (define (product l var)
    (define (multiplier exp) (car exp))
    (define (multiplicand exp) (cadr exp))
    (make-sum
     (make-product (multiplier l) (deriv (multiplicand l) var))
     (make-product (deriv (multiplier l) var) (multiplicand l))))

  (put 'deriv '+ sum)
  (put 'deriv '* product)
  'done)

で、べき乗を盛り込んでみる。とりあえずパクった試験が以下。

  ("deriv test"
   (setup (lambda () (install-deriv-package)))
   ("deriv test (first)"
    (assert-equal 0 (deriv '1 'x))
    (assert-equal 0 (deriv 'y 'x))
    (assert-equal 1 (deriv 'x 'x))
    )
   ("deriv test (second)"
    (assert-equal 1 (deriv '(+ x 3) 'x))
    (assert-equal 'y (deriv '(* x y) 'x))
    (assert-equal '(+ (* x y) (* y (+ x 3)))
		  (deriv '(* (* x y) (+ x 3)) 'x))
    )
   ("deriv test (third)"
    (assert-equal 1 (deriv (make-exponentiation 'x 1) 'x))
    (assert-equal '(* 2 x) (deriv (make-exponentiation 'x 2) 'x))
    (assert-equal '(* 5 (** x 4))
		  (deriv (make-exponentiation 'x 5) 'x))
    )
   )

えーとカンニングして以下の実装、になったんですがなんか微妙。(追加、修正分のみ)

(define (install-deriv-package)
  (define (sum l var)
    (define (addend exp) (car exp))
    (define (augend exp) (cadr exp))
    (make-sum (deriv (addend l) var)
	      (deriv (augend l) var)))
  (define (product l var)
    (define (multiplier exp) (car exp))
    (define (multiplicand exp) (cadr exp))
    (make-sum
     (make-product (multiplier l) (deriv (multiplicand l) var))
     (make-product (deriv (multiplier l) var) (multiplicand l))))
  (define (exponential l var)
    (define (base x) (car x))
    (define (exponent x) (cadr x))
    (make-product 
     (exponent l)
     (make-exponentiation (base l) (- (exponent l) 1))))

  (put 'deriv '+ sum)
  (put 'deriv '* product)
  (put 'deriv '** exponential)
  'done)

(define (make-exponentiation e1 e2)
  (cond ((=number? e1 1) 1)
	((=number? e2 0) 1)
	((and (number? e1) (number? e2))
	 (let f ((e1 e1) (e2 e2) (result 1))
	   (if (= e2 0)
	       result
	       (f e1 (- e2 1) (* result e1)))))
	((=number? e2 1) e1)
	(else (list '** e1 e2))))

これ、試験は通るが、という罠な気がしてるんですが ...
# とは言え、微分のルールが分かってないのでナニ

d. について

これ、ぱっと見では put の引数逆にすれば良いだけじゃん、と思ってしまったんですが多分ダウトだな。c. の微妙な点を含め、明日検討とゆー事で。(を