問題5.1-5.3

4章最後ごにょごにょしましたが終わったので、5章に入ります。なんかざっと眺めてみると5章最後の方もごにょごにょしそうです。
いつも通り先にシミュレータを作っておきます。超循環評価器より構造が楽ですね。extract-labelsで継続っぽいこともやってて面白い。あと昨日命令列を配列に並べていくのが面白いって言いましたけど、ここでも同じようなことやってますね。やっぱり一般的な方法なんだなー。
make-execution-procedure(制御命令の振り分けと実行手続き生成関数)見てると総称関数の便利さがよく分かった気がする。やってる内容はあんまり変わらないと思うけど。

5.1

図は省略します(図を描くようなCommon Lispのライブラリを作ってみたい。図形言語みたいなの。でも既にありそうだ)。今回はとりあえずレジスタ計算機言語の制御命令列で書いてみます。

(define fact-iter-machine
  (make-machine
   '(p c n)
   (list (list '+ +) (list '* *) (list '> >))
   '( (assign p (const 1))
      (assign c (const 1))
     iter
      (test (op >) (reg c) (reg n))
      (branch (label done))
      (assign p (op *) (reg p) (reg c))
      (assign c (op +) (reg c) (const 1))
      (goto (label iter))
     done)))

> (set-register-contents! fact-iter-machine 'n 10)
done
> (start fact-iter-machine)
done
> (get-register-contents fact-iter-machine 'p)
3628800
> (set-register-contents! fact-iter-machine 'n 10000)
done
> (start fact-iter-machine)
done
> (get-register-contents fact-iter-machine 'p)
284625968091705451890641321211986889014805140 ...... 0000000000

でちゃんと動きますね。なんかすごく楽しい。シミュレーションって面白いなー。

5.2

あ、5.1でやっちゃった…。いや、じゃあデータパスを含んだ形で書きます。といってもデータパスの書き方の定義がないみたいなんで雰囲気で書きます。

(data-paths
 (registers
  ((name p)
   (buttons ((name p<-1) (source (constant 1)))
            ((name p<-p*c) (source (operation *)))))
  ((name c)
   (buttons ((name c<-1) (source (constant 1)))
            ((name c<-c+1) (source (operation +)))))
  ((name n)))
 
 (operations
  ((name *)
   (inputs (register p) (register c)))
  ((name +)
   (inputs (register c) (constant 1)))
  ((name >)
   (inputs (register c) (register n))))
 
 (controller
    (p<-1)
    (c<-1)
  iter
    (test >)
    (branch (label done))
    (p<-p*c)
    (c<-c+1)
    (goto (label iter))
  done))

たぶんこんな感じ。制御器だけの表記からdata-pathsを構成したりするのも頑張ればできそうですね。そこからデータパス図を自動で生成してくれるようなプログラムがあったら便利だなー。

5.3

これもレジスタ計算機言語で書きます。まずはimprove, good-enough?は使えると仮定して始めるみたいなので、sqrt-iterの部分を作ります。

(define (improve guess x) (average guess (/ x guess)))
(define (average x y) (/ (+ x y) 2))
(define (good-enough? guess x)
  (< (abs (- (sqr guess) x)) 0.001))

(define sqrt-machine
  (make-machine
   '(x guess)
   (list (list 'improve improve) (list 'good-enough? good-enough?))
   '( (assign guess (const 1.0))
     sqrt-iter
      (test (op good-enough?) (reg guess) (reg x))
      (branch (label sqrt-done))
      (assign guess (op improve) (reg guess) (reg x))
      (goto (label sqrt-iter))
     sqrt-done)))

データパス図書くと簡単です。実行すると、

> (set-register-contents! sqrt-machine 'x 2)
done
> (start sqrt-machine)
done
> (get-register-contents sqrt-machine 'guess)
1.4142156862745097

でちゃんとでます。精度はモンテカルロよりいいですね。

次にimproveを作ります。

(define sqrt-improve-machine
  (make-machine
   '(x guess buf)
   (list (list 'average average) (list '/ /))
   '( (assign buf (op /) (reg x) (reg guess))
      (assign guess (op average) (reg guess) (reg buf)))))

こんな感じ。できればaverageは無くしたいので展開してみます。すると

(define sqrt-improve-machine
  (make-machine
   '(x guess buf)
   (list (list '+ +) (list '/ /))
   '( (assign buf (op /) (reg x) (reg guess))
      (assign buf (op +) (reg guess) (reg buf))
      (assign guess (op /) (reg buf) (const 2.0)))))

実行すると、

> (set-register-contents! sqrt-improve-machine 'guess 3)
done
> (set-register-contents! sqrt-improve-machine 'x 4.0)
done
> (start sqrt-improve-machine)
done
> (get-register-contents sqrt-improve-machine 'guess)
2.1666666666666665

> (improve 3 4.0)
2.1666666666666665

で正しいようです。次にgood-enough?を作ります。算術演算のみで構築ということなので<とabsとsqrも含めます。

(define sqrt-good-enough?-machine
  (make-machine
   '(x guess buf return)
   (list (list '- -) (list 'abs abs) (list 'sqr sqr) (list '< <))
   '( (assign guess (op sqr) (reg guess))
      (assign buf (op -) (reg guess) (reg x))
      (assign buf (op abs) (reg buf))
      (test (op <) (reg buf) (const 0.001))
      (branch (label true))
      (goto (label false))
     true
      (assign return (const #t))
      (goto (label done))
     false
      (assign return (const #f))
      (goto (label done))
     done)))

すると

> (good-enough? 2 4)
#t
> (set-register-contents! sqrt-good-enough?-machine 'guess 2)
done
> (set-register-contents! sqrt-good-enough?-machine 'x 4)
done
> (start sqrt-good-enough?-machine)
done
> (get-register-contents sqrt-good-enough?-machine 'return)
#t

> (good-enough? 3 4)
#f
> (set-register-contents! sqrt-good-enough?-machine 'guess 3)
done
> (set-register-contents! sqrt-good-enough?-machine 'x 4)
done
> (start sqrt-good-enough?-machine)
done
> (get-register-contents sqrt-good-enough?-machine 'return)
#f

で正しく動きます。trueとかfalseとかのラベルは#tか#fを返すために便宜上入れましたが、sqrtにまとめる時にはとっぱらっていいです。
以上でsqrtを基本演算のみでレジスタ計算機言語で書く準備が整いました。まとめるとこんな感じになると思います。

(define sqrt-machine
  (make-machine
   '(x guess buf)
   (list (list '+ +) (list '- -) (list '/ /) (list 'abs abs) (list 'sqr sqr) (list '< <))
   '(sqrt
      (assign guess (const 1.0))
     sqrt-iter
     good-enough?
      (assign buf (op sqr) (reg guess))
      (assign buf (op -) (reg buf) (reg x))
      (assign buf (op abs) (reg buf))
      (test (op <) (reg buf) (const 0.001))
      (branch (label sqrt-done))
     improve
      (assign buf (op /) (reg x) (reg guess))
      (assign buf (op +) (reg guess) (reg buf))
      (assign guess (op /) (reg buf) (const 2.0))
      (goto (label sqrt-iter))
     sqrt-done)))

必要ないラベルもありますが、何の処理をしてるか分かりやすくするために入れてます。実行してみます。

> (set-register-contents! sqrt-machine 'x 2)
done
> (start sqrt-machine)
done
> (get-register-contents sqrt-machine 'guess)
1.4142156862745097
> (set-register-contents! sqrt-machine 'x 3)
done
> (start sqrt-machine)
done
> (get-register-contents sqrt-machine 'guess)
1.7321428571428572
> (set-register-contents! sqrt-machine 'x 9)
done
> (start sqrt-machine)
done
> (get-register-contents sqrt-machine 'guess)
3.00009155413138

概ね正しい値を得ることができるようです。ところでいちいちset-register-contents!とかget-register-contentsとか打つのとても面倒くさいので次のようなものを導入します。

(define (execute-machine-with machine binds . vars)
  (for-each (lambda (bind)
             (set-register-contents! machine (car bind) (cadr bind)))
           binds)
  (start machine)
  (for-each (lambda (var)
             (print var)(print '=)
             (print (get-register-contents machine var))
             (newline))
           vars))

これで次のように書けます。

> (execute-machine-with sqrt-machine '((x 3)) 'guess)
guess=1.7321428571428572
> (execute-machine-with gcd-machine '((a 24) (b 12)) 'a)
a=12
> (execute-machine-with fact-iter-machine '((n 20)) 'n 'p 'c)
n=20
p=2432902008176640000
c=21

ほんとはマクロで書けばクォートしなくてもいいのですが、Schemeにはgensymがないみたいで"安全な"マクロが作れないみたいなのでやめておきます。

(3/26 4:00)
と思ったんだけど、これ名前被ることないような気がしてきた。定義内部で新しい変数何も作ってないし。いやlambdaで作ってるけどあれはbindsとかvarsの中を回るだけで特に副作用もなさそうだし大丈夫なんじゃないかな。じゃあマクロで書いてしまおう。どうやらdefmacroに似たdefine-macroというものがあるっぽいので書いてみます。

(define-macro (execute-machine-with machine-name binds . vars)
  `(begin
     (for-each (lambda (bind)
                (set-register-contents! ,machine-name (car bind) (cadr bind)))
               ',binds)
     (start ,machine-name)
     (for-each (lambda (var)
                (print var)(print '=)
                (print (get-register-contents ,machine-name var))
                (newline))
               ',vars)))

こんな風にできます。

> (execute-machine-with sqrt-machine ((x 3)) guess)
guess=1.7321428571428572
> (execute-machine-with gcd-machine ((a 24) (b 32)) a b)
a=8
b=0
> (execute-machine-with gcd-machine ((a 108) (b 16)) a b)
a=4
b=0
> (execute-machine-with fact-iter-machine ((n 14)) p c n)
p=87178291200
c=15
n=14

楽しい。でもほんとに安全なのかどうかはよく分かってない。まあ変な風に使わなきゃたぶん大丈夫だと思うけど。

今日はここまで。