SICP問題5.18-5.19

GWがあったのと、その後遺症で脳が機能を縮退していたせいもあり、だいぶ間があいてしまいましたが、つづきです。

いっぱいなおしすぎてるんで、もうわけわかりません。
ソースおいとくので、そっちみてください。

5.18のレジスタのトレースについては、いままでやってきたのをレジスタに適用するだけです。トレースをON/OFFするのは、別途set-register-trace-onとset-register-trace-offを用意してます。

5.19はいよいよ本命のブレークポイントを導入する問題。
ラベルとラベルからの距離をいれることでその位置にブレークポイントを設定し、pcがそこに到達すると、その命令を実行する直前に処理を停止させる。
5.17でinstructionにラベルをいれるのが個人的に非常に気に入ったので、ブレークポイントの設定はリストにして保持するのではなく、ラベルからの距離と一緒にinstructionにいれてしまうことにしました。

(define (make-instruction text)
  ; テキスト、命令、直前のラベル、ラベルからの距離、ブレイクポイント
  (list text '() '() '() false))

; instructionにラベルとラベルからの距離の情報を記憶させる
(define (set-label-to-instructions! insts label)
  (define (iter insts count)
    (if (or (null? insts) (instruction-have-label? (car insts)))
      insts
      (cons (set-instruction-label-info! (car insts) label count)
            (iter (cdr insts) (+ count 1)))))
  (iter insts 1))

そして、(set-breakpoint machine label n)としたときにえっちらおっちらinstructionを検索して、ラベルと距離が一致するところにブレークポイントを設定します。

      ; ブレークポイントを設定する
      (define (set-breakpoint-switch label n switch)
        ; pcを頭から走査し、ラベルと距離が一致したらセット
        ; 見つからない場合はエラーにする。
        (define (iter insts)
          (if (null? insts)
            (error "Not find label -- MACHINE" label n)
            (let ((inst (car insts)))
              (if (and (eq? (instruction-label inst) label)
                          (eq? (instruction-label-count inst) n))
                (set-instruction-breakpoint! inst switch)
                (iter (cdr insts))))))
        (iter the-instruction-sequence)
        'done)
      ; ブレークポイントON用
      (define (set-breakpoint label n)
        (set-breakpoint-switch label n true))
      ; ブレークポイントCANCEL用
      (define (cancel-breakpoint label n)
        (set-breakpoint-switch label n false))

executeでは実行直前にinstructionがブレークポイント設定されているかどうかを判定し
、設定されていたら何もせずに終わります。このとき、pcの中身は実行しようとしていた命令のままです。

      (define (execute)
        (let ((insts (get-contents pc)))
          (if (null? insts)
            'done
            (begin
              ; 命令計数
              (advance-instruction-count)
              ; 命令トレース
              (print-instruction-trace (car insts))

              ; ブレークポイントが設定されていない場合のみexecuteする
              ; このときpcは実行直前の状態になってるはずなので
              ; この状態で再度executeすれば続きから実行できるはず
              (if (not (instruction-breakpoint (car insts)))
                (begin
                  ((instruction-execution-proc (car insts)))
                  (execute))
                (begin
                  (print-breakpoint (car insts))
                  'stop))))))

このままexecuteをもう一回やっても同じようにとまってしまうので、proceed-machineはpcの最初の命令をブレークポイントを無視して実行し、つづきはexecuteにまかせると言う形をとります。

      ; 再開
      (define (proceed)
        ; とまっている箇所をブレークポイントを無視して実行し
        ; executeを呼びだす。
        (let ((insts (get-contents pc)))
          (if (null? insts)
            'done
            (begin
              ; 命令計数
              (advance-instruction-count)
              ; 命令トレース
              (print-instruction-trace (car insts))
              ((instruction-execution-proc (car insts)))
              (execute)))))

なんか無駄が多いような気がしますが。
cancel-all-breakpointはinstructionを全部なめて片っ端からoffにしていくだけです。

ソース

ダウンロード

モンテ・クリスト伯

いやあ、うわさにたがわず、面白かったです。

もし、今買おうかどうか悩んでいたら、迷うことなく買うことをおすすめします。
文庫で7巻ありますが、そんなものは問題ありません、読んでるうちにすぐ終わります。
読む時間がないというのも心配ありません、読み始めれば、読む時間を作るようになるはずです。

あらすじは超有名なんで、なんとなくどんな感じかは知っていたんですが、ファリア司祭が出てきたあたりからぐんぐん話しに引き込まれていき、そのまま結末まで一気に進んでしまいました。
じっくりと進む展開に、ここまで詳細に書いていく必要があるんだろうか、と思ったこともあったんですが、最後まで読み終わってみると、ああ、ここまで書くことに意味があったんだなあと考え直しました。ここまで書かないと、エドモン・ダンテスの最後の心境に違和感を感じてしまうのかもしれないと思ったわけです。
まあネタバレするのもアレなんで実際読んでみてほしいんですが、最後の感動はダンテスに対する共感が不可欠です、ダンテスの心の動きに沿って読んでいく必要があるわけで、そうなるためにはダンテス以上に相手側の描写を重ねていく必要があるのです。

と、いうわけで、長いのにも意味はありますし、実際読んでて面白いので、本当に一気に読めてしまうと思います。
GWは終わりましたが、次の連休に向けて読むものを探してる人は、一度検討してみてはいかがでしょうか。

SICP問題5.17

命令の直前にあるラベルを表示できるようにする問題。
最初は前問までと同じようなにexecuteになにか処理をつっこめばいいのかと思っていましたが、よくソースをみてみると、基本計算機ってラベルの情報持ってないんですよね。
というわけで、あーだこーだ考えてましたが、後でやることになる5.19の問題のことも考慮して一番楽そうな、extract-labelsを変更することにしました。
大体こんな感じです。

(define (extract-labels text receive)
  (if (null? text)
    (receive '() '())
    (extract-labels (cdr text)
                    (lambda (insts labels)
                      (let ((next-inst (car text)))
                        (if (symbol? next-inst)
                          (if (assoc next-inst labels)
                            (error "Multiply defined label -- ASSEMBLE" next-inst)
                            (receive (set-label-to-instructions! insts next-inst)
                                     (cons (make-label-entry next-inst
                                                             insts)
                                           labels)))
                          (receive (cons (make-instruction next-inst)
                                         insts)
                                   labels)))))))
(define (make-instruction text)
  (list text '() '()))

(define (instruction-text inst)
  (car inst))

(define (instruction-execution-proc inst)
  (cadr inst))

(define (set-instruction-execution-proc! inst proc)
  (set-car! (cdr inst) proc))

; instructionにラベルの情報を記憶させる
(define (set-label-to-instructions! insts label)
  (if (or (null? insts) (instruction-have-label? (car insts)))
    insts
    (cons (set-instruction-label-info! (car insts) label)
          (set-label-to-instructions! (cdr insts) label))))

(define (instruction-have-label? inst)
  (not (null? (instruction-label inst))))

(define (instruction-label inst)
  (caddr inst))

(define (set-instruction-label-info! inst label)
  (set-car! (cddr inst) label)
  inst)

extract-labelsは命令のテキストの最後の方から逆順で処理していくため、labelが見つかった場合は、そこまでで処理されているinstsに対してlabelを覚えさせればよいはずです、ただしそのinstがすでにlabelを覚えている場合には上書きしてはいけません。
というようなことをset-label-to-instructions!でやってます。
直前のラベルの情報はmake-instructionのところで機械命令データ構造に確保しています。また、データ構造が変わっているため、アクセスするための手続きにもちょっと手をいれています。

SICP問題5.15-5.16

命令計数と命令トレースを組み込む問題。
命令計数の方は、最初各make～に組み込んでましたが、命令トレースのところでexecuteに組み込めばいいじゃん、と気づいたのでシコシコ修正。
なおしたのは基本計算機のみです。  多分。

; 基本計算機
(define (make-new-machine)
  (let ((pc (make-register 'pc))
        (flag (make-register 'flag))
        (stack (make-stack))
        (the-instruction-sequence '())
        (instruction-count 0)
        (instruction-trace false))
    ; 命令計数用
    (define (advance-instruction-count)
      (set! instruction-count (+ 1 instruction-count)))
    (define (initial-instruction-count)
      (set! instruction-count 0))
    (define (print-instruction-count)
      (newline)
      (display (list 'instruction-count '= instruction-count))
      (newline))
    ; 命令トレース用
    (define (trace-on)
      (set! instruction-trace true))
    (define (trace-off)
      (set! instruction-trace false))
    (let ((the-ops
            (list (list 'initialize-stack
                        (lambda () (stack 'initialize)))
                  (list 'print-stack-statistics
                        (lambda () (stack 'print-statistics)))
                  (list 'print-instruction-count
                        (lambda () (print-instruction-count)))
                  (list 'initial-instruction-count
                        (lambda () (initial-instruction-count)))))
          (register-table
            (list (list 'pc pc) (list 'flag flag))))
      (define (allocate-register name)
        (if (assoc name register-table)
          (error "Multiply defined register: " name)
          (set! register-table
            (cons (list name (make-register name))
                  register-table)))
        'register-allocated)
      (define (lookup-register name)
        (let ((val (assoc name register-table)))
          (if val
            (cadr val)
            (error "Unknown register: " name))))
      (define (execute)
        (let ((insts (get-contents pc)))
          (if (null? insts)
            'done
            (begin
              ; 命令計数
              (advance-instruction-count)
              ; 命令トレース
              (print-instruction-trace (car insts))
              ((instruction-execution-proc (car insts)))
              (execute)))))
      ; 命令トレース
      (define (print-instruction-trace inst)
        (if instruction-trace
          (begin
            (display (instruction-text (car inst)))
            (newline))))
      (define (dispatch message)
        (cond ((eq? message 'start)
               (set-contents! pc the-instruction-sequence)
               (execute))
              ((eq? message 'install-instruction-sequence)
               (lambda (seq) (set! the-instruction-sequence seq)))
              ((eq? message 'allocate-register) allocate-register)
              ((eq? message 'get-register) lookup-register)
              ((eq? message 'install-operations)
               (lambda (ops) (set! the-ops (append the-ops ops))))
              ((eq? message 'stack) stack)
              ((eq? message 'operations) the-ops)
              ; 命令計数用
              ((eq? message 'initial-instruction-count) (initial-instruction-count))
              ((eq? message 'advance-instruction-count) (advance-instruction-count))
              ; 命令トレース用
              ((eq? message 'trace-on) (trace-on))
              ((eq? message 'trace-off) (trace-off))
              (else (error "Unknown request -- MACHINE" message))))
      dispatch)))

fibonacci計算機の命令計数が爆発的にあがっていくのがよくわかりました。

SICP問題5.14

階乗計算機にスタックの統計情報をくみこむ問題。
ついでにreadとprintも追加することになります。
read、printはありがたいことに標準で用意されているようなのでそれをそのまんま使います。

(define fact-machine
  (make-machine
    '(val n continue)
    (list (list 'print print) (list 'read read) (list '- -) (list '= =) (list '* *))
    '( 
      fact-start
        (perfome (op initialize-stack))
        (assign continue (label fact-done))
        (assign n (op read))
      fact-loop
        (test (op =) (reg n) (const 1))
        (branch (label base-case))
        (save continue)
        (save n)
        (assign n (op -) (reg n) (const 1))
        (assign continue (label after-fact))
        (goto (label fact-loop))
      after-fact
        (restore n)
        (restore continue)
        (assign val (op *) (reg n) (reg val))
        (goto (reg continue))
      base-case
        (assign val (const 1))
        (goto (reg continue))
      fact-done
        (perfome (op print) (reg val))
        (perfome (op print-stack-statistics))
        (goto (label fact-start)))))

nに関する式はおそらく(2*(n-1))だと思われます。

SICP問題5.13

レジスタをあらかじめ指定するのではなく、使われた時点で割り当てるようにする、という問題だと解釈しました。
と、いうわけでこんな感じに修正してます。

      (define (lookup-register name)
        (let ((val (assoc name register-table)))
          (if val
            (cadr val)
            ; エラーにせずにレジスタを割り当てるようにする。
;            (error "Unknown register: " name))))
            (begin
              (allocate-register name)
              (lookup-register name)))))

lookup-registerで見つからなかったらallocate-registerして、もういっかい検索という横着なつくりです。
allocate-registerがちゃんとレジスタをつくってくれないと無限ループですが、あまり気にしないことにしました。

SICP問題5.12

なんかいろいろ情報をためましょうという問題。
せっかくきれいに写生したソースが自分のグダグダなコードで汚くなっていきます。
これまたあちこちなおしてるのでソースでどぞ。

使い方は

(fibonacci-machine 'get-commands) ;命令のリスト
(fibonacci-machine 'get-goto-register) ; gotoにセットしたレジスタのリスト
(fibonacci-machine 'get-save-register) ; スタックにsaveしたレジスタのリスト
(fibonacci-machine 'get-restore-register) ; スタックからrestoreしたレジスタのリスト
((fibonacci-machine 'get-register-values) 'レジスタ名) ; レジスタにセットされる代入元のリスト

みたいな感じです。
ちょっと面倒だったのが最後のレジスタ毎の代入元リストで、仕方ないのでスタックみたいなリストをためておくための手続きを用意してレジスタを作るたびに一緒に作るようにしてます。
後、値を一意にするの部分は面倒だったのでassocで頑張ってます。
使い方が悪いせいかリストの中のカッコがやたら多いので、返す直前にmapでcarしてます。

ダウンロード

メモ：エドモン・ダンテスの獄中生活

モンテ・クリスト伯を読んでます。
いやあ、うわさにたがわぬ面白さで、非常に先が気になります。
話自体も気になるんですが、実はもうひとつ気になることがあって、果たしてエドモン・ダンテスは14年間何をしていたのか、いまいちよくわからないんですね。
そこで、本文中の手がかりから、彼が大体何をしていたか整理してみようかなあ、と思ってます。
ググッた方が早いかもしれませんが、強烈なネタバレ食らうのもいやなので。
以下にあるものは全て岩波文庫から出ている山内義雄訳の「モンテ・クリスト伯」をもとにしてます。

まずは刑務検察官の巡視のときに出てくる、収監されてから17ヶ月と言う台詞です（1巻270頁）。ここまでは何もわからずにただとらわれている状態です。
ここでダンテスは検察官に自分のことを自由にしてくれるよう嘆願し、そしてその結果をまちます。
この待っている期間は、2週間＋3ヶ月＋6ヶ月=9ヶ月半です、が、なぜか本文では10ヶ月半になっています（1巻285頁）。いやがらせでしょうか。まあ、10ヶ月半が正しいとして、この時点で27ヶ月=2年3ヶ月が経過したことになります。そして、それからさらに1年後、典獄が変わったという記述があり（1巻286頁）、3年3ヶ月経過したことがわかります。
その後ダンテスは囚人がたどるあらゆる不幸の段階を経験し、気がつけば4年が経過しています（1巻296頁）。7年3ヶ月です。
ダンテス自身は牢にはいっておよそ6年（1巻307頁）といっていますが、時計も持たない、囚人の言うことです、気にしないことにしましょう。
さらにもうしばらくして、運命の師ファリア司祭に出会います、ここでダンテスは自分がつかまったときに、満19歳になりかけていた、と言い、それを受けてファリア司祭はではまだ26にはなっていまい、とつぶやきます（1巻315～316頁）、ということは上の計算はまんざら間違ってなさそうです。
運命の出会いの後、ダンテスは1年間彼の教えを受けます（1巻370頁）、8年3ヶ月です。
ここでファリア司祭が再度脱獄を計画し、2人でトンネル堀を進めます。
とまあここまでは順調なんですが、難しいのはここからで、そのトンネル堀りには1年を越える月日（1巻375頁）がかかっているというのはまあよいとして、その後、「穴は15ヶ月の後にできあがった」という記述があります。どこから数えてなのかわかりません。まあ長めに数えて1年＋15ヶ月=2年3ヶ月、合計で10年6ヶ月経過したことにしましょう。

ここから先は脱出し、ダンテスが14年の歳月が流れたと知るまで、具体的な年月は出てきていないと思われます。
つまりおよそ3年半の間、ダンテスとファリア司祭はいろいろと胸に思うところはあるにせよ、父親と息子のような絆をはぐくんでいたということになるのでしょう。
で、あればファリア司祭を失ったときの悲しみいかばかりか、とあらためて胸に来るところがあります。

黒死館殺人事件

去年の夏に一度読んでるんですが、気に入って新しい本を買ったので再読。
名探偵法水麟太郎が事件を解決する話なんですが、そこには悪魔がどうしたとか、聞いた事のない反射運動がどうたらとか、解けるわけねえだろと思わずつぶやきたくなる暗号とかが満載されていて、飽きることがありません。
いろいろよくわからないことが書いてありますが、あまりきにしないで法水という探偵の持つ魅力を存分に楽しんだほうがよいと思います。
なにしろ、この法水という探偵は、ホームズを代表とする名探偵であり、あらゆる問題をあっというまに解いてしまうのですが、にもかかわらず事件がさっぱり解決していかない、いわば探偵小説における刑事役のようでもあり、また、時には実際の犯人が行っていない犯罪方法を創出する、いわば犯人役までも兼ねているような人物なのです。
一応熊城や支倉といった本当の刑事役もいるのですが、法水の言うことに驚いているか、でなければ皮肉を言っているか、もうほとんどいないのと同じレベルの存在感しかありません。
読めば読むほど事件の真相には興味がなくなってくる、不思議な魅力の小説だと思います。

SICP問題5.11-c

各レジスタ毎にスタックを持たせようという問題。
本に書いてあるとおりでなくとも、ひとつのスタックに全部入れといてassocするのもありかと思いましたが、とりだしたあとstackから取り除くのにset-cdr!とか駆使しないといけなそうだったのでおとなしく書いてあるとおりの方針でやることにしました。

考え方としては、レジスタを作ったタイミングでついでにstackも作ることにし、マシンには(レジスタ名,stack)のリストを保持させます、そして取り出す際にはレジスタ名でリストを検索し、該当のstackからpush、popします。

まずはmake-new-machine。
allocate-registerをしたタイミングでスタックを作るように変更しています。
また、initialize-stackはstackのリストを順にinitializeしていくようにしました。
ところで、initialize-stackって本文だと使ってないですよね？
（写し間違えてたら悲しい）

; レジスタ毎専用スタック作成
(define (make-exclusive-stack name)
  (list (cons name (make-stack))))

; 基本計算機
(define (make-new-machine)
  (let ((pc (make-register 'pc))
        (flag (make-register 'flag))
        ; スタックはレジスタ登録時に一緒に作る
        (stack '())
        (the-instruction-sequence '()))
    (let ((the-ops
            (list (list 'initialize-stack
                        (lambda () (map (lambda (exclusive-stack)
                                          ((cdr exclusive-stack) 'initialize))
                                        stack)))))
          (register-table
            (list (list 'pc pc) (list 'flag flag))))
      (define (allocate-register name)
        (if (assoc name register-table)
          (error "Multiply defined register: " name)
          (begin
            (set! register-table
              (cons (list name (make-register name))
                    register-table))
            ; レジスタ毎の専用スタック作成
            (set! stack (append stack (make-exclusive-stack name)))))
        'register-allocated)
      (define (lookup-register name)
        (let ((val (assoc name register-table)))
          (if val
            (cadr val)
            (error "Unknown register: " name))))
      (define (execute)
        (let ((insts (get-contents pc)))
          (if (null? insts)
            'done
            (begin
              ((instruction-execution-proc (car insts)))
              (execute)))))
      (define (dispatch message)
        (cond ((eq? message 'start)
               (set-contents! pc the-instruction-sequence)
               (execute))
              ((eq? message 'install-instruction-sequence)
               (lambda (seq) (set! the-instruction-sequence seq)))
              ((eq? message 'allocate-register) allocate-register)
              ((eq? message 'get-register) lookup-register)
              ((eq? message 'install-operations)
               (lambda (ops) (set! the-ops (append the-ops ops))))
              ((eq? message 'stack) stack)
              ((eq? message 'operations) the-ops)
              (else (error "Unknown request -- MACHINE" message))))
      dispatch)))

ASSEMBLEのスタック命令の方も変えてます。

; スタック命令
(define (make-save inst machine stack pc)
  (let ((reg (get-register machine
                           (stack-inst-reg-name inst))))
    ; 専用のスタックを探す
    (let ((exclusive-stack
            (get-exclusive-stack stack (stack-inst-reg-name inst))))
      (lambda ()
        (push exclusive-stack (get-contents reg))
        (advance-pc pc)))))

(define (make-restore inst machine stack pc)
  (let ((reg (get-register machine
                           (stack-inst-reg-name inst))))
    ; 専用のスタックを探す
    (let ((exclusive-stack
            (get-exclusive-stack stack (stack-inst-reg-name inst))))
      (lambda ()
        (set-contents! reg (pop exclusive-stack))
        (advance-pc pc)))))

stackを探してくるところはこんな感じ。

; 専用スタックの取得
(define (get-exclusive-stack stack reg-name)
  (let ((exclusive-stack (assoc reg-name stack)))
    (if exclusive-stack
      (cdr exclusive-stack)
      (error "Stack not found -- ASSEMBLE" reg-name))))

これで、5.11-aのような(restore n)とやるとスタックがないよ～というエラーがでるようになります。

細々と直していて自分でもどこ直したかわかんなくなってきたので、一応ソースおいときます。
本から写したものと、5.11-b、cのが入ってます。

ダウンロード