2014年1月30日木曜日

SchemeでBrainfuckインタプリタ

さて、Scheme(Racket)でのBrainfuckインタプリタの作成です。
以前にも実は一回書いた事があるってばあるんですが、基本的なエンジンだけの作成で、キチンとしたREPL形式のインタプリタではなかったんですね。
今回はキチンとしたスタンドアローンでREPL構造を持つBrainfuckインタプリタを実装してみたいと思います。

Scheme(R5RS)と例外処理


さて、完全なスタンドアローンのインタプリタを作ろう、って場合、例外処理が欠かせなくなります。何故なら入力が正しく行われなかった場合、システムが落ちてしまって、まあ、みっともないから、ですね。
ところで、Scheme(R5RS)互換でBrainfuckを記述しようとすると、大きな問題に次のような事があり得ます。
Brainfuckの場合、インタプリタと言っても、プロンプトに直接コードを打ち込む事はなく(あっても良いけどちとややこしい事が生じる)、基本的にはコードを記述したテキストファイルを読み込んで解釈実行する、ってスタイルです。つまり、REPLの中で「必ず」ファイルを開く動作を定義しなければなりません。
しかしそこでScheme(R5RS)だとややこしい状態が生じるんですね。「ファイルが存在しない」場合の挙動がイマイチ分からない。

(with-input-from-file string thunk) 省略可能手続き
(with-output-to-file string thunk) 省略可能手続き

string は,一つのファイルを指名する文字列であること。
そして,thunk は,引数をとらない手続きであること。
with-input-from-file では,ファイルが既存であること。
一方,with-output-to-file では,ファイルが既存だった
ときの効果は未規定である。入力または出力のためにファイ
ルが開かれ,それに接続された入力ポートまたは出力ポー
トが,current-input-port またはcurrent-output-port
によって返される(かつ(read),(write obj ) などで使わ
れる) デフォルト値へと仕立てられ,そしてthunk が無引数
で呼び出される。thunk が戻るときには,ポートが閉じられ
て以前のデフォルトが回復される。with-input-from-file
とwith-output-to-file は,thunk がもたらした(1個ま
たは複数個の) 値を返す。もしも脱出手続きが,これらの手
続きの継続から脱出するために使われるならば,これらの手
続きの振舞は実装依存である。

(open-input-file filename) 手続き

既存のファイルを指名する文字列を取り,そして,そのファ
イルからの文字を配送できる入力ポートを返す。もしもファ
イルを開くことができないならば,エラーが通知される。
 つまり、Scheme(R5RS)だと基本的にファイルが存在しない場合はエラーを返し、そいつをまずはトラップすれば良いわけですが、ちとここでSchemeの通知するエラーとは何ぞや、と言う話が出てきます。

1.3.2. エラー状態と未規定の振舞

エラー状態について言うとき,この報告書は“エラーが通知
される” という表現を使って,実装がそのエラーを検出し報
告しなければならないことを示す。もしあるエラーの議論に
そのような言い回しが現れないならば,実装がそのエラーを
検出または報告することは,奨励されているけれども,要求
されていない。実装による検出が要求されていないエラー状
態は,普通ただ単に“エラー” と呼ばれる。
たとえば,ある手続きにその手続きで処理することが明示的
に規定されていない引数を渡すことは,たとえそのような定
義域エラーがこの報告書でほとんど言及されていなくても,
エラーである。実装は,そのような引数を含めるように手続
きの定義域を拡張してもよい。
この報告書は“実装制限の違反を報告してもよい” という表
現を使って,実装の課すなんらかの制限のせいで正当なプロ
グラムの実行を続行できない,と報告することが実装に許さ
れている状況を示す。もちろん実装制限は望ましくないが,
実装が実装制限の違反を報告することは奨励されている。
たとえば実装は,あるプログラムを走らせるだけの十分な記
憶領域がないとき,実装制限の違反を報告してもよい。
もしある式の値が“未規定” (unspecified) であると述べられ
ているならば,その式は,エラーが通知されることなく,な
んらかのオブジェクトへと評価されなければならない。しか
し,その値は実装に依存する。この報告書は,どんな値が返
されるべきかを明示的には述べない。

実はR5RSに載ってる「エラーに関する記述」ってこれだけなんですよ(笑)。あれま。
いや、今まであんま考えて無かったんですが、良く使うエラー提示の"error"って関数も実は存在しなくってあれは実装依存だったんだ、とか今知った所存です(笑)。ダメじゃん(笑)。
つまり、R5RSに関する限り、「エラーを投げる」って事自体が実装依存にならざるを得ないんですね。こう言う事です。


  1. 自分で書いたコードに於いてエラーを通知する手段が用意されていない
  2. Schemeシステムが投げるエラーをトラップする手段がない 
1番に関しては自分で関数を書く(あるいはcall/cc等を使って関数を書く)と言う手段はありますが、2番はとてもややこしいです。
例外処理、と言うのは基本的には「出てきたエラーに対して適切な手段を提示する」わけなんですが、R5RS範疇では「どういうエラーが提示されてるのか」判別する手段が無い。つまり、この辺りは全部Schemeの下のレイヤーで決定されてる、って事になります。
例えばRacketの場合だと、存在しないファイルを開こうとすると、

> (with-input-from-file "./hoge.txt"
(lambda ()
(let loop ((ls '()) (c (read-char)))
(if (eof-object? c)
(reverse ls)
(loop (cons c ls) (read-char))))))
. . with-input-from-file: cannot open input file
path: C:\Users\cametan\Documents\./hoge.txt
system error: 指定されたファイルが見つかりません。; errno=2
>
view raw error.rkt hosted with ❤ by GitHub


なんて返してくるわけですが、一体これをどうやってトラップするのか?Racketだとexnと言う構造体が定義されていて、それを利用してこの場合、exn:fail:filesystem:errnoと言うブツを返すらしいんですが、こんなのが他のシステムにも採用されてる保証はない(Pythonみたいに例外クラスをOOPで定義されてる場合も当然あるでしょう)。これはSRFI34SRFI35SRFI36とか使っても本質的に解決出来る問題だとは思えないのです。
つまり、この辺がR5RSのポータビリティの限界ですね(笑)。もちろん上のSRFIなんかでも上手くラップしてるのかもしれませんが、エラー定義がシステムの内部依存になってるとすれば、おとなしく(笑)システム依存の例外処理機構使った方が良さそうです。
何か負けた気もするんですが(笑)、今回は諦めて、例外処理に関してはRacketが提供しているwith-handlersをおとなしく使う事にします(苦笑)。

Brainfuckの仕様


まあ、当然知ってる人は知ってるでしょうが、Wikipediaの方から改めてBrainfuckの仕様を抜書きしてみます。

  1. > ポインタインクリメントする。ポインタをptrとすると、C言語の「ptr++;」に相当する。
  2. < ポインタをデクリメントする。C言語の「ptr--;」に相当。
  3. + ポインタが指す値をインクリメントする。C言語の「(*ptr)++;」に相当。
  4. - ポインタが指す値をデクリメントする。C言語の「(*ptr)--;」に相当。
  5. . ポインタが指す値を出力に書き出す。C言語の「putchar(*ptr);」に相当。
  6. , 入力から1バイト読み込んで、ポインタが指す先に代入する。C言語の「*ptr=getchar();」に相当。
  7. [ ポインタが指す値が0なら、対応する ] の直後にジャンプする。C言語の「while(*ptr){」に相当。
  8. ] ポインタが指す値が0でないなら、対応する [ (の直後[1])にジャンプする。C言語の「}」に相当[2]

さて、Scheme的に言うと1から6までが「関数」(手続き)そして7番と8番は「特殊形式」(構文、あるいはシンタックス)になりますね。実は1から6までは実装はハナクソなんですが、7と8がややこしい。一体これをどうやってプログラムするのか。
今までParser自体は書いた事があんま無いわけですが、要するにRead部分でBrainfuckのプログラムファイルを読み込んだ時点で、どうやらジャンプ先の候補ってのをマーキングしておいて、それを「パーズと称して」(笑)Evalに渡さなければならないみたいです。この辺はEvalでやる事じゃあなさそうですね。ではやってみますか。

Read の実装

まずはファイルを読み込む関数(read-file)を実装していきます。仕様は次の通りとします。

  1. ファイルを開く。
  2. ストリームから一文字ずつread-charする。その度にカウンターを+1する。
  3. 文字が>、<、+、-、.、,の場合はcodeにconsする。
  4. 文字が[の場合はlsにカウンターの値をpushする。
  5. 文字が]の場合はlsの値をpopして、stackにカウンターの値と(car ls)のペア、(car ls)とカウンターの値のペアをpushする(つまり、stackは連想リストとする)。lsに対応する[の位置情報が無い場合、「カッコの数が合致してない」んでエラーを返す。
  6. 文字がこの8種類以外の場合は無視してread-charする。
  7. ファイル終端に来た場合、ls内に位置情報が残ってる場合、「カッコの数が合致してない」んでエラーを返す。lsが空リストだったら多値として(reverse code)と連想リストstackの二値を返す。
この7つでread-fileは完成です。なお、エラーを返すにはRacket実装依存のraiseを使い、stackへのpushにはSRFI1のalist-consを用います。

(define (read-file file-name)
(with-input-from-file file-name
(lambda ()
(let loop ((counter 0) (code '()) (ls '()) (stack '()) (c (read-char)))
(if (eof-object? c)
(if (null? ls)
(values (reverse code) stack)
(raise 'parenthesis)) ; raise の引数には適当な値を与えられる。これは後の Print 部との兼ね合いを考えてシンボルを与えてる。
(case c
((#\> #\< #\+ #\- #\. #\,) (loop (+ counter 1) (cons c code) ls stack (read-char)))
((#\[) (loop (+ counter 1) (cons c code) (cons counter ls) stack (read-char)))
((#\]) (if (null? ls)
(raise 'parenthesis)
(loop (+ counter 1) (cons c code) (cdr ls)
(alist-cons (car ls) counter (alist-cons counter (car ls) stack)) ; stack には (a . b) と (b . a) の両方を alist-cons を利用して push する
(read-char))))
(else (loop counter code ls stack (read-char)))))))))
view raw read-file.rkt hosted with ❤ by GitHub




さて、read-fileを書き上げたら Read 部本体である parser (実際は parse は read-file がやってるんですが・笑)関数を実装していきます。これは今までのゲームの例のように、インタプリタの現状(phase)に合わせて動作を変更します。次が parser の仕様です。



  1. 関数 parser は x、 phase、 counter、 code、 pointer、 memory、 stackの7つの引数を受け取る関数とする。
  2. parser は phase に従ってその挙動を変えるものとする。なお、phaseの中身は基本的にはシンボルである。
  3. phase が 'read-file だった場合、ユーザーからプロンプトを通じてファイルパスを受け取り、その引数を関数 read-file に受け渡し、返り値を受け取り、多値としてx、 phase、 counter、 code(これは read-file が返したもの)、 pointer、 memory、 stack(これも read-file が返したもの)の7つを返す。
  4. phase が 'read-char だった場合、ユーザーからプロンプトを通じて1文字だけ受け取りそれを新たに x として x、 phase、 counter、 code、 pointer、 memory、 stack の7つの値を多値として返す。
  5. phase が read だった場合、ユーザーからプロンプトを通じて何か受け取り、それを新たに x として x、 phase、 counter、 code、 pointer、 memory、 stack の7つの値を多値として返す。
  6. それ以外の場合は基本的にスルーして、 x、 phase、 counter、 code、 pointer、 memory、 stack の7つの値をそのまま多値として返す。

ゲームの場合もそうですが、「受け取った何らかの入力は」 x に束縛して、それ以外 Read は特に何もやりません。唯一の例外は、 read-file に構文解析させた情報を code と stack に積むのみ、だけですね。あとは phase 情報に従って適切な読み込み系関数を探して実行するだけ、となります。

(define (parser x phase counter code pointer memory stack)
(case phase
((read-file) (let ((i (read)))
(let ((file-name (if (string? i)
i
(symbol->string i))))
(let-values (((code stack) (read-file file-name)))
(values x phase counter code pointer memory stack)))))
((read-char) (values (read-char) phase counter code pointer memory stack))
((read) (values (read) phase counter code pointer memory stack))
(else (values x phase counter code pointer memory stack))))
view raw read.rkt hosted with ❤ by GitHub


では Eval を見て行きましょう。

Eval の実装

まず、Eval の実装を始める前に、インタプリタの動作の振る舞いを決定するステージ、 phase がどんなものになるか決めてしまいましょう。
と言うのも、今までのゲームと違って、今回の brainfuck インタプリタの場合、全体的にREPLとしてイベントループを形成するのはもちろんですが、一旦コードが読まれると基本的には Eval 内で繰り返し処理してから Print 部に渡す為、 phase がどういうステージを持つのかハッキリしないとちと混乱してくるからです。
(しかも、Eval 自体でのループの際、 .命令と,命令があった場合、一旦ループを中断して、Print部とRead部の助けを借りないとならない)


  1. introduction ステージ: インタプリタを起動した際にアプリケーションが自己主張するステージ(まあ無くても良いんですが・笑)
  2. read ステージ: 何らかの入力を外部から読み込むステージ
  3. read-file ステージ: Brainfuck プログラムファイルを読み込むステージ
  4. read-char ステージ: 一文字だけ入力を外部から読み込むステージ
  5. put-char ステージ: 一文字だけ表示するステージ
  6. execute ステージ: Brainfuck プログラムを評価するステージ
  7. break ステージ: 何らかのエラーによってプログラムの実行が中止されたステージ
  8. exception ステージ: エラーに関する表示を行うステージ
基本的には上の8つとなります。
それで、ステージがイベントループの中核になるわけですが、基本的な流れは

introduction -> read -> read-file -> execute -> read -> read-file -> execute -> ...

と言うカンジで、初回だけ introduction が出てきますが、あとは read -> read-file -> execute -> の繰り返しです。 execute 内でたまに、read-char ステージかあるいは put-char ステージが求められる、と言う考え方です。
なお、break ステージだけは Eval が設定しません。これは後で例外処理機構が例外を処理した際に設定するステージとしましょう。それを Eval が見て、exception ステージを設定する、と言う考え方で実装します。
では以下に Eval の簡単な仕様を提示します。

  1. Eval(interp 関数) は x、 phase、 counter、 code、 pointer、 memory、 stack、の7つの引数を受け取る関数とする。
  2. phase が 'introduction だった場合 phase を 'read に変更し、x、 'read、 counter、 code、 pointer、 memory、 stack、の7つを多値として返す。
  3. phase が 'read だった場合、
    1. x(入力値)がquit、exit、または bye だった場合、brainfuck インタプリタを終了する。
    2. x が load、 open、 または read-file だった場合、phase を 'read-file に変更し、x 'read-file counter code pointer memory stack の7つを多値として返す。
    3. それ以外の場合はスルーして、 x、 phase、 counter、 code、 pointer、 memory、 stack の7つを多値としてそのまま返す。
  4. phase が 'read-file だった場合、BrainfuckコードがRead部から読み込まれた事を意味する。すなわち、phase を 'execute に設定し、再帰的に自身を呼び出す。具体的には  x、 'execute、 counter、 code、 pointer、 memory、 stack、を7つの引数として interp 関数を呼び出す。
  5. phase が 'read-char だった場合、pointerが指すメモリの値に 入力値 x を整数に変換した値を足して、phase を 'execute に変更して自身を呼び出す。
  6. phase が 'put-char だった場合、出力が終了した事を意味する。従って、phase を 'excute に変更して自身を呼び出す。
  7. phase が 'execute だった場合、次のように動作する
    1. counterの値がcodeの長さと一致した場合、Brainfuckコードの解釈実行が終了した事を意味する。すなわち初期化として #f、 'read、 0、 #f、 0、 '(0 . 0)、 '()、の7つを多値として返す。
    2. 1でなければ counter の指す code の値を解釈実行する。すなわち、Brainfuckの仕様に従って動作する。
  8. phase が 'break だった場合、phase に 'exception を設定して、x、 'exception、 counter、 code、 pointer、 memory、 stack、の7つを多値として返す。
  9. phase が 'exception だった場合、Brainfuckインタプリタシステムがエラー報告をユーザーに行い終わった事を意味する。従って初期化として #f、 'read、 0、 #f、 0、 '(0 . 0)、 '()、の7つを多値として返す。
  10. それ以外の場合は phase に 'introduction を設定して、x、 'introduction、 counter、 code、 pointer、 memory、 stack の7つを多値として返す。
これが基本動作です。
さて、実際はもっと具体的に5-2がどういう事を行うか、なんですが、ちょっと説明しましょう。
基本的には「全く破壊的操作を行わない」Brainfuck仕様を考えています。Wikipediaの説明を見ると、Brainfuckで扱うメモリとは

少なくとも30000個の要素を持つバイトの配列(各要素はゼロで初期化される)
となってるんですが、そこはSchemeなんで別に上限値を設定する必要はありません。ではどうするのか。
Schemeには連想リストがあるんで、これをメモリに見立ててみれば良い、と言う事です。
つまり初期値として memory と言う引数には '((0 . 0)) と言う「連想リスト」を与えてます。これは「メモリゼロ番地で、初期値は0」と言う意味合いに対応しています。
>と言う命令を見た時、pointerを1増やすわけですが、その時、平たく言うと memory に '(1 . 0) と言うペアをconsしてやる。そうすれば memory は '((1 . 0) (0 . 0)) と言う状態になって、二つの記憶域を持つ状態になります。もう一回 > があれば今度は memory は '((2 . 0) (1 . 0) (0 . 0)) と言う状態になりますね。
つまり、実質的には > は memoryに (pointer . 0) と言うペアを cons する関数だ、と捉え直す事が出来るのです(もちろん、既にポインタが指すペアが存在する場合は新たにペアを cons する必要はありません)。

注: なお、実際はペアを使って cons するのではなく、SRFI1のalist-consを使って cons していきます。
反面、 < は「既に > が作成したメモリ」をたどっていくだけなので新しいメモリ(のペア)を作成する事はありません。単純に pointer の値を -1 するだけです。

注: なお、本当は上の機構を使えば負の番地を持つメモリも実装可能ですが、今回は敢えてやっていません。pointer の値が負になるとエラーを返します。 

+、-は pointer の指す memory を assv して、その cdr に対して加算(+1)ないしは減算(-1)を行います(これを datum とする)。ただし、ここでも破壊的変更を避ける為、memoryから対象のペアを削除して(この削除は破壊的削除ではない)新しく作ったペアを cons します。

注 : 具体的には、Eval( interp 関数)が引数として memory を保持してるので、再帰過程に於いて SRFI1 の alist-delete を使って対象ペアを除いたカタチで memory を取り出し、それに対して pointer と計算し終わったdatum を alist-cons する。すなわち書式は
(alist-cons pointer datum (alist-delete pointer memory)) 
となる。 
. では一旦 interp 関数のループを止めて、ポインタの指すメモリの値を Print 部に渡さないとなりません。
手順としては、


  1. phase を 'put-char にしてループを抜ける宣言をする。
  2. (integer->char (cdr (assv pointer memory))) の値を x に束縛して x、 'put-char、 counter + 1、 code、 pointer、 memory、 stack、の7つを多値として返す。
です。
でこっちは滅多にないんですが、,命令も.に似てますね。

  1. phase を 'read-char にしてループを抜ける宣言をする。
  2. すなわち、 x、 'read-char、 counter + 1、 code、 pointer、 memory、 stack、の7つを多値として返す。
phase が 'put-char、あるいは 'read-char の場合は既に書きました。基本的には phase に 'executeをセットしなおして自身を再帰呼び出しするだけです。ただし、 read-charモードの場合はメモリに入力値を加算しないといけませんが、前述した通り、SRFI の alist-delete と alist-cons を上手く使って破壊的操作を回避します。
最後はループ命令です。
[を見た時、

  1. pointer が指すメモリの値、すなわち (cdr (assv pointer memory)) が0なら stack から counterから飛べる値を探してきて、counter にその値をセットして自身を再帰呼び出しする。  
  2. そうじゃないなら、counterを+1してそのまま処理を継続する。

具体的な話をすると、 stack も連想リストです。これはRead部でread-fileが解析したジャンプ対象の位置情報が入っています。
例えばBrainfuckの何らかのプログラムの4つ目に[があって、41個目に]があった場合、stackは '((4 . 41) (41. 4))と言うカタチで対応を保持しています。そして実行部である Eval (interp 関数)では、code の4つ目で [ を見た場合 (cdr (assv pointer memory)) の値が 0 であるかどうかをチェックして、そうだった場合、カウンターを一気に41へ(正確には]の後ろなんで42)進めます。
]の場合は、無条件に stack が提示する [ の位置へとカウンターを「戻し」ます。先ほどのケースで、stackが'((4 . 41) (41. 4))だった場合、counterが41なんでcounterを (cdr (assv counter stack)) に従って4に戻して interp 関数は自分を再帰呼び出しします。

と言うわけで、Eval ( interp 関数)のコードは以下の通りです。

(define (interp x phase counter code pointer memory stack)
(case phase
((introduction) (values x 'read counter code pointer memory stack))
((read) (case x
((quit exit bye) (exit))
((load open read-file) (values x 'read-file counter code pointer memory stack))
(else (values x 'read counter code pointer memory stack))))
((read-file) (interp x 'execute counter code pointer memory stack))
((read-char) (let ((datum (+ (cdr (assv pointer memory)) (char->integer x))))
(interp x 'execute counter code pointer (alist-cons pointer datum memory) stack)))
((put-char) (interp x 'execute counter code pointer memory stack))
((execute) (if (= counter (length code))
(values #f 'read 0 #f 0 '((0 . 0)) #f)
(case (list-ref code counter)
((#\>) (let ((ptr (+ pointer 1)))
(let ((apair (assv ptr memory)))
(interp x phase (+ counter 1) code ptr (if apair
memory
(alist-cons ptr 0 memory)) stack))))
((#\<) (let ((ptr (- pointer 1)))
(if (negative? ptr)
(raise 'under-flow)
(interp x phase (+ counter 1) code ptr memory stack))))
((#\+) (let ((datum (+ (cdr (assv pointer memory)) 1)))
(interp x phase (+ counter 1) code pointer (alist-cons pointer datum (alist-delete pointer memory)) stack)))
((#\-) (let ((datum (- (cdr (assv pointer memory)) 1)))
(interp x phase(+ counter 1) code pointer (alist-cons pointer datum (alist-delete pointer memory)) stack)))
((#\.) (let ((datum (integer->char (cdr (assv pointer memory)))))
(values datum 'put-char (+ counter 1) code pointer memory stack)))
((#\,) (values x 'read-char (+ counter 1) code pointer memory stack))
((#\[) (let ((datum (cdr (assv pointer memory))) (apair (assv counter stack)))
(interp x phase (+ (if (zero? datum)
(cdr (assv counter stack))
counter) 1) code pointer memory stack)))
((#\]) (interp x phase (cdr (assv counter stack)) code pointer memory stack)))))
((break) (values x 'exception counter code pointer memory stack))
((exception) (values #f 'read 0 #f 0 '((0 . 0)) '()))
(else (values x 'introduction counter code pointer memory stack))))
view raw eval.rkt hosted with ❤ by GitHub




では最後にPrint部です。

Print の実装

Print部は相変わらず簡単です。単純に言うとメッセージを大域変数で連想リストとして設定して、phase の条件に従ってassvで検索したペアの cdr を表示すれば良い。そしてその後、返り値を返します。
Print部に直接関連した phase は


  1. introduction
  2. read-char
  3. read-file
  4. put-char
  5. exception
の5つで、そのうち1、2,3は纏められて、4、5も纏められます。

まずは大域変数 *messages* を設定します。

(define *messages*
'((prompt . "brainfuck ==> ")
(read-char . "enter a character? ==>")
(read-file . "load? ==> ")
(introduction . "\nA Brainfuck up interpreter fuckin' impremented with Scheme the Fuck\nCopyTheFuckLeft by Cametan in the fuckin' year 2014\n")
))
view raw messages.rkt hosted with ❤ by GitHub


1、2、3のケースだと単純に (cdr (assq phase *messages*)) を表示すれば良いだけですし(何のために *messages* のキーと phase の値に互換性を持たせてるのか、と言うとこの為です!)、4、5の場合は Eval ( interp 関数)が渡してきた x を表示すれば良い。あとは、プロンプトを表示するだけなんで、Print 部は次のように簡単に書けます。

(define (print x phase counter code pointer memory stack)
(case phase
((introduction read-char read-file) (display (cdr (assq phase *messages*))))
((put-char exception) (display x))
(else (newline) (display (cdr (assq 'prompt *messages*)))))
(values x phase counter code pointer memory stack))
view raw print.rkt hosted with ❤ by GitHub


これで、BrainfuckのREPL各部位は完成しました。あとは実際REPLとして組み上げるだけです。

REPL と例外処理

まあ、前からやってる通り、単純にはSchemeのSRFI11を利用して多値関数同士を結んで末尾再帰でREPLを書くだけで良いんですが、各関数(っつーかReadとEval)は場合によっては例外を throw しますが、一方、例外を catch してシステムを安全にする機構は組み上げてません。
平たく言うと、REPL部でそれをやってしまおう、って事です。
まずは、例外処理無しのREPLをひな形として組んでみます。

(define (repl x phase counter code pointer memory stack)
(let-values (((x phase counter code pointer memory stack) (parser x phase counter code pointer memory stack)))
(let-values (((x phase counter code pointer memory stack) (interp x phase counter code pointer memory stack)))
(let-values (((x phase counter code pointer memory stack) (print x phase counter code pointer memory stack)))
(repl x phase counter code pointer memory stack)))))


これでも充分動くんですが、例えば「存在しないファイル」を開こうとすると当然エラーが出てシステムは落ちてしまいます。

A Brainfuck up interpreter fuckin' impremented with Scheme the Fuck
CopyTheFuckLeft by Cametan in the fuckin' year 2014
brainfuck ==> load
load? ==> ./hoge.txt
. . with-input-from-file: cannot open input file
path: C:\Users\cametan\Documents\./hoge.txt
system error: 指定されたファイルが見つかりません。; errno=2
>
view raw error.rkt hosted with ❤ by GitHub


システムが落ちる、とはどういう事か。継続よろしく、エラーと言うのは発生するとトップレベルに強制的に戻される(つまり関数内から抜ける)、って事になるわけですね。
つまり、言い方を変えると、例外処理と言うのはトップレベルに戻る前にそのエラーをまずは「捕まえる」仕組みです。そして捕まえたらそのエラーの種類に従って、適切な処置を施す。
この場合、REPL内でエラーが投げられるわけですが、どういう処理が必要かと言うと、大枠的には「REPL内に戻る」事になります。何故かと言うとインタプリタ内でエラーが起きて別のプログラムが走ったりすればこれは困ります(笑)。インタプリタでエラーが起きたらインタプリタに戻って欲しい。
言い換えると

エラーが起きた -> でもインタプリタ(REPL)に戻る

ってのが「エラーに対する適切な処置」になるわけです。
基本的にはどんなエラーが起きてもインタプリタに戻って構わないんですが、一応「どんなエラーが起きたか」ユーザーに示さないといけない(利便性の問題です)。その為に「どんなエラーが起きたのか」知る必要があって、その為のエラートラップになるわけですね。
今まで組み上げたプログラムを見ると(想定された)エラーの種類、ってのは次の通りです。


  1. read-file 内で起きた「ファイルが見つかりません」エラー
  2. read-file 内で起きた「カッコの数が合いません」エラー
  3. eval内で起きた「pointerの値が負の数です」エラー
この3つが想定されてるエラーです。1番はScheme(より正確に言うとRacket)組み込みのエラー、2番と3番はプログラマ側が決めたエラーです。
でこれを実装する為にRacketの with-handlers を用います。 with-handlersの構文は次のようになっています。

( with-handlers ((述語 エラー処理) ...)    (本体))
つまり、まず構文的には、(let-values ... で形成されたREPLの本体を(with-handlers で包んでやれば良い、って事になる。
加えると、述語なんですが、要するにこれがエラー種類を判定する述語です。
先にも書きましたが、1. のケースだとRacket自体が「どういう種類のエラーなのか」定義してる部分で、これはプログラマ側でどーにか変更する、ってモノじゃありません。リファレンスで調べなきゃいけない範疇となります(笑)。で、exn:fail:filesystem:errno ってのがそのエラーの型で exn:fail:filesystem:errno? がその述語になります(ちなみに exn 自体は変数扱いになるようです)。
2番と3番がプログラマ側が定義したエラーで、raise で定義した・・・事実上、定義したエラーになります。何を定義したのか、と言うと raise に与えた引数がその型を定義してる、って言って過言じゃないです。何故 read-file や interp で使った raise にシンボルを引数として与えたのか、と言う理由がここにあります。
と言うのも、シンボルを引数にして与えた raise によるユーザー定義のエラーの場合、述語は単純にラムダ式となって

(lambda (v) (eq? '何かのシンボル v))

と書ける。一般にSchemeを含むLisp族はシンボルはユニーク(単一しか存在し得ない)である事が保証されていて、しかも eq? による比較は高速で決着が付く。これを考えると raise する場合は圧倒的にシンボルを引数に与えた方が得だ、って事になりますね。
そして、 with-handlers のエラー処理もラムダ式で記述します。
気を付けないといけないのは、この場合のラムダ式の引数は述語部分の引数(あるいは変数)と同じじゃないといけません。
つまり、組み込みエラーの場合は ext がシンボルなんでエラー処理部分のラムダ式の引数は ext 、他の場合は自分で決めたもの、例えば述語部位が v を使ってたらエラー処理部分のラムダ式の引数も v にする、って事ですね。
さて、さっきも書いた通り、エラー処理自体は「REPLに戻るのが前提」と書きました。ここで整理すると、

  1. x はPrint部の為に「こう言うエラーが起きました」と言う文字列情報を入れる。
  2. phase は 'break にセットする。
  3. あとの引数は(どの道 Eval が初期化する前提なんで)手を付けない。
  4. 以上の情報を持ってREPLを再度呼び出す
となります。つまり、エラー処理のラムダ式は原則

(lambda (引数) (repl エラー情報文字列 'break counter code pointer memory stack))

になる、って事を意味します。
これを考慮してREPLを修正します。

(define (repl x phase counter code pointer memory stack)
(with-handlers ((exn:fail:filesystem:errno? ; ファイルが存在しない場合のエラー処理
(lambda (ext) (repl "the file not found" 'break counter code pointer memory stack)))
((lambda (v) (eq? v 'parenthesis)) ; カッコの数が合わない場合のエラー処理
(lambda (v) (repl "number of parenthesis doesn't match" 'break counter code pointer memory stack)))
((lambda (v) (eq? v 'under-flow)) ; ポインタが負の値になった場合のエラー処理
(lambda (v) (repl "pointer under flow" 'break counter code pointer memory stack)))
)
(let-values (((x phase counter code pointer memory stack) (parser x phase counter code pointer memory stack)))
(let-values (((x phase counter code pointer memory stack) (interp x phase counter code pointer memory stack)))
(let-values (((x phase counter code pointer memory stack) (print x phase counter code pointer memory stack)))
(repl x phase counter code pointer memory stack))))))
view raw repl.rkt hosted with ❤ by GitHub


これで、仮に「存在しないファイル」をREPLで開いた場合でも、Brainfuckインタプリタは落ちないで、そのまま処理を継続します。

A Brainfuck up interpreter fuckin' impremented with Scheme the Fuck
CopyTheFuckLeft by Cametan in the fuckin' year 2014
brainfuck ==> load ; load 指令を出す
load? ==> ./hoge.txt ; 存在しないファイルを指定する
the file not found ; どんなエラーがあったのか表示
brainfuck ==> ; またプロンプトへと戻る


以上でBrainfuckインタプリタの完成です。以下に全コードを載せておきます。

#lang racket
(require srfi/1 srfi/11)
;;;;; Read
(define (read-file file-name)
(with-input-from-file file-name
(lambda ()
(let loop ((counter 0) (code '()) (ls '()) (stack '()) (c (read-char)))
(if (eof-object? c)
(if (null? ls)
(values (reverse code) stack)
(raise 'parenthesis))
(case c
((#\> #\< #\+ #\- #\. #\,) (loop (+ counter 1) (cons c code) ls stack (read-char)))
((#\[) (loop (+ counter 1) (cons c code) (cons counter ls) stack (read-char)))
((#\]) (if (null? ls)
(raise 'parenthesis)
(loop (+ counter 1) (cons c code) (cdr ls)
(alist-cons (car ls) counter (alist-cons counter (car ls) stack))
(read-char))))
(else (loop counter code ls stack (read-char)))))))))
;;; read-file-test
;(read-file "./helloworld.txt")
;(let-values (((a b) (read-file "./quine.txt")))
; (values a (length a) b))
(define (parser x phase counter code pointer memory stack)
(case phase
((read-file) (let ((i (read)))
(let ((file-name (if (string? i)
i
(symbol->string i))))
(let-values (((code stack) (read-file file-name)))
(values x phase counter code pointer memory stack)))))
((read-char) (values (read-char) phase counter code pointer memory stack))
((read) (values (read) phase counter code pointer memory stack))
(else (values x phase counter code pointer memory stack))))
;;; Read-test
;(parser #f #f 0 #f 0 '((0 . 0)) #f)
;(parser #f 'introduction 0 #f 0 '((0 . 0)) #f)
;(parser #f 'read 0 #f 0 '((0 . 0)) #f)
;(parser #f 'read-file 0 #f 0 '((0 . 0)) #f)
;(parser #f 'read-char 0 #f 0 '((0 . 0)) #f)
;(parser #f 'put-char 0 #f 0 '((0 . 0)) #f)
;;;;; Eval
(define (interp x phase counter code pointer memory stack)
(case phase
((introduction) (values x 'read counter code pointer memory stack))
((read) (case x
((quit exit bye) (exit))
((load open read-file) (values x 'read-file counter code pointer memory stack))
(else (values x 'read counter code pointer memory stack))))
((read-file) (interp x 'execute counter code pointer memory stack))
((read-char) (let ((datum (+ (cdr (assv pointer memory)) (char->integer x))))
(interp x 'execute counter code pointer (alist-cons pointer datum memory) stack)))
((put-char) (interp x 'execute counter code pointer memory stack))
((execute) (if (= counter (length code))
(values #f 'read 0 #f 0 '((0 . 0)) #f)
(case (list-ref code counter)
((#\>) (let ((ptr (+ pointer 1)))
(let ((apair (assv ptr memory)))
(interp x phase (+ counter 1) code ptr (if apair
memory
(alist-cons ptr 0 memory)) stack))))
((#\<) (let ((ptr (- pointer 1)))
(if (negative? ptr)
(raise 'under-flow)
(interp x phase (+ counter 1) code ptr memory stack))))
((#\+) (let ((datum (+ (cdr (assv pointer memory)) 1)))
(interp x phase (+ counter 1) code pointer (alist-cons pointer datum (alist-delete pointer memory)) stack)))
((#\-) (let ((datum (- (cdr (assv pointer memory)) 1)))
(interp x phase(+ counter 1) code pointer (alist-cons pointer datum (alist-delete pointer memory)) stack)))
((#\.) (let ((datum (integer->char (cdr (assv pointer memory)))))
(values datum 'put-char (+ counter 1) code pointer memory stack)))
((#\,) (values x 'read-char (+ counter 1) code pointer memory stack))
((#\[) (let ((datum (cdr (assv pointer memory))) (apair (assv counter stack)))
(interp x phase (+ (if (zero? datum)
(cdr (assv counter stack))
counter) 1) code pointer memory stack)))
((#\]) (interp x phase (cdr (assv counter stack)) code pointer memory stack)))))
((break) (values x 'exception counter code pointer memory stack))
((exception) (values #f 'read 0 #f 0 '((0 . 0)) '()))
(else (values x 'introduction counter code pointer memory stack))))
;;; Eval-test
;(define code (string->list "+++++++++[>++++++++>+++++++++++>+++++<<<-]>.>++.+++++++..+++.>-.------------.<++++++++.--------.+++.------.--------.>+."))
;(interp #f #f 0 #f 0 '((0 . 0)) '((9 . 41) (41 . 9)))
;(interp #f 'introduction 0 #f 0 '((0 . 0)) '((9 . 41) (41 . 9)))
;(interp 'exit 'read 0 #f 0 '((0 . 0)) '((9 . 41) (41 . 9)))
;(interp 'load 'read 0 #f 0 '((0 . 0)) '((9 . 41) (41 . 9)))
;(interp #f 'read-file 0 code 0 '((0 . 0)) '((9 . 41) (41 . 9)))
;(interp #f 'execute 0 code 0 '((0 . 0)) '((9 . 41) (41 . 9)))
;(interp #\H 'put-char 44 code 1 '((0 . 0) (3 . 45) (2 . 99) (1 . 72)) '((9 . 41) (41 . 9)))
;(define quine (string->list "->++>+++>+>+>+++>>>>>>>>>>>>>>>>>>>>>>+>+>++>+++>++>>+++>+>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>+>+>>+++>>>>+++>>>+++>+>>>>>>>++>+++>+++>+>>+++>+++>+>+++>+>+++>+>++>+++>>>+>+>+>+>++>+++>+>+>>+++>>>>>>>+>+>>>+>+>++>+++>+++>+>>+++>+++>+>+++>+>++>+++>++>>+>+>++>+++>+>+>>+++>>>+++>+>>>++>+++>+++>+>>+++>>>+++>+>+++>+>>+++>>+++>>+[[>>+[>]+>+[<]<-]>>[>]<+<+++[<]<<+]>>>[>]+++>+[+[<++++++++++++++++>-]<++++++++++.<]"))
;(interp #f 'execute 0 quine 0 '((0 . 0))'((367 . 403) (403 . 367) (369 . 389) (389 . 369) (359 . 361) (361 . 359) (321 . 355) (355 . 321) (349 . 351) (351 . 349) (340 . 342) (342 . 340) (322 . 337) (337 . 322) (332 . 334) (334 . 332) (326 . 328) (328 . 326)))
;;;;; Print
(define *messages*
'((prompt . "brainfuck ==> ")
(read-char . "enter a character? ==>")
(read-file . "load? ==> ")
(introduction . "\nA Brainfuck up interpreter fuckin' impremented with Scheme the Fuck\nCopyTheFuckLeft by Cametan in the fuckin' year 2014\n")
))
(define (print x phase counter code pointer memory stack)
(case phase
((introduction read-char read-file) (display (cdr (assq phase *messages*))))
((put-char exception) (display x))
(else (newline) (display (cdr (assq 'prompt *messages*)))))
(values x phase counter code pointer memory stack))
;;;;; REPL
(define (repl x phase counter code pointer memory stack)
(with-handlers ((exn:fail:filesystem:errno?
(lambda (ext) (repl "the file not found" 'break counter code pointer memory stack)))
((lambda (v) (eq? v 'parenthesis))
(lambda (v) (repl "number of parenthesis doesn't match" 'break counter code pointer memory stack)))
((lambda (v) (eq? v 'under-flow))
(lambda (v) (repl "pointer under flow" 'break counter code pointer memory stack)))
)
(let-values (((x phase counter code pointer memory stack) (parser x phase counter code pointer memory stack)))
(let-values (((x phase counter code pointer memory stack) (interp x phase counter code pointer memory stack)))
(let-values (((x phase counter code pointer memory stack) (print x phase counter code pointer memory stack)))
(repl x phase counter code pointer memory stack))))))
(repl #f #f 0 #f 0 '((0 . 0)) #f) ; 初期値はこのようにして与える
view raw brainfuck2.rkt hosted with ❤ by GitHub




Racket で実行形式作成

以前から Racket には raco と言うコンパイラが付属してたんですが、コマンドラインツールだし、何かメンドくせえし(笑)、とかでスタンドアローンでの実行形式作るのは諦めてたんですね。
しかし最近、とうとう DrRacket IDEからメニューから選んで実行形式が作れるようになる、と大進歩を遂げました。Lisp系言語だと「スタンドアローンは作りづらい」って言われてたんですが、ここに来てやっとLispプログラムの恩恵を一般に配布しやすくなった、って言って良いでしょう。
ただ、残念なのは、どうもユニコードの問題があって、日本語なんかの文字列が入ってるとコンパイラが通ってもすぐ落ちたりしちゃうんですね(今回、メッセージ表記を全て英語にしたのはそのせいです)。

ファイルを保存してからDr.Racketの [Racket] メニューから [実行ファイルの作成...]を選びます。


そうするとポップアップメニューが現れます。


Typeに関しては一番下のDistributionを使えば良いでしょう。と言うのも、これがアプリの配布形式を作るブツだからです。

注: 一番目のブツは平たく言うとエイリアスを作るだけで、コンパイルして実行形式を作るとはいえない。二番目はコンパイルは行うが、その実行にはRacket本体が必要で、要するにいわゆる「ランタイム」を含めた実行形式を作成するには3番目のDistributionしかなく、配布目的、あるいは完全なスタンドアローンを作るならこれを利用するしかなくなる。

 BaseもRacketを使えば良いです(GRacketはRacket(コマンドライン版)のちょっとしたGUI版程度です)。
あとは [作成] ボタンを押せば自動的に実行形式を含むzipファイルを作成してくれます(圧縮までしてくれるたぁ何て親切・笑!)

Brainfuck の大きさ

Wikipediaによると

開発者Urban Müllerがコンパイラがなるべく小さくなる言語として考案した。 実際、Müllerが開発したコンパイラのサイズはわずか123バイトインタプリタは98バイトであった。
なんだそうなんですが、Schemeで書いたBrainfuckインタプリタの実行形式は何と5.09メガバイトもありました(笑)。何と53倍弱の大きさです(笑)。いやあ、富豪の時代ですねぇ(笑)。
これ、twitterでも笑って言ってたんですが(笑)。5.09メガバイトって事はフロッピーディスク一枚に収まらないんですよ(笑)。何枚くらいになるんだろ・・・まあフロッピー四枚くらいで、90年代前半だとゲームで多くてフロッピー二枚、四枚なんて殆どOS並の「大きさ」なんです。
これやってみたらやっぱ長い間Lisp系言語が人気無かったのは分かりますね。Brainfuckくらいの単純なインタプリタでも書いちゃうとOS並の大きさになっちゃう、ってのは20年くらい前のPCだとマジで死活問題です(笑)。いやあ、今の時代は良い時代ですねぇ(笑)。

ってなわけで、実行形式へのリンクも貼っておきますね。


2014年1月27日月曜日

REPL VS. MVC

さて、次のようなwxPythonを使った記事があります。

ModelViewController

これはwx.lib.pubsubと呼ばれるライブラリを使ってMVCパターンでGUIアプリを作る例なんですが、かなり錯綜してるように見えますね。
基本的には


  1. ModelがsendMessageメソッドを用いてインスタンス変数を(相手が誰か分からないにせよ)メッセージとして送信する。
  2. ControllerがView(あるいはフレーム)のインスタンスを保持してる。
  3. Controllerがsubscribeメソッドを用いてメッセージを受信する。
  4. ControllerがViewをチェンジする。
となってて、Controllerの仕事が多すぎますし、全てがControllerに依存しています。
これが「望むべくMVCの書き方」なのか、って言われると、理論的には「?」なんじゃないんでしょうか。ちょっと釈然としませんね。
ところがこれが、クラス同士の通信、って概念で考えると、結構既存のGUIフレームワークとMVCの相性って良くねぇんじゃねえの、とか色々試行錯誤した結果思いました。REPLだとreturnで結んだRead、Eval、Print同士が仲良く、ある種イベントループを作り上げるんですが、現状のGUIフレームワークだと、恐らくそのルーツはVisual Basicらしいんですが、要するにフレームに「各種メソッドが個別にぶら下がってる」モデルがベースな為、実はREPL構造とは相性が悪い。悪いくせにMVCなんてやると結構大変ですね。
本当はMVCパターンを狙うならMVCに適したGUIフレームワークが必要なのかもしれません。ハッキリ言えばREPLを写像する、ってアイディアから言うとGUIフレームワークが用意してるイベントループが邪魔なんですよね。REPLだと自分でイベントループを簡単に書けちゃうし、またクラス同士の独立性も高まります。ひょっとしたら低レベルツールを使えば何とかなるのかもしれませんが、いずれにせよ、恐らく、現代の多くのGUIフレームワークは元々「個別のイベントとそれが関与してるメソッド」を「ぶら下げる」為に本体自体がイベントループを用意せざるを得なかったんでしょう。

ここんとこやってたのはREPLのMVCへの写像がテーマです。つまり、キチンとしたREPLを持つCLIのアプリケーションを書いて、そのCLIアプリケーションを最小限の努力でGUI化するにはどうすれば良いかを考えてました。なかなかこれが苦戦してたんですが、ある程度の方針が分かりました。それは次のようなモノです。

  1. ViewにはControllerのインスタンスを埋め込む。
  2. ControllerにはModelのインスタンスを埋め込む。
  3. Modelは返り値を返す(returnする)。
  4. ViewはControllerのインスタンス.メソッドを引数を付けて呼び出して、その返り値を利用して何かしら表示する。
  5. GUIフレームワークのイベントループにはViewのインスタンスを渡す。
  6. 環境情報等は極論Viewが保持する(もちろん環境クラスを作っても良いが、そのインスタンスはViewで管理する)。
の6つですね。これなら比較的REPLの構造を崩さないで済みます。
ただ、Viewに環境等の情報を埋め込む限り、破壊的操作は避けられないと言うデメリットが生じますが、これは現行のGUIフレームワークを用いる以上、しょうがないでしょう。
では、実際に前出のwxPythonを用いたMVCの例に従って、GUIで(大した事はないですが)アプリケーションを組んでいきましょう。

CLIのアプリケーションを作る


まずは、上記のアプリと同じように動くCLIのアプリケーションをREPLモデルで組み上げます。まあ、アプリケーションって程大したプログラムでもないんですが、一方、MVCにどうやってコンバートするのか、と言うのを見るには単純な方が良いんで、まあいいでしょう。
次のコードがCLI版になります。

# -*- coding: utf-8 -*-
import sys
class Read:
def __init__(self):
pass
def addMoney(self):
return 10
def removeMoney(self):
return -10
def parse(self, y):
return self.parseAux(raw_input(), y[1])
def parseAux(self, x, env):
if x == u'Add Money':
return self.addMoney(), env
elif x == u'Remove Money':
return self.removeMoney(), env
else:
return [], env
class Eval:
def __init__(self):
pass
def interp(self, y):
x, env = y[0], y[1]
try:
return x + env, x + env
except TypeError:
sys.exit()
class Print:
def __init__(self):
pass
def display(self, y):
x, env = y[0], y[1]
print x
return x, env
class REPL:
def __init__(self):
pass
def do(self, env = (False, 0)):
r = Read()
e = Eval()
p = Print()
while env:
env = p.display(e.interp(r.parse(env)))
if __name__ == "__main__":
repl = REPL()
repl.do()
view raw repl.py hosted with ❤ by GitHub




ホント大した事がないんですが、それでも重要な事があります。それはこれです。

Pythonの場合、継承目的で作成してメソッドを全部子クラスに継承させたい場合、プライベートメソッド(アンダーバー二つ__で始まるアレ)は作らない

です。これ、どういう理由なんだか知らないんですが、プライベートメソッドにしちゃうと、Pythonだと子クラスに継承出来ないんですね。色々Pythonに関して調べてみたんですが、どういう理由でこうなってるのか分かりません。

注: Twitterで教えてもらったんですが、通常、OOPな言語の場合(例えばC#)、「他から呼び出されたくなくても、子クラスに継承したい場合のメソッドではプライベートじゃなくってProtectedメソッドにする模様です。 

まあそれさえ気を付ければ良い、って事ですね。
ではこれをひな形にして、MVCによるGUI版を作っていきます。

Qt Designer

原版はwxWidgetで作られていたんですが、今回はPySideと言うQtのPythonバインディングを用います。Qt知らない人はあんまいないと思うんですが、一応説明すると、Googleのアプリケーションなんかでも用いられているC++で書かれたマルチプラットフォームのGUIフレームワークで、他にはLinuxのKDEを作ってるツールって事で有名ですね。wxWidgetなんかに比べても高機能だと言われています。
Windowsの場合、PySideをインストールすると、C:\Python27\Lib\site-packages\PySide\にdesigner.exe、つまりQt Designerと言うGUI Builderが入ってますんで、これ使ってサクサクとまずはFrameを作っていきます。


Qt Desingerを起動すると次のようなポップアップが現れます。


Dialog without Buttonsを選んで[Create]ボタンを押します。


左側にあるWidget Boxから、LabelLCDNumberButton二つをドラックアンドドロップで持ってきて、適当に次のようにDialog上に配置します。


んで、レイアウト調整なんですが、上のツールバーにこの手のボタンが並んでるんですが。


例えばボタン二個をCtrl押しながらマウスで選択して、一番左のボタン(Lay Out Horizontally)とか押すと、ボタン二個がキチンと並んで、かつその状態(ボタン二個が入った大枠)を引き伸ばしたりして大きさ調整出来るんですね。


同様に、Label、LCDNumber、そしてボタンの大枠を全部選択してLay Out in a Gridボタンを押すと次のようになって、また大枠を引き伸ばせます。



Formプルダウンメニューから[Preview...]を選べば、今の状態が実際にどんなもんなのか見る事が出来ます。


ちとLabelが大きすぎるので、Labelを選択して、右側のPropertyからSize Policyを探しだして、Vertical PolicyFixedにします。



うん、イイ感じになってきました。
LabelがTextLabelと言う名称で左寄せなんで、これをMy Moneyと改名して中央寄せにしたい。その場合は、さっきのように、Labelを選んで、右側のPropetyTextでTextLabel -> My Moneyと変更、AlignmentHorizontalAlignCenterにします。


DialogのWindowTitleをMain Viewに変更したいので、右上のObject Inspectorからdialogを選択、またもやPropertyからWindowTitleを探しだしてMain Viewに変更します。


ボタンの名前も変えましょう。これも例によってPropetyを使います。TextをそれぞれAdd Money、Remove Moneyに変更します。


ここまで来ればあと一歩、です。Qtにはシグナルとスロットって機構がありまして、要するにボタンが押された時適切なメッセージを出して任意のメソッドに繋ぐ(スロット)わけですが、そのひな形もQt Designer上で作ります。
[Edit]プルダウンメニューから[Edit Signals/Slots]を選択してQt Designerのモードをシグナル/スロット編集モードにします。


さて、そうすると任意のボタンをとあるスロットに繋ぐわけですが、このシグナル/スロットモードでは、GUIでそれを抽象的に扱う事が出来ます。例えばAdd Moneyボタンをドラッグしようとするとヘンな矢印が出てくるんですね。これが「特定のメソッドへの接続」を表します。


マウスを離すとConfigure Connectionと言うポップアップが現れます。


ちょっと見れば分かるんですが、左側が「ボタンの動作」、右側が「ボタンの動作に従った望まれるメソッド」が並んでて、例えば左にあるclicked()ってメソッドは「ボタンがクリックされたら」ですね。つまり、「何かが成されたら(右側にある)何かをしろ」と言う関係になっています。
右側にはQtで想定されてるデフォルトの動作が並んでるんですが、ここではbuttonClicked()と言うメソッドを(まだ書いてないけど)新たに追加して、そいつと左側のclicked()を結びましょう。
右側の[Edit...]ボタンをクリックします。


上がスロット、下がシグナルになっています。今回はシグナルは使わないんで、上のスロットの+ボタンを押してbuttonClicked()と言うメソッドを追加します。


[OK]ボタンを押してConfigure Connectionに戻ります。左側からClick()を選択、右からbuttonClicked()を選択、[OK]ボタンを押します。



同様にして、Remove Moneyボタンも同じbuttonClicked()メソッドに繋いでしまいます。


これで準備はO.K.です。まずはui_mvctest.uiとでも名づけて、GUIデザインを保存しましょう。
Qt Designerではxmlファイルとしてデザインが保存されます。

<?xml version="1.0" encoding="UTF-8"?>
<ui version="4.0">
<class>dialog</class>
<widget class="QDialog" name="dialog">
<property name="geometry">
<rect>
<x>0</x>
<y>0</y>
<width>400</width>
<height>300</height>
</rect>
</property>
<property name="windowTitle">
<string>Main View</string>
</property>
<widget class="QWidget" name="">
<property name="geometry">
<rect>
<x>10</x>
<y>20</y>
<width>381</width>
<height>271</height>
</rect>
</property>
<layout class="QGridLayout" name="gridLayout">
<item row="0" column="0">
<widget class="QLabel" name="label">
<property name="sizePolicy">
<sizepolicy hsizetype="Preferred" vsizetype="Fixed">
<horstretch>0</horstretch>
<verstretch>0</verstretch>
</sizepolicy>
</property>
<property name="text">
<string>My Money</string>
</property>
<property name="alignment">
<set>Qt::AlignCenter</set>
</property>
</widget>
</item>
<item row="1" column="0">
<widget class="QLCDNumber" name="lcdNumber"/>
</item>
<item row="2" column="0">
<layout class="QHBoxLayout" name="horizontalLayout">
<item>
<widget class="QPushButton" name="pushButton">
<property name="text">
<string>Add Money</string>
</property>
</widget>
</item>
<item>
<widget class="QPushButton" name="pushButton_2">
<property name="text">
<string>Remove Money</string>
</property>
</widget>
</item>
</layout>
</item>
</layout>
</widget>
</widget>
<resources/>
<connections>
<connection>
<sender>pushButton</sender>
<signal>clicked()</signal>
<receiver>dialog</receiver>
<slot>buttonClicked()</slot>
<hints>
<hint type="sourcelabel">
<x>123</x>
<y>230</y>
</hint>
<hint type="destinationlabel">
<x>192</x>
<y>262</y>
</hint>
</hints>
</connection>
<connection>
<sender>pushButton_2</sender>
<signal>clicked()</signal>
<receiver>dialog</receiver>
<slot>buttonClicked()</slot>
<hints>
<hint type="sourcelabel">
<x>290</x>
<y>227</y>
</hint>
<hint type="destinationlabel">
<x>353</x>
<y>261</y>
</hint>
</hints>
</connection>
</connections>
<slots>
<slot>buttonClicked()</slot>
</slots>
</ui>
view raw ui_mvctest.ui hosted with ❤ by GitHub


んで、まずはこいつをPythonで解釈出来るpyファイルに変換せなアカンのですね。んで、その為のツールが、例えばWindowsならC:\Python27\Scripts\にpyside-uic.exeと言う名前でインストールされてる筈なんですが、どーゆーわけかコイツはコマンドラインのアプリケーションとなっています(苦笑)。何故にQt Designerから直接呼び出して変換出来ないのかサッパリ分かりません(苦笑)。
(wxGladeならGUIでPythonコードに変換してくれます!)
Linuxならこの手のツールがあっても、コマンドラインが使いやすいんでイイんですが、ことさらWindowsのコマンドラインは使いづらいんですよねぇ。パス記述するのがおうおうにして厄介です。
まあ、しょうがないんですが、基本的には完全パス与えて実行した方が良さそうです。例えばこの場合ですと、

C:\Python27\Scripts\pyside-uic.exe -o プロジェクトフォルダ\ui_mvctest.py プロジェクトフォルダ\ui_mvctest.ui

でしょうか。オプション引数 -oを忘れないようにしましょう。また、こう言うのがホント気になるんですが、変換後のファイル、元ファイル、の順序です(普通の発想なら元ファイル -> 変換後のファイル、になるんじゃねえの?とか思うんですが、しばしばこう言う「語順」を見かける)。
さて、無事に変換が済めば、PySide用に変換されたpyファイルが出来てる筈です。

# -*- coding: utf-8 -*-
# Form implementation generated from reading ui file 'c:\Users\cametan\Documents\Python\project\MVCtest\ui_mvctest.ui'
#
# Created: Mon Jan 27 07:30:54 2014
# by: pyside-uic 0.2.15 running on PySide 1.2.1
#
# WARNING! All changes made in this file will be lost!
from PySide import QtCore, QtGui
class Ui_dialog(object):
def setupUi(self, dialog):
dialog.setObjectName("dialog")
dialog.resize(400, 300)
self.widget = QtGui.QWidget(dialog)
self.widget.setGeometry(QtCore.QRect(10, 20, 381, 271))
self.widget.setObjectName("widget")
self.gridLayout = QtGui.QGridLayout(self.widget)
self.gridLayout.setContentsMargins(0, 0, 0, 0)
self.gridLayout.setObjectName("gridLayout")
self.label = QtGui.QLabel(self.widget)
sizePolicy = QtGui.QSizePolicy(QtGui.QSizePolicy.Preferred, QtGui.QSizePolicy.Fixed)
sizePolicy.setHorizontalStretch(0)
sizePolicy.setVerticalStretch(0)
sizePolicy.setHeightForWidth(self.label.sizePolicy().hasHeightForWidth())
self.label.setSizePolicy(sizePolicy)
self.label.setAlignment(QtCore.Qt.AlignCenter)
self.label.setObjectName("label")
self.gridLayout.addWidget(self.label, 0, 0, 1, 1)
self.lcdNumber = QtGui.QLCDNumber(self.widget)
self.lcdNumber.setObjectName("lcdNumber")
self.gridLayout.addWidget(self.lcdNumber, 1, 0, 1, 1)
self.horizontalLayout = QtGui.QHBoxLayout()
self.horizontalLayout.setObjectName("horizontalLayout")
self.pushButton = QtGui.QPushButton(self.widget)
self.pushButton.setObjectName("pushButton")
self.horizontalLayout.addWidget(self.pushButton)
self.pushButton_2 = QtGui.QPushButton(self.widget)
self.pushButton_2.setObjectName("pushButton_2")
self.horizontalLayout.addWidget(self.pushButton_2)
self.gridLayout.addLayout(self.horizontalLayout, 2, 0, 1, 1)
self.retranslateUi(dialog)
QtCore.QObject.connect(self.pushButton, QtCore.SIGNAL("clicked()"), dialog.buttonClicked)
QtCore.QObject.connect(self.pushButton_2, QtCore.SIGNAL("clicked()"), dialog.buttonClicked)
QtCore.QMetaObject.connectSlotsByName(dialog)
def retranslateUi(self, dialog):
dialog.setWindowTitle(QtGui.QApplication.translate("dialog", "Main View", None, QtGui.QApplication.UnicodeUTF8))
self.label.setText(QtGui.QApplication.translate("dialog", "My Money", None, QtGui.QApplication.UnicodeUTF8))
self.pushButton.setText(QtGui.QApplication.translate("dialog", "Add Money", None, QtGui.QApplication.UnicodeUTF8))
self.pushButton_2.setText(QtGui.QApplication.translate("dialog", "Remove Money", None, QtGui.QApplication.UnicodeUTF8))
view raw ui_mvctest.py hosted with ❤ by GitHub


ってなわけでこいつを利用してMVCモデルによるGUIアプリケーションを作っていきます。

残念なお知らせ

当初の予定では、CLIのアプリをREPLモデルとして作る -> 各クラスとGUI部品を多重継承で受け取ったMVC部品を作ってく、って予定だったんですが、なんと、PySideが多重継承させてくれないんですよ(苦笑)。何でやねん、とか怒ってたんですが(笑)。
曰く、

新スタイルクラスじゃないと多重継承出来ません

とか言いやがって(笑)。んなもん知るか、っての(笑)。
調べてみたら、Pythonの新スタイルクラス、ってのは2.2以降に出てきた、とか書かれてるんですが、Pythonに触れ出したのは2.4以降なので、全く何のこっちゃ、です(笑)。
まあ、いずれにせよ、Qt自体が多重継承推奨してない模様なんで従いますか。この場合の「従う」ってのは、結果REPLのPrintは捨てる、って事です(爆)。

View

と言うわけで、まずはViewを作っていきます。Viewのコードは以下の通り。

# -*- coding: utf-8 -*-
import sys, repl
from PySide import QtCore, QtGui
from ui_mvctest import Ui_dialog
from repl import Read, Eval
class View(QtGui.QWidget):
def __init__(self, parent = None):
# GUI部品の初期化
super(View, self).__init__(parent)
self.ui = Ui_dialog()
self.ui.setupUi(self)
self.initUI()
# 環境保持
self.env = 0
self.c = Controller() # Controller のインスタンスを持つ
def initUI(self):
self.show() # 本当はここに置かなくても構わない
def buttonClicked(self): # Button が click() された時に結ばれてるスロット
sender = self.sender() # これがシグナル
x, env = self.c.parse(sender.text(), self.env) # シグナルの中身のテキストと、環境 env を Controller の parse メソッドに渡す
self.ui.lcdNumber.display(x) # LCDNumber は display メソッドで表示する
self.env = env # インスタンス変数 env を書き換えておく
view raw View.py hosted with ❤ by GitHub


ポイントは、最初書いた通りControllerのインスタンスを保持してる事、それと、REPLモデルの場合の引数の一部にあたる環境 env をインスタンス変数として持っている事です。
単純な流れとしては、


  1. ボタンがクリックされると buttonClicked() メソッドが呼び出され、その中でControllerのインスタンスのparse()メソッドが呼び出され(結果Model()のインスタンスが返す)返り値をxとenvに代入する。
  2. 返り値xはLCDディスプレイの表示に使われる。
  3. 返り値envはインスタンス変数envに代入される。
です。
今回はシンプルだったんですが、基本的にはボタン押されたと同時にController(翻ってはModel)からの返り値利用して表示までこぎつけるようにした方が良いでしょうね。ここで色々分けてしまうと(つまり、別の何かに手渡す感じにする)、GUIのコード的には相当ワヤクチャになってしまうでしょう。

Controller

Controllerのコードは以下の通りです。

class Controller(Read):
def __init__(self):
Read.__init__(self) # Read クラスを継承して初期化する
self.m = Model() # Model クラスのインスタンスを保持する
def parse(self, x, env): # Read の parse をオーバーライドする
if x == u'Add Money':
return self.m.interp(self.addMoney(), env) # Model のインスタンスメソッド interp を呼び出す
else:
return self.m.interp(self.removeMoney(), env)
view raw read.py hosted with ❤ by GitHub



ControllerもModelのインスタンスを持っています。ここではparseメソッドをオーバーライドしてますが、特徴としては、ReadはreturnしてたトコをModelのインスタンスからinterpメソッドを呼び出して引数を与えてるトコですね。まあ、見た通りReadのコードより(継承も相まって)相当単純化されています。
まあ、今回はシンプルなんですが、こう言う感じで、例えばViewが複数の情報を送るような場合、View側から適切なControllerインスタンスのメソッドを呼び出し、Controller側でも入力に応じたメソッドを用意しておく、と言うようなカタチにすれば複雑なプログラムにも対処出来るんじゃないでしょうか。かつ、ここではやっぱ「計算自体は」行いません。あくまでModelに対するプロトコル形式を選択出来るカタチに注力すべきだと思います。

Model

最後はModelです。Modelのコードは以下の通りです。

class Model(Eval):
def __init__(self):
Eval.__init__(self) # Eval を継承して初期化する
def interp(self, x, env): # Read の interp をオーバーライドする
num = x + env
return num, num # 普通に return して構わない(これは View に返り値として利用される)
view raw model.py hosted with ❤ by GitHub



これも継承の為相当シンプルになっています。まあ、このアプリケーションのケースだと、元々Eval自体もシンプルなんですが、GUIの場合余計な入力は最初っから入ってこない前提なんで(特にボタンとかはそう)殆ど書くのはハナクソですね。
もう一回書いておきますが、

View が Controller のインスタンスからメソッドを呼び出し -> Controller は Model インスタンスからメソッドを呼び出し -> Model インスタンスが計算結果を返す -> View が結果を知る
って流れなんですが、恐らくこのように見えるでしょう。

View が Controller のインスタンスからメソッドを呼び出す -> すぐ返り値が返ってくる

つまり、Model自体は表面的には見えないで隠されてるカンジになりますね。

Main

ZetCodeのPySideチュートリアルに依ると、main関数を作って、こう書くのが「お約束」の模様です(笑)。

def main():
app = QtGui.QApplication(sys.argv) # アプリケーションオブジェクト作成
v = View() # View のインスタンス作成
sys.exit(app.exec_()) # app.exec_() がイベントループを司ってるらしい(良く知らん・笑)
if __name__ == '__main__': # お馴染み!
main()
view raw main.py hosted with ❤ by GitHub




ってなわけで REPL -> MVC のコンバートは完了です。以下にMVCの全コードを置いておきます。

# -*- coding: utf-8 -*-
import sys, repl
from PySide import QtCore, QtGui
from ui_mvctest import Ui_dialog
from repl import Read, Eval
class View(QtGui.QWidget):
def __init__(self, parent = None):
super(View, self).__init__(parent)
self.ui = Ui_dialog()
self.ui.setupUi(self)
self.initUI()
self.env = 0
self.c = Controller()
def initUI(self):
self.show()
def buttonClicked(self):
sender = self.sender()
x, env = self.c.parse(sender.text(), self.env)
self.ui.lcdNumber.display(x)
self.env = env
class Controller(Read):
def __init__(self):
Read.__init__(self)
self.m = Model()
def parse(self, x, env):
if x == u'Add Money':
return self.m.interp(self.addMoney(), env)
else:
return self.m.interp(self.removeMoney(), env)
class Model(Eval):
def __init__(self):
Eval.__init__(self)
def interp(self, x, env):
num = x + env
return num, num
def main():
app = QtGui.QApplication(sys.argv)
v = View()
sys.exit(app.exec_())
if __name__ == '__main__':
main()
view raw mvc_test.py hosted with ❤ by GitHub


ついでだからWindowsの実行形式も作ってしまおう

せっかくGUIのアプリケーションが作れたんだからWindowsの実行形式にコンパイル出来ればサイコーだったりしますよね。その為にはpy2exeと言うユーティリティを使います。
これは以前、Pythonでのイスカンダルのトーフ屋ゲームの実行形式作った時にも利用したユーティリティでコマンドライン形式のアプリケーション実行形式を作る場合には結構簡単に使えるんですが、ところがQtなんかのGUIモノをコンパイルする場合ハマったので、一応ここに解説しておきます。
まずは何はともあれ、どーゆーわけか


Microsoft Visual C++ 2008 Redistributable Package (x86)


と言うものがPCにインストールされてないといけません。しかもSP1とか2010とかじゃダメで、上のブツじゃないとダメなんです。こいつに含まれてるmsvcp90.dllってブツが実行形式作成に必須なモノなんです。
なお、上のヤツは再配布可能なdll(ダイナミックリンクライブラリ)が含まれてるんですが、利用規約にはフォルダMicrosoft.VC90.CRT(msvcp90.dllが存在するVC以下のフォルダ)に含まれてる「3つのdll」は全て単独で配布するのは禁止されていて、同じフォルダにあるMANIFEST ファイルを含め、全部纏めて配布せなアカン、って決められてる模様です。
ああ、クソメンドくせえなぁ、Microsoftさんよ(苦笑)。
そこで、py2exeチュートリアルに従って、まずは次のようなsetup.pyを作ります。

from distutils.core import setup
from glob import glob
import py2exe, sys
# 目的の dll があるパスを明示する
sys.path.append("C:\\Program Files (x86)\\Microsoft Visual Studio 9.0\\VC\\redist\\x86\\Microsoft.VC90.CRT")
# じゃないと、ここでパスを明示しても py2exe が dll を拾ってきてくれない
data_files = [('Microsoft.VC90.CRT', \
glob(r'C:\Program Files (x86)\Microsoft Visual Studio 9.0\VC\redist\x86\Microsoft.VC90.CRT\*.*'))]
setup(
windows = [{'script':'c:\プロジェクトフォルダ\mvc_test.py'}],
data_files = data_files
)
view raw setup.py hosted with ❤ by GitHub


上のようなsetup.pyを作ると、自動生成される実行形式をぶち込んだフォルダ(distフォルダ)にdllが入ってるフォルダをコピペしてくれます。これでMicrosoftの規約は守れるようになるわけですね。
そしてその後、


  1. DOS窓でプロジェクトフォルダに移動する
  2. 「python プロジェクトフォルダ/setup.py py2exe」 をDOS窓で走らせる 
とすればプロジェクトフォルダ内に新しくbuildとdistと二つのフォルダが作られます。distフォルダにめでたくWindows実行形式が生まれていますね。

まあ、こんなカタチでやっとこさ、GUIアプリの実行形式を作るまで辿り着きました。お疲れ様です。


2014年1月5日日曜日

Return Of イスカンダルのトーフ屋ゲーム

シリーズ(いつシリーズ化したんだ・笑)「イスカンダルのトーフ屋ゲーム」第3弾です。

まあ、今回は余談的に始めました。OOPスタイルでのSchemeでの「イスカンダルのトーフ屋ゲーム」の作成にかなり苦労したんで、フツーに関数型で書けばどうなるのか、自分で確かめてみたかったんですね。

作成自体は1日あれば終わったんですが、やっぱり慣れもあるし、ロジック的には同じの3回目だから、って事もあるんでしょうが、それでも「関数型で書く」ってのはやっぱ早いです。すぐ出来る。

加えるとテストがラクなんですよね。オブジェクトに対してメソッド呼び出して・・・ってのは、ぶっちゃけ、インタプリタでも書式がメンド臭いんで、結局「テストコード」を本体側に対して記述しないと色々とウザったい。
ある意味、テスト駆動開発ってOOP前提だよな、って気がしました。

なお、今回は原作者のページに置いてあるイスカンダルのトーフ屋ゲーム(ViViScript 版)~プロ仕様~の計算ロジックを参考にしてます。これ(と同じページに置いてあるオリジナル版)が原作者氏の書いたソースだ、って気づかなかったんですよね(笑)。実行形式が端末起動して遊べるようになってたから、まさか今公開してるのがエディタのマクロ言語で記述されてる、たぁ思いもよらなかったです(笑)。てっきりCかなんかで記述してると思い込んでました(爆)。

ってなわけで、初めましょうか。

ゲームに必要な大域変数の定義

まずはゲームに必要な大域変数を定義します。
関数型プログラミングではあまり大域変数使わない前提なのは確かなんですが、計算の過程に於いて、何らかのデータの「参照対象」が必要な場合があります。
重要なのは「参照の為に」定義するんであって、そのデータは絶対プログラム内では書き換えません。
まあ、そいつを引数で与えてやってもイイんですが、後に見ますが、スタイル的にはフツーのプログラミングに於ける「破壊的変更」を対象を新しく生成する事で避けてるんで、どうしても本体の引数が増えちゃうんですね。
ここで「大域変数」として定義した内容は、ゲーム全体に於いて使いまわされるけど、固定した値で変更する必要が生じないモノに限ってます。具体的には、


  1. トーフのプロパティ(値段、製造コスト等)
  2. Game-Overに達する目標金額
の二つです。今までの「イスカンダルのトーフ屋ゲーム」に於けるプログラミングを見てた人には、この二つはゲームを通して不変である、って事に気づくでしょう。
(ちなみに、ゲームに於いて表示される「文字列」も不変な故に大域変数対象になりますが、それは後にPrint部を作る際に定義しましょう。結局トータルでは3つの大域変数が必要となります。)
また、プログラム本体にこの手の「決まった数値」を埋め込むのは避けるべきだ、ってのも良く言われる事です。これらを関数の外側に出しておけば、ソースに手を入れて変更するのもラクですしね。
これら二つをトーフに於いては連想リスト、目標金額は単なる変数として定義します。



;;;;; Game Over
(define game-over 30000) ; ゲームオーバーの条件
;;;;; トーフのデータ
(define tofu '((price . 50) ; トーフの値段
(cost . 40) ; トーフの製造コスト
(sunny . 500) ; 晴れの時に売れる最大個数
(cloudy . 300) ; 曇りの時に売れる最大個数
(rainy . 100))) ; 雨の時に売れる最大個数
これで準備は万端です。ではまずはR->E->Pの順序に則って、まずはRead部から仕上げて行きましょうか。

Read (Parser 関数)

大まかなロジックは前回と全く同じなんですが、クラスに詰め込んだローカル関数を基本的には全部外に出してフツーの関数として再定義する事で、ソースは随分スッキリと読みやすくなります。
Common Lispに比べると、まあ、名前空間の衝突とか避ける為に、割にSchemeでは何でもかんでもローカル関数にしたがる傾向がありますが(実際、外人のCLerに「キミのコードはScheme臭い」って言われた事がある)、確かにローカル関数は場合によってはソースの可読性落としますね。
(ちなみに、基本的にはCLerはSchemer程ローカル関数は使わずに何でも大域的に定義したがるらしい。と言うのも「パッケージ機構」ってのがあって、名前空間の問題を仕様上回避するような仕掛けが施されている。反面そう言う大掛かりなシステムが"仕様上定義されてない"Schemeでは比較的神経質に関数を扱わざるを得ない。)
まあ、ケースバイケースなんですが、前回みたいに「ローカル関数の中にローカル関数定義」とかは多分やり過ぎなんで(笑)、そこまでするなら大域的に定義した方がスッキリするのは確かです。

なお、大まかな仕様は次の通りです。


  1. Parser関数(以降Readとする)は6つの(!)引数を受け取り、その中のphase変数の値を見て挙動を変更する。
  2. 変更される挙動とは...もういいやね、これ(笑)。
  3. 基本的には、引数をそのまま6つの多値として返すが、入力値があった場合にはそれをpnに束縛する。


ではソースです。

;;; Read
(define (y-or-n? arg)
; yes か no かに類する入力に対して
; yes の場合は #t、 no の場合は #f を返す
; 入力違反に対しては空リストを返す
(letrec ((test
; 入力されたシンボルを大文字シンボルに変換
; yes に類する場合は #t
; no に類する場合は #f
; それら以外の場合は '() を返す
(lambda (sym)
(let ((upsym (string->symbol
(string-upcase
(symbol->string sym)))))
(case upsym
((Y YES) #t)
((N NO) #f)
(else '()))))))
; body
(if (symbol? arg)
(test arg)
'())))
(define (input-integer arg limit)
; 整数の入力しか受け付けない関数
; 入力違反には空リストを返す
(letrec ((test
; 入力された整数が0からトーフを作れる
; 最大値の間にあるか調べる
; 最大値は環境を参照する
; 入力違反には '() を返す
(lambda (num)
(if (<= 0 num limit)
num
'()))))
; body
(if (integer? arg)
(test arg)
'())))
(define (parser phase player comp wr pn cn)
; Read
; 入力を受け取らなくても基本的には6つの値
; phase、 player、 comp、 wr、 pn、 cn
; を自動的に返し、これらは環境を参照してる
; 入力は pn に束縛する
(letrec-syntax ((iter
; 出力用のループはローカルマクロでまとめてある
(syntax-rules ()
((_ (arg ...))
(let loop ((i (arg ...)))
(if (null? i)
(loop (arg ...))
(values phase player comp wr i cn)))))))
(case phase
((introduction instruction play-again?) (iter (y-or-n? (read))))
((input-integer) (iter (input-integer (read) cn)))
(else (values phase player comp wr pn cn)))))
view raw parser hosted with ❤ by GitHub

だいぶスッキリとして読みやすくなったのではないでしょうか。ローカル関数(letrec)も相変わらず使ってますが、やっぱ一つの関数内にネストが一個程度でやめておきたいもんですね。ローカル関数内ローカル関数は見た目には厳しすぎる。

ところで、実はここで前回までのプログラミングと大きく違う点があります。それは3つあって、


  1. 環境を作る仕組みがない。
  2. 環境は関数に引き渡される引数として表現される。
  3. 従って、ReadにもPrintにも(言わせれば)環境が引数として渡される。
前にPython版から作り出した時、「環境はEvalのモンだしなぁ」ってこだわってたんですが、実はここに来てそんなこだわりは必要がない、って事に気づきました。以前はそこにこだわっていた為、クラス変数と言うポスト大域変数の書き換え、みたいな破壊的操作が必要になってたんですね。
しかしながら、ここに来て、環境を手渡しつつRead、Eval、Printの間でグルグル回す方が良いのではないか、と気づいた。つまり、どの環境の変数に対してどの関数が手を入れるのか明確にする方が大事な気がしてきたんです(言わばバケツリレー方式ですね・笑)。
基本的には環境に対して計算結果を返すのはEvalの役目です。それは変わりません。しかしRead部はどっちにしても入力値を手渡す、って限定に於いては環境に手を入れても良いのではないか。つまり、ここでは「入力情報」がある意味「環境」になっちゃった、って事ですね。
上にあげた6つの引数のうち、 pn ってのが入力値を保持する為の引数です。つまり、何らかの入力があった際には pn は Readが扱う、と言うルールが明確になったのです。

Eval (Interp関数)

前までだとやれこのデータをクラスで定義して・・・だったんですが、今回は全く必要がありません(笑)。サクサクと進みます(笑)。
Eval部も基本的には、前回の「ローカル関数だらけ」を分離したスタイルになっています。お陰で、Eval(Interp関数)が一体何を行ってるのか、明確になる。

  1. Interp関数(Eval)は6つの引数を受け取る。
  2. シンボルで表された変数phaseを見て適する関数を呼び出し、次のphaseを束縛する。
  3. 変数 player はプレイヤーの持ち金である。加算減算が( calc 関数によって)返された場合は変数 player にその返り値を束縛する。
  4. 変数 comp は対戦相手の持ち金である。加算減算が( calc 関数によって)返された場合は変数 comp にその返り値を束縛する。
  5. 変数 wr は天気予報の値である。関数 weather-report の返り値を束縛する。
  6. 変数 pn はReadが読み込んだ入力値である。計算に必要な場合、この値を見て評価するが、pn に対しては特に何も行わない。
  7. 変数 cn は評価に於いて何らかのエクストラの情報が生じた場合(これは要するにPrintが要する情報になるが)この変数に評価結果を束縛する。
  8. 以上の6つを多値による返り値として返す。
さて、こう見てみると、一応Read->Eval->Printループなんですが、内部的にはEvalがスタート地点で、Eval->Print->Readと言うカンジで回っていくのが分かるんじゃないでしょうか。あらゆるデータに関する「評価」は文字通りEval(interp関数)が行っているんです。

ではソースの方を。

;;;;; Eval
(define (comp-calc comp weather-report)
; コンピュータが作るトーフの個数を天気予報から算出
(letrec ((calc
(lambda ()
(cond ((>= (cdr (assq 'sunny weather-report)) 80) 500)
((>= (cdr (assq 'rainy weather-report)) 20) 100)
(else 300)))))
; body
(min (quotient comp (cdr (assq 'cost tofu))) (calc))))
(define (weather-report prob1 prob2)
; 天気予報を計算する関数
; 返り値は連想リスト
(let ((sunny (- 100 (max prob1 prob2)))
(rainy (min prob1 prob2)))
(let ((cloudy (- 100 sunny rainy)))
`((sunny . ,sunny)
(cloudy . ,cloudy)
(rainy . ,rainy)))))
(define (actual-weather weather-report tofu r)
; 実際の天気を計算する関数
; 天気予報を参照して計算する
; 返り値は天気情報のシンボルと
; 天気によるトーフの売上の最大値
; の二つを多値として返す
(cond ((< r (cdr (assq 'rainy weather-report)))
(values 'rainy (cdr (assq 'rainy tofu))))
((< r (+ (cdr (assq 'rainy weather-report))
(cdr (assq 'cloudy weather-report))))
(values 'cloudy (cdr (assq 'cloudy tofu))))
(else
(values 'sunny (cdr (assq 'sunny tofu))))))
(define (calc seller n sold tofu)
; トーフの売上から損益を計算する
(+ seller (- (* (min sold n) (cdr (assq 'price tofu)))
(* n (cdr (assq 'cost tofu))))))
(define (test player comp game-over)
; ゲームの勝者を計算する
(letrec ((calc
; プレイヤーの持ち金とコンピュータの持ち金から
; 勝者を計算する
(lambda ()
(cond ((> player comp) 'you-win)
((= player comp) 'even)
(else 'you-lose)))))
; body
; 目標金額に達したかどうかチェックして真ならローカル関数
; calc を呼び出す
(and (or (>= player game-over) (>= comp game-over))
(calc))))
(define (interp phase player comp wr pn cn)
; Eval
; Read から与えられた6つの引数に従って評価を行うこのプログラムの心臓部
; phase に対しては次のフェーズをセット
; player と comp はそれぞれの持ち金を表す
; wr は天気予報計算の結果を入れる変数
; pn にはプレイヤーが入力した情報
; cn には eval の評価値(もしあれば)
; と、それぞれ束縛される
; これらはその後、多値として Print に渡される
(let-syntax ((initialize
; コード中で初期化に必要なトコが3箇所あり、
; メンドいんでローカルマクロ initialize として
; まとめた
(syntax-rules ()
((_ player comp)
(let ((prob0 (random-integer 100))
(prob1 (random-integer 100)))
(values 'input-integer player comp
(weather-report prob0 prob1) pn
(quotient player (cdr (assq 'cost tofu)))))))))
; body
(case phase
((introduction) (if pn ; 'introduction 過程と 'instruction 過程は
(values 'instruction player comp wr pn cn) ; 殆どコードが同じなんで、ローカルマクロにして
(initialize player comp))) ; 纏めても良かったかもしんない。
((instruction) (if pn
(initialize player comp)
(values phase player comp wr pn cn)))
((input-integer) (let ((c (comp-calc comp wr)))
(values 'opponent-turn player comp wr pn c)))
((opponent-turn) (let ((prob (random-integer 100)))
(let-values (((sym sold) (actual-weather wr tofu prob)))
(values 'next-day (calc player pn sold tofu) (calc comp cn sold tofu) wr pn sym))))
((next-day) (let ((fact (test player comp game-over)))
(if fact
(values 'show-winner player comp wr pn fact)
(initialize player comp))))
((show-winner) (values 'play-again? player comp wr cn pn))
((play-again?) (if pn
(initialize 5000 5000)
(exit))) ; exit はRacket 実装依存
(else (values 'introduction player comp wr pn cn)))))
view raw gistfile1.txt hosted with ❤ by GitHub


やっぱ分かりやすいと思います。Evalが必要とする個々の関数も全部小さいですし、ローカル関数で纏められすぎてるコードを読むよりゃやっぱラクですよねぇ。
一つあるトリックとしては、関数 actual-weather が多値を返してます。一つ目は一種フラグのシンボルで、このシンボルを使ってPrint関数が文字列情報をまとめた連想リストから適する表示形式を探してきます。つまり、変数 cn に束縛させるシンボルを返すと言うのが目的。二つ目はトーフデータが持つ「天気による最大売上個数」を連想リストから検索してて返してて、この結果はプレイヤーと対戦相手の「売上計算」に利用されてその後破棄されます。
このくらいですし、大したトリックでもないですね(笑)。まあ、多値利用しただけだった、ってばだけなんですが、意外と便利です(笑)。

Print 関数

さて、最後に Print 関数です。今回ははえぇなぁ(笑)。
最初に書きましたように、まずは表示に使うメッセージデータを連想リストとして纏めて大域変数としてまずは定義します。
実はこの辺、前回も指摘したんですが、SRFI-48で定義されてるFormatを使用すれば、書式の指定子込みでデータを作れるんで、もっと簡単になるでしょう。
今回もPrintが利用してる関数は、わざわざ整形演算を行う為に書いたモノが殆どで、format 前提なら殆ど本体だけで間に合う、って言っても過言じゃないと思います。


  1. Print 関数は6つの引数を取る関数である。
  2. ただし、印字を出力後、この6つの引数を多値としてそのまま返し、引数に対する操作は一切行わない(これがまさしく印字が副作用的性質である事の証明・笑)
  3. 基本的には、phase 引数を見て適した文字列を連想リストとして設計された message データから検索してくる。
  4. 出力に必要であれば、cn 変数を用いる。
これだけ、です。コードがそれにすれば分量が若干多いように見えますが、もう一度言いますが、SRFI-48でのformatとか利用すれば殆ど Print 関数本体だけで仕事をやっつけちゃえるのです。
(恐らく連想リストの設計さえも、phase と一対一対応で、理想的には phase を利用して検索して表示するだけ、までに構造的には絞り込めると思います。Lispのシンボルの有用性の証明になる気がします。)

ではソースです。

;;;;; Print
(define messages
; ゲームで使われる文字列のデータ
'((yen . " 円 ")
(1000-yen . #\■)
(empty-yen . #\□)
(space . #\space)
(introduction . "イスカンダルのトーフ屋ゲーム(Scheme 関数プログラミング 版)\n
Copyright (c) 1978 - 2014 by Nobuhide Tsuda\n\n
ルール説明しますか?[y/n]")
(instruction . "ここはイスカンダル星。あなたはここでトーフ屋を経営し、\n
地球への帰還費用を作り出さなくてはいけません。\n
でもお向かいには、コンピュータが経営するトーフ屋があります。。。\n\n
トーフの原価は1個40円、販売価格は50円です。\n
1日に売れる個数は天候に左右されます。\n
晴れると500個、くもりだと300個、雨のときは100個まで売れます。\n
トーフは日持ちしないので、売れ残った分はすべて廃棄します。\n
そこで、次の日の天気予報をよく見て、何個作るか決心してください。\n
所持金5千円からはじめて早く3万円を超えた方が勝ちです。\n\n
いいですか?[y/n]\n")
(money . "\n所持金:\n")
(player . "あなた")
(comp . #("わたし" "わたしは "))
(sunny . #("\n明日の天気予報: 晴れ " #\◎ " 晴れ \\(^o^)/ "))
(cloudy . #( "% くもり " #\・ " くもり (~_~) "))
(rainy . #("% 雨 " #\● " 雨 (;_;) "))
(percent . "%")
(howmany-tofus? . "\nトーフを何個作りますか?(1~")
(kokka . ")")
(makes . "個 作ります。\n")
(next-day . "***** 次の日 *****")
(weather . "今日の天気は")
(period . ".")
(is . " です。")
(you-win . "\nあなたの勝ちです。")
(even . "\n引き分けです。")
(you-lose . "\nコンピュータの勝ちです。")
(play-again? . "\nplay again ? [y/n]")
))
(define (show-money player comp data)
; プレイヤーとコンピュータの持ち金の文字列整形
; 本当はSRFIのformatを使えばもっと簡単に書ける
(letrec ((calc
; プレイヤーとコンピュータの持ち金の表示用文字列整形
(lambda (name gold)
(letrec ((format
; 数値用文字列整形
(lambda ()
(cond ((> gold 9999) 1)
((> gold 999) 2)
((> gold 99) 3)
(else 4))))
(spaces
; 数値を揃える為のスペース整形
(lambda (num)
(make-string num (cdr (assq 'space data)))))
(calc
; 持ち金のグラフィック部分の整形
(lambda ()
(let ((x (quotient gold 1000)))
(let ((y (- 30 x)))
(string-append
(make-string x (cdr (assq '1000-yen data)))
(make-string y (cdr (assq 'empty-yen data)))))))))
; calc の body
(string-append (spaces 2)
(let ((n (cdr (assq name data))))
(if (vector? n)
(vector-ref n 0)
n))
(spaces 1)
(spaces (format))
(number->string gold)
(cdr (assq 'yen data))
(calc)
"\n")))))
; body
(string-append (cdr (assq 'money data))
(calc 'player
player)
(calc 'comp
comp))))
(define (show-weather-report wr data)
; 天気予報表示の文字列整形
; 本当はSRFIのformat を使うともっと簡単に書ける
(letrec ((calc0
; パーセンテージ表示用
(lambda (keys)
(let ((s0 (map (lambda (k)
(vector-ref
(cdr (assq k data)) 0)) keys))
(s1 (map (lambda (k)
(number->string
(cdr (assq k wr))))
keys)))
(string-append (string-concatenate
(map string-concatenate (zip s0 s1)))
(cdr (assq 'percent data))
"\n"))))
(calc1
; グラフィック表示用
(lambda (keys)
(let ((nums (map (lambda (k)
(quotient
(* (cdr (assq k wr)) 10) 25))
keys)))
(string-concatenate
(map (lambda (k n)
(make-string n
(vector-ref (cdr (assq k data)) 1)))
keys nums))))))
; body
(let ((keys '(sunny cloudy rainy)))
(string-append (calc0 keys) (calc1 keys)))))
(define (ask-howmany-tofu num data)
; いくつトーフを作るのか尋ねる
(string-append (cdr (assq 'howmany-tofus? data))
(number->string num)
(cdr (assq 'kokka data))))
(define (computer-reply num data)
; コンピュータの反応表示
(string-append (vector-ref (cdr (assq 'comp data)) 1)
(number->string num)
(cdr (assq 'makes data))))
(define (show-weather-is sym data)
; 実際の天気を表示
(let ((keys `(weather period period period ,sym is)))
(map (lambda (k)
(let ((v (cdr (assq k data))))
(if (vector? v)
(vector-ref v 2)
v))) keys)))
(define (show-winner key data)
; 勝者を表示
(cdr (assq key data)))
(define (print phase player comp wr pn cn)
; Print
; 表示だけじゃなくって、 Eval から渡された6つの引数、
; phase、 player、 comp、 wr、 pn、 cn を
; そのまま返す
(for-each (lambda (x)
(sleep 0.5) ; Racket 実装依存
(display x))
(case phase
((input-integer) `(,(string-append (show-money player comp messages)
(show-weather-report wr messages)
(ask-howmany-tofu cn messages))))
((opponent-turn) `(,(computer-reply cn messages)))
((next-day) (show-weather-is cn messages))
((show-winner) `(,(show-winner cn messages)))
(else `(,(cdr (assq phase messages))))))
(values phase player comp wr pn cn))
view raw print hosted with ❤ by GitHub


とこれで、Read、Eval、Printの全てのパーツが「関数型プログラミングを使って」組みあがりました。(もっともHaskellな人達は簡単に出力を扱える事に違和感があるでしょうが・笑)
あとはREPLを組むだけ、ですね。

Read-Eval-Print-Loop

REPLは次のように末尾再帰な関数として書いて、実行時に適切な引数をREPL関数に渡す事でゲームが動きます。

;;;;; REPL (Read-Eval-Print-Loop)
(define (repl phase player comp wr pn cn)
(let-values (((r0 r1 r2 r3 r4 r5) (parser phase player comp wr pn cn)))
(let-values (((e0 e1 e2 e3 e4 e5) (interp r0 r1 r2 r3 r4 r5)))
(let-values (((p0 p1 p2 p3 p4 p5) (print e0 e1 e2 e3 e4 e5)))
(repl p0 p1 p2 p3 p4 p5))))) ; ここで末尾再帰
(repl #f 5000 5000 #f 0 0) ; 初期状態を適当に渡して起動
view raw eval hosted with ❤ by GitHub

まあ、多値を6つも返す関数が3つもあるんで物凄い事になってるんですが(笑)、基本的には簡単ですね。関数REPLは末尾再帰で呼び出された際に、最終的にPrintが渡した値を引数として持って、延々と無限ループへと突入するわけです(笑)。Evalが(exit)命令を出すまでこの動きは止まりません(笑)。

なお、phase の初期値として #f を渡してるのは、初期状態で、 #f はParser 関数( Read ) 本体のcase 構文内で「else」として認識され、そのまま「何もせずに」 interp 関数に全引数を渡すからです。
続いて、interp 関数は phase = #f を見て、やはり本体の case 構文内で else として処理され、ここで初めて、phase にシンボル 'introduction が返り値の一つとして束縛されるわけです。
つまり、初期状態で phase に与える値はゲーム中で使われてないブツなら何でも良くって(あるいは意図的に「途中から」始める事も可能) 結果、伝統的で単純な #f を与えてみました。
ちなみにそうなると、最初の Read -> Print 間は全く何もしてないに等しくて、引数与えるのは「REPLをビックリさせて起動させる」に等しいです(笑)。また、先ほどにも書きましたが、内部的にはE->P->Rの順に処理が進んでいく、ってのは全くそのままの意味です。

非破壊的なゲーム構造

まあ、ちょっとしたシャレで始めたこのヴァージョンだったんですが、面白い事に気づきました。
実は、REPLで末尾再帰が呼び出される際に、与えられる引数はPrintの返り値です。
んで、実はこのプログラムの中では「一回も」普通のプログラミングで言う「代入」は行われていないんですね。つまり「直接変数を書き換える」と言う事は一切行っていない。
特にEvalの動作なんですが、


  1. 引数を参照する
  2. 基本的には「操作」は新しい値を「作る」
  3. 他のケースでは「与えられた引数を参照して」(要するに)コピーしてる
  4. 結果、返り値は元のデータではなく新しいデータである。
この「コピーして」「新しいデータを作る」ってのが言わば関数型プログラミングのキモなんですよね。じゃあ参照に使われた古い引数はどうなるのか、っつーと、参照されなくなった時点でGC(ガベージコレクタ)がやってきて回収・廃棄処分です(笑)。
これは実はReadにせよPrintにせよ、「コピーして新しいデータを作ってる」ってのは同じです。「書き換え」ではないんです。
まあ、こんなこたぁ関数型言語に詳しい人には釈迦に説法なんですが、ちと待てよ、と。こんな事が出来るなら恐らく「非破壊的に」データ生成し続けてゲームを作れるモデル、例えば理論的にはRPGなんかも作れるんじゃないか、って思ったんですね。で、多分それは可能でしょう。
以前、関数型プログラミングは机上の空論なんじゃないか、って実は失望してたんですが、ひょいとしたキッカケで実用上OKなんじゃないか、って思えるようになったのは大収穫でした。
つまり、上のREPLのような関数を設計して、参照する環境として引数(例えばRPGで言うとプレイヤー情報とか)を与えて、内部的にはコピーして元データには一切手をかけない。そうすれば「非破壊的なプログラム構造を持った」関数型による関数型の為の関数型のゲームが作成可能だ、って光明が見えたんですよね。
引き続きこのテーマを研究してみたいと思います。言い換えると、例えばOOPモデルでさえ(プログラミング言語の末尾再帰の最適化が保証されていれば)インスタンス変数を「書き換える」のではなくって「新しいインスタンスを」常に生成するモデルも可能だろう、って事ですから。

では今回の全ソースコードです。

#lang racket
;;;;; made on PLT Racket
;;;;; Racket:
;;;;; http://racket-lang.org/
; Racket 実装依存
; 他の処理系の場合、SRFI(Schemeの共有ライブラリ)を呼び出すには
; Gauche: http://practical-scheme.net/gauche/index-j.html
; (use srfi-1) ...
; Guile: http://www.gnu.org/software/guile/
; (srfi srfi-1) ...
; 等に書き換える
(require srfi/1 srfi/11 srfi/13 srfi/27)
;;;;; 乱数の初期化
(random-source-randomize! (make-random-source))
;;;;; ダミーデータ
;
;(define player 5000)
;(define comp 5000)
;;;;; Game Over
(define game-over 30000) ; ゲームオーバーの条件
;;;;; トーフのデータ
(define tofu '((price . 50) ; トーフの値段
(cost . 40) ; トーフの製造コスト
(sunny . 500) ; 晴れの時に売れる最大個数
(cloudy . 300) ; 曇りの時に売れる最大個数
(rainy . 100))) ; 雨の時に売れる最大個数
;;;;; Print
(define messages
; ゲームで使われる文字列のデータ
'((yen . " 円 ")
(1000-yen . #\■)
(empty-yen . #\□)
(space . #\space)
(introduction . "イスカンダルのトーフ屋ゲーム(Scheme 関数プログラミング 版)\n
Copyright (c) 1978 - 2014 by Nobuhide Tsuda\n\n
ルール説明しますか?[y/n]")
(instruction . "ここはイスカンダル星。あなたはここでトーフ屋を経営し、\n
地球への帰還費用を作り出さなくてはいけません。\n
でもお向かいには、コンピュータが経営するトーフ屋があります。。。\n\n
トーフの原価は1個40円、販売価格は50円です。\n
1日に売れる個数は天候に左右されます。\n
晴れると500個、くもりだと300個、雨のときは100個まで売れます。\n
トーフは日持ちしないので、売れ残った分はすべて廃棄します。\n
そこで、次の日の天気予報をよく見て、何個作るか決心してください。\n
所持金5千円からはじめて早く3万円を超えた方が勝ちです。\n\n
いいですか?[y/n]\n")
(money . "\n所持金:\n")
(player . "あなた")
(comp . #("わたし" "わたしは "))
(sunny . #("\n明日の天気予報: 晴れ " #\◎ " 晴れ \\(^o^)/ "))
(cloudy . #( "% くもり " #\・ " くもり (~_~) "))
(rainy . #("% 雨 " #\● " 雨 (;_;) "))
(percent . "%")
(howmany-tofus? . "\nトーフを何個作りますか?(1~")
(kokka . ")")
(makes . "個 作ります。\n")
(next-day . "***** 次の日 *****")
(weather . "今日の天気は")
(period . ".")
(is . " です。")
(you-win . "\nあなたの勝ちです。")
(even . "\n引き分けです。")
(you-lose . "\nコンピュータの勝ちです。")
(play-again? . "\nplay again ? [y/n]")
))
(define (show-money player comp data)
; プレイヤーとコンピュータの持ち金の文字列整形
; 本当はSRFIのformatを使えばもっと簡単に書ける
(letrec ((calc
; プレイヤーとコンピュータの持ち金の表示用文字列整形
(lambda (name gold)
(letrec ((format
; 数値用文字列整形
(lambda ()
(cond ((> gold 9999) 1)
((> gold 999) 2)
((> gold 99) 3)
(else 4))))
(spaces
; 数値を揃える為のスペース整形
(lambda (num)
(make-string num (cdr (assq 'space data)))))
(calc
; 持ち金のグラフィック部分の整形
(lambda ()
(let ((x (quotient gold 1000)))
(let ((y (- 30 x)))
(string-append
(make-string x (cdr (assq '1000-yen data)))
(make-string y (cdr (assq 'empty-yen data)))))))))
; calc の body
(string-append (spaces 2)
(let ((n (cdr (assq name data))))
(if (vector? n)
(vector-ref n 0)
n))
(spaces 1)
(spaces (format))
(number->string gold)
(cdr (assq 'yen data))
(calc)
"\n")))))
; body
(string-append (cdr (assq 'money data))
(calc 'player
player)
(calc 'comp
comp))))
(define (show-weather-report wr data)
; 天気予報表示の文字列整形
; 本当はSRFIのformat を使うともっと簡単に書ける
(letrec ((calc0
; パーセンテージ表示用
(lambda (keys)
(let ((s0 (map (lambda (k)
(vector-ref
(cdr (assq k data)) 0)) keys))
(s1 (map (lambda (k)
(number->string
(cdr (assq k wr))))
keys)))
(string-append (string-concatenate
(map string-concatenate (zip s0 s1)))
(cdr (assq 'percent data))
"\n"))))
(calc1
; グラフィック表示用
(lambda (keys)
(let ((nums (map (lambda (k)
(quotient
(* (cdr (assq k wr)) 10) 25))
keys)))
(string-concatenate
(map (lambda (k n)
(make-string n
(vector-ref (cdr (assq k data)) 1)))
keys nums))))))
; body
(let ((keys '(sunny cloudy rainy)))
(string-append (calc0 keys) (calc1 keys)))))
(define (ask-howmany-tofu num data)
; いくつトーフを作るのか尋ねる
(string-append (cdr (assq 'howmany-tofus? data))
(number->string num)
(cdr (assq 'kokka data))))
(define (computer-reply num data)
; コンピュータの反応表示
(string-append (vector-ref (cdr (assq 'comp data)) 1)
(number->string num)
(cdr (assq 'makes data))))
(define (show-weather-is sym data)
; 実際の天気を表示
(let ((keys `(weather period period period ,sym is)))
(map (lambda (k)
(let ((v (cdr (assq k data))))
(if (vector? v)
(vector-ref v 2)
v))) keys)))
(define (show-winner key data)
; 勝者を表示
(cdr (assq key data)))
(define (print phase player comp wr pn cn)
; Print
; 表示だけじゃなくって、 Eval から渡された6つの引数、
; phase、 player、 comp、 wr、 pn、 cn を
; そのまま返す
(for-each (lambda (x)
(sleep 0.5) ; Racket 実装依存
(display x))
(case phase
((input-integer) `(,(string-append (show-money player comp messages)
(show-weather-report wr messages)
(ask-howmany-tofu cn messages))))
((opponent-turn) `(,(computer-reply cn messages)))
((next-day) (show-weather-is cn messages))
((show-winner) `(,(show-winner cn messages)))
(else `(,(cdr (assq phase messages))))))
(values phase player comp wr pn cn))
;;;;; Eval
(define (comp-calc comp weather-report)
; コンピュータが作るトーフの個数を天気予報から算出
(letrec ((calc
(lambda ()
(cond ((>= (cdr (assq 'sunny weather-report)) 80) 500)
((>= (cdr (assq 'rainy weather-report)) 20) 100)
(else 300)))))
; body
(min (quotient comp (cdr (assq 'cost tofu))) (calc))))
(define (weather-report prob1 prob2)
; 天気予報を計算する関数
(let ((sunny (- 100 (max prob1 prob2)))
(rainy (min prob1 prob2)))
(let ((cloudy (- 100 sunny rainy)))
`((sunny . ,sunny)
(cloudy . ,cloudy)
(rainy . ,rainy)))))
(define (actual-weather weather-report tofu r)
; 実際の天気を計算する関数
; 天気予報を参照して計算する
(cond ((< r (cdr (assq 'rainy weather-report)))
(values 'rainy (cdr (assq 'rainy tofu))))
((< r (+ (cdr (assq 'rainy weather-report))
(cdr (assq 'cloudy weather-report))))
(values 'cloudy (cdr (assq 'cloudy tofu))))
(else
(values 'sunny (cdr (assq 'sunny tofu))))))
(define (calc seller n sold tofu)
; トーフの売上から損益を計算する
(+ seller (- (* (min sold n) (cdr (assq 'price tofu)))
(* n (cdr (assq 'cost tofu))))))
(define (test player comp game-over)
; ゲームの勝者を計算する
(letrec ((calc
; プレイヤーの持ち金とコンピュータの持ち金から
; 勝者を計算する
(lambda ()
(cond ((> player comp) 'you-win)
((= player comp) 'even)
(else 'you-lose)))))
; body
(and (or (>= player game-over) (>= comp game-over))
(calc))))
(define (interp phase player comp wr pn cn)
; Eval
; Read から与えられた6つの引数に従って評価を行うこのプログラムの心臓部
; phase に対しては次のフェーズをセット
; player と comp はそれぞれの持ち金を表す
; wr は天気予報計算の結果を入れる変数
; pn にはプレイヤーが入力した情報
; cn には eval の評価値(もしあれば)
; と、それぞれ束縛される
; これらはその後、多値として Print に渡される
(let-syntax ((initialize
; コード中で初期化に必要なトコが3箇所あり、
; メンドいんで initialize とローカルマクロとして
; まとめた
(syntax-rules ()
((_ player comp)
(let ((prob0 (random-integer 100))
(prob1 (random-integer 100)))
(values 'input-integer player comp
(weather-report prob0 prob1) pn
(quotient player (cdr (assq 'cost tofu)))))))))
; body
(case phase
((introduction) (if pn
(values 'instruction player comp wr pn cn)
(initialize player comp)))
((instruction) (if pn
(initialize player comp)
(values phase player comp wr pn cn)))
((input-integer) (let ((c (comp-calc comp wr)))
(values 'opponent-turn player comp wr pn c)))
((opponent-turn) (let ((prob (random-integer 100)))
(let-values (((sym sold) (actual-weather wr tofu prob)))
(values 'next-day (calc player pn sold tofu) (calc comp cn sold tofu) wr pn sym))))
((next-day) (let ((fact (test player comp game-over)))
(if fact
(values 'show-winner player comp wr pn fact)
(initialize player comp))))
((show-winner) (values 'play-again? player comp wr cn pn))
((play-again?) (if pn
(initialize 5000 5000)
(exit))) ; exit はRacket 実装依存
(else (values 'introduction player comp wr pn cn)))))
;;; Read
(define (y-or-n? arg)
; yes か no かに類する入力に対して
; yes の場合は #t、 no の場合は #f を返す
; 入力違反に対しては空リストを返す
(letrec ((test
; 入力されたシンボルを大文字シンボルに変換
; yes に類する場合は #t
; no に類する場合は #f
; それら以外の場合は '() を返す
(lambda (sym)
(let ((upsym (string->symbol
(string-upcase
(symbol->string sym)))))
(case upsym
((Y YES) #t)
((N NO) #f)
(else '()))))))
; body
(if (symbol? arg)
(test arg)
'())))
(define (input-integer arg limit)
; 整数の入力しか受け付けない関数
; 入力違反には空リストを返す
(letrec ((test
; 入力された整数が0からトーフを作れる
; 最大値の間にあるか調べる
; 最大値は環境を参照する
; 入力違反には '() を返す
(lambda (num)
(if (<= 0 num limit)
num
'()))))
; body
(if (integer? arg)
(test arg)
'())))
(define (parser phase player comp wr pn cn)
; Read
; 入力を受け取らなくても基本的には6つの値
; phase、 player、 comp、 wr、 pn、 cn
; を自動的に返し、これらは環境を参照してる
; 入力は pn に束縛する
(letrec-syntax ((iter
; 出力用のループはローカルマクロでまとめてある
(syntax-rules ()
((_ (arg ...))
(let loop ((i (arg ...)))
(if (null? i)
(loop (arg ...))
(values phase player comp wr i cn)))))))
(case phase
((introduction instruction play-again?) (iter (y-or-n? (read))))
((input-integer) (iter (input-integer (read) cn)))
(else (values phase player comp wr pn cn)))))
;;;;; REPL (Read-Eval-Print-Loop)
(define (repl phase player comp wr pn cn)
(let-values (((r0 r1 r2 r3 r4 r5) (parser phase player comp wr pn cn)))
(let-values (((e0 e1 e2 e3 e4 e5) (interp r0 r1 r2 r3 r4 r5)))
(let-values (((p0 p1 p2 p3 p4 p5) (print e0 e1 e2 e3 e4 e5)))
(repl p0 p1 p2 p3 p4 p5)))))
(repl #f 5000 5000 #f 0 0)


イスカンダルのトーフ屋ゲーム Strikes Back

年末年始かけてイスカンダルのトーフ屋ゲームの実装ばっかやってて一体何をやってるんでしょうか(笑)。

さて、今回は前回と同じゲームなんですが、Schemeで実装してみました。

SICPのデータ抽象型のプログラミング示唆にもある通り、クロージャを使いまくってプログラミングすればどうなるのか、一回やってみたかったんですね。それがOOPの理解も深めるだろう、とか思って・・・。

結果は・・・サイテーです(笑)。
まあ、言語形式もあるんですが、少なくともSchemeでOOP系のプログラミングやるのは頭痛の種以外の何者でもない、ってことが分かりました(爆)。
取り合えず関数型プログラミングとOOPとどっちがマシか、って話は脇に置いておきますが、少なくともLispのようなカッコが多い、と言うかプログラミングコードがかなり深いネストを生じる言語ですと、OOPのコード書くのはキツい、かつ、読むのもキツい、って思いますね(笑)。OOPはPython等のフツーの言語、言い換えるとネストがそんなにキツくならない言語に限って「スタイル的に有効だ」ってのが今回の実験での結論です。
Schemeのスタイル(あるいはLisp一般での関数型プログラミングのスタイル)、ってのは、基本的には


  1. 暗黙のbegin(あるいはprogn)をアテにしない。
  2. 従って一つの関数には一つの処理しかさせない小さな関数をたくさん書く
  3. 小さな関数同士を組み合わせて大きな処理をさせる
って事で、極めてシンプルにプログラムを組み上げる事です。これはUNIX的プログラミングの方策としては王道ですし、かつ、これだと大してネストが深くならないので、カッコだらけでもそんなに読むのはツラくありません。
反面、OOPと言うかデータ抽象型ですと、一つのオブジェクトに如何にしてたくさんのデータと処理をまとめるか、って事になって、一つのdefineされたモノが異様に膨らんでしまいます。もうこうなると理想的なSchemeコードとは言えないでしょう。
ま、てなワケで実験としては有効でしょうが、真似しないようにしましょう(笑)。自分で書いてて「こりゃヒドいコードだ」とかアタマ痛くなってましたから(笑)。

さて、今回の方針です。

  1. 新しいロジックは採用せず、基本的に前回作ったPython版のコーディングを参考にする。
  2. Schemeデファクトスタンダードの仕様、R5RSになるたけ準じて、Racket実装依存の機能はなるべく使わない。使った場合は明示して、他のScheme処理系で動かす場合、最低限の変更でOKなモノを目指す。
  3. 足りない機能があったらSRFIから持ってくる。
の3つです。1番目は当然で、「実験」でスクラッチからロジック考えてればアタマ痛くなってきます(笑)。
2番目もこれがなかなかSchemeだと難しいんですが敢えての挑戦です。どうも個人的な意見では、Webで見つけた面白そうなSchemeコードでも、作者の処理系選択によって、あっちじゃ動くけどこっちじゃ動かん、とか結構腹が立つんですよね(笑)。特に僕が使ってるRacketの場合、Racket実装依存で書くには便利な機能がテンコ盛りなんですが、他のScheme処理系じゃ動きません、っつーのはあまりにもアレなカンジがします。
3番目も初めての挑戦ですかね。SRFIは「共通ライブラリ」とか言われたりしますが、本当は個人的にはあんま好きじゃなくって、と言うのも仕様定義だけで実装は各実装に任せる、と。要するに外部的にライブラリがあって、どのScheme処理系でもインポート出来る、ってポータブルな意味でのライブラリじゃないんで嫌なんです(笑)。まあでも、今回は、少なくともGaucheGuileの2つで最低限の変更で動かせる為にSRFIサポートをチェックしてそのようにしました(Scheme48も考えたんですが、こいつはそもそも使えるSRFIが少ない)。

では始めます。

データ抽象化: 擬似OOP

ところで。「実装依存の機能をなるたけ使わない」「なるべくR5RS内で事を済ませる」となると・・・データ抽象型プログラミングを実現するにはそれなりの機構と自分で実装せなあきまへん(苦笑)。
もちろん、SICPよろしく、全部細やかにクロージャ使って実装していくのも可能なんですが、それじゃああんまりにもメンド臭すぎます。
そこで。
Paradigms of Artificial Intelligence Programmingを参考にして、まずは擬似OOPとも言えるシステムをR5RSマクロで組んでいくのが最初に行う事です・・・ってこれがまた大変だったんですけどね(苦笑)。
ではまずそのコードを。

;; 総称プロシージャ用連想リスト
(define generic-proc '())
;; クラス変数用連想リスト
(define class-vars-alist '())
;; クラス定義用マクロ
(define-syntax define-class
(syntax-rules ()
((_ class (inst-var ...)
((class-var class-val) ...)
(method arg body ...) ...)
(begin
(set! class-vars-alist
(cons `(class ((class-var . ,class-val) ...))
class-vars-alist))
(for-each ensure-generic-proc '(method ...))
(define (class inst-var ...)
(lambda (message)
(case message
((method) (lambda arg body ...))
...)))))))
(define (get-method object message)
(object message))
(define (ensure-generic-proc message)
(if (assq message generic-proc)
#f
(let ((proc (lambda (object . args)
(apply (get-method object message) args))))
(set! generic-proc
(alist-cons message proc generic-proc)))))
(define-syntax get-class-var
(syntax-rules ()
((_ class var)
(cdr (assq 'var
(cadr (assq 'class class-vars-alist)))))))
(define-syntax class-var-set!
(syntax-rules ()
((_ class var val)
(let ((alist
(alist-cons 'var val
(alist-delete 'var
(cadr (assq 'class class-vars-alist))))))
(set! class-vars-alist
(cons `(class ,alist)
(alist-delete 'class class-vars-alist)))))))
;; メソッド定義用マクロ
(define-syntax define-method
(syntax-rules ()
((_ method)
(define method (cdr (assq 'method generic-proc))))))
view raw pseudo-oop hosted with ❤ by GitHub
一応、Schemeと言うかLisp一族に明るくない人の為に解説しておきますが、簡単に言うと、Lisp/Schemeで言う「マクロ」とは、言語に新しい構文規則を付け足す機能です。つまり、Scheme/Lispでは、極端に言うと、C言語で言うdo~whileなんかの「構文」を自分で新しく作れちゃうんですね。
ここではそう言うカタチで新しく「擬似OOP」な機構を作り出してるんです。
んで基本的なコードのアイディアってのはSICP第三章で紹介されてるモノとも同じですね。

ところで、残念ながらSchemeのR5RSで策定されてるマクロはCommon Lispのマクロに比べると遥かに貧弱で、PAIPで紹介されてる実装のスペックには届きませんでした。その一つとして継承機能が組み込めなかった。
もっともPAIPで紹介されてるOOPマクロが継承可能なのは、中で使われてるmessage変数がgensymされてないんで、そこに子クラスの条件ツッコむとcase内の選択肢が増える、と言う極めて危ない実装となっています(笑)。それで考えるとSchemeのマクロが安全なんですけどね。
それから、PAIPの実装だと、クラス定義した時点でメソッドが自動で定義されるんですが、これがR5RS Scheme マクロだと不可能でした。そこでしょーがないんで、外部的にdefine-methodと言うマクロを作って、それでメソッド名をわざわざ打ち込む形式にせざるを得ませんでした。CLOSと普通のオブジェクト指向の間の子のようなスタイルになってしまいましたね。
あと、Peter Norvigによる実装ですと、クラス変数がdefunを包んでるように定義されていて(クロージャで囲まれてる)、このスタイルだとやはりそのままSchemeでは実現出来ません(Schemeだとこの場合ローカル関数扱いになってクラスが外から全く見えなくなってしまう)。そこでPythonのようなクラス変数へのアクセスも考慮して、思い切ってクラス変数は大域変数としてクラス外で連想リストとして定義して、そこへのアクセッサをget-class-var、class-var-set!として定義しています。ちと不格好なんですが、前回見たとおり、使いドコロによっては便利ですが同時に危険なクラス変数へのアクセスは明示的に不便な薫りを漂わせておくべきだ、ってのは結果悪くないんじゃないか、とは思います。
ちなみに、連想リストを使ってる+Racketの厳密なクオート適用のせいで、原作ではフツーの関数だったけど、ここではマクロにせなあかんかったのが何個かあります。


テスト実行は以下のとおりです。

;; クラス定義のテスト
; クラス定義構文は
; (define-class クラス名 (インスタンス変数...) ((クラス変数) ...) 本体 ...)
; 本体は
; (メッセージ名 (引数) 動作1 動作2 ...)
; と言う構文で書き連ねていけば良い。
(define-class account (name (balance 0))
((interest-rate .06))
(withdraw (amt) (cond ((<= amt balance)
(set! balance (- balance amt))
balance)
(else 'insufficient-funds)))
(deposit (amt) (set! balance (+ balance amt))
balance)
(balance () balance)
(name () name)
(interest () (set! balance
(+ balance (* (get-class-var account interest-rate) balance)))
balance))
;; メソッドを外部から呼び出す為のdefine-method構文
;; 書式は以下の通り
;; (define-method メソッド名)
;; これでクラス内のメソッド定義が呼び出される
(define-method withdraw)
(define-method deposit)
(define-method balance)
(define-method name)
(define-method interest)
class-vars-alist
generic-proc
(define acct (account "A. User" 2000))
(= (deposit acct 42) 2042)
(= (interest acct) 2164.52)
(= (balance acct) 2164.52)
;; 実行結果
'((account ((interest-rate . 0.06)))) ; クラス変数の連想リストの中身
'((interest . #<procedure:proc>) ; 総称関数用連想リストの中身
(name . #<procedure:proc>)
(balance . #<procedure:proc>)
(deposit . #<procedure:proc>)
(withdraw . #<procedure:proc>))
#t
#t
#t
>



と言うわけで、ちと不格好なOOPモドキではありますが、これらを駆使してScheme版「イスカンダルのトーフ屋ゲーム」を書いていこうと思います。

Parser クラス (Read)

さて、前回は結構勢いだけで作っていって、「どう言う順番で組み立てていくべきか」とかあんま考えてなかったんですよね(笑)。結構行き当たりばったりでした(笑)。
まあ、今回は二回目ですし、また参考に出来るPythonのコードもあるし、ってな事もあるんですが、しかしそれでもどうやらやはり

REPL構造はRead->Eval->Printの順序で組み立てていくべきだ

って事がちと分かりましたね。
考えてみれば当たり前なんですが、情報の流れを追った順序で組み上げていくのが原則で、逆方向に進むとか、あるいはEvalから組み上げてみる、ってのはどうやら具合が宜しくない模様です。
んで、今回もReadに関する指針は次の通りです。


  1. Perserクラスはクラス変数としてphaseを持つ。また、メソッドはinputメソッド(ここではReadと呼ぶ)のみを持つ(正確には「のみ」しか持てなかった・苦笑)。
  2. Readの挙動は「何も入力が無くてもEvalに情報を渡す」「整数の入力しか受け付けないでその情報を含めてEvalに渡す」「Yes/Noに類する入力だけ受け取ってその情報を含めてEvalに渡す」の3種類とする。
  3. 挙動の変更はゲームのステージを表すクラス変数、phaseを参照して行う。Phaseにはゲームステージがシンボルとして束縛されている。
  4. Read は2値を返す。一つ目はphaseの値をシンボルとして、二つ目は入力値、あるいは入力されない場合は #f (Schemeの偽)返す。
以上の3つです。基本的には1つ目も2つ目も前回のPython版と同じです。
違う点と言うと、まずは、phaseに束縛されてるシンボルと言うLisp族特有のデータ型なんですが、Pythonでは文字列を返した代わりに使っています。
もちろんゲームステージに対して番号ふる処理にしてもいいんですが、やっぱり組んでる人間としては「どのステージでどう言う処理を」って明示された方が分かりやすいんですよね。しかしながら、一般に文字列情報は比較等の演算で時間がかかると言う欠点があるんです。
反面、Lisp族のデータ型シンボルとは、評価過程に於いて唯一無二と言う事が保証されていて、ポインタ比較だけで何の情報が渡されたのか、とすぐ分かるんですね。理論的には文字列を受け渡ししているPython版なんかより遥かに高速に比較処理してくれます。これが大きいです。
しかもプログラム組んでる人間にもどう言う情報で・・・と言うのが一発で分かりますし、Lisp内に於いては数値比較よりも高速だったりします。至れり尽くせり、ああシンボル万歳、たぁLisp好きの合言葉ですね(笑)。
あとは、3番。前回のPython版は二つの情報をまとめた「タプル」と言うデータ型でEvalとやり取りさせてたんですが、このScheme版では本当に二つ値を返しています。これも一部のLisp(特にCommon LispとScheme)では有名な不思議な機能、多値関数と言う機能です。手続きvaluesで包んでやるとあら不思議、いくつもの値を一気に返せるんですってよ、奥様!
まあ、実際はここで使う必然性は実はあんま無かったんですが(笑)、何となくやってみたかっただけです(笑)。実際ホントの事言うと、リストとか便利過ぎて、通常あんま多値の出番がないんですよね(笑)。

まあ、てなワケでコードを見てみますか。ぶっ飛びますよ(笑)。

;;; Read
(define-class parser ()
; クラス変数の初期状態は 'introduction とする
((phase 'introduction))
; 入力メソッド
(input () ;(flush-output) ; Racket 実装依存。コンパイル用
; Racket の実装のせいか、read をletrec 内で定義した
; 再帰内で呼び出すと異常な動作になる為、出力機構自体を
; ループで包まないとならない。同じコードを二度書くのが
; メンドいんで、ローカルマクロで出力用ループを定義した。
(let-syntax ((return-values
(syntax-rules ()
((_ phase proc0 (proc1))
(values phase (let loop ((i (proc1)))
(let ((fact (proc0 i)))
(if (null? fact)
(loop (proc1))
fact))))))))
(letrec ((input-integer
; 整数の入力しか受け付けない
; 違反した場合は空リストを返す
(lambda (var)
(if (integer? var)
var
'())))
(yes-or-no?
; yes no に類する入力しか受け付けない
; 違反した場合は空リストを返す
(lambda (var)
(letrec ((y-or-n?
; yes に類する入力には #t を返す
; no に類する入力には #f を返す
(lambda (sym)
(and (memq sym '(Y YES)) #t)))
(symbol-upcase
; 入力されたシンボルを大文字に直す
(lambda (arg)
(if (symbol? arg)
(string->symbol
(string-upcase
(symbol->string arg)))
'()))))
(let ((sym (symbol-upcase var)))
(if (memq sym '(Y YES N NO))
(y-or-n? sym)
'()))))))
(let ((p (get-class-var parser phase)))
(case p
((input-integer)
(return-values p input-integer (read)))
((instruction play-again?)
(return-values p yes-or-no? (read)))
(else (values p #f))))))))
(define-method input)
view raw parser-class hosted with ❤ by GitHub

さあて、どうでしょうかこれは(笑)。
まずは予告してた通り、Read自体がデータ抽象として設計されてる為、一つのSchemeの手続きとしては明らかに長すぎる印象があるんじゃないでしょうか。つまり、印象的には何でもかんでも詰め込み過ぎてる関数に見える、って事ですね。
加えると、PythonのOOPの場合はselfがあるんで、メソッドをクラス内でバラバラに定義してもお互いに参照可能でした。一方、まあ、今回実装したクラス定義があまりに貧弱だ、って事もあるんですが(笑)、クラス内で定義されたメソッドにクラス内で定義したメソッドは基本的にアクセス出来ません(笑)。自分でやってて「何じゃこりゃ?」とか思ったわけですが(笑)。
詳しく説明すると、define-methodで定義したメソッドはインスタンスを通じてしかメソッド本体にアクセス出来ないんです。

メソッドの書式:
(メソッド インスタンス 引数 ...)

ところが当然、今のように「クラスで定義してる最中にメソッドへのアクセスが出来ない」、つまり内部的に参照しあえない場合は・・・そうですね、メソッド内部でローカル関数として必要な機能を定義してやるしかない、って事になります(だから上のコードはletrecだらけなんです)。
いや、今までPythonのself嫌いで文句ばっか言ってたんですが(笑)、今回初めてPythonのself機構が好きになりましたね(笑)。自分で実際OOP作ってみて分かるその偉大さ(笑)。ああ、そう言う理由でああなんだ、とか実装してみて初めて分かる事ってあるんだなぁ、ってカンジです。
もっとも、良く言われるんですが、PythonでのOOP機構は全部パブリックなんで危険だ、って話もあって、それで言うとプログラム全体で必要な機構をメソッドで外部に出して、他の内部用演算はローカル関数として外部から隠す、と言う上のような書き方の方が安全、って言えば安全かもしれません。ただし見た目の酷さを除けば、ですが(笑)。

取り合えずテストしてみましょうか。実はこれがちょっとしたトラブルがあるんですが、まあ、大まかには予定通り動きます(笑)。

;; Read のテスト
(define p (parser))               ; parser のインスタンス p を生成
class-vars-alist ; クラス変数の表示
(class-var-set! parser phase 'input-integer) ; phase を 'input-integer に変更
class-vars-alist
(input p) ; input メソッド呼び出し
(class-var-set! parser phase 'instruction) ; phase を 'instruction に変更
class-vars-alist
(input p)
(class-var-set! parser phase 'play-again) ; phase を 'play-again に変更
class-vars-alist
(input p)
(class-var-set! parser phase 'foo) ; phase を 'fooに変更
class-vars-alist
(input p)
;; 実行結果
'((parser ((phase . introduction)))) ; phase の初期状態
'((parser ((phase . input-integer)))) ; phase を 'input-integer に変更
foo
bar
baz ; 入力では文字を受け取らない
3.14 ; 浮動小数点数も受け取らない
100 ; 整数が入力されると
'input-integer ; phase と
100 ; 入力された数値の2つが返る
'((parser ((phase . instruction)))) ; phase を 'instruction に変更
foo
bar
baz ; 入力では普通の文字は受け取らない
3.14 ; 浮動小数点数も受け取らない
100 ; 整数も受け取らない
y ; y は yes として受け取り
'instruction ; phase と
#t ; yes 入力時の結果 #t が返る
'((parser ((phase . play-again)))) ; phase を 'play-again に変更
'play-again ; あれれれれれれ?
#f
'((parser ((phase . foo))))
'foo
#f ; この数行は Racket のバグ
>
とまあ、最初の方はテストが通るんですが、途中でRacketがおかしな挙動になるんですよね(苦笑)。成功する場合もあれば失敗する場合もある。なんじゃそりゃ(笑)。
実はRacketの場合、(Lisp族にしては)ゴージャスなIDE付き、って事もあって、なんか特にReadで呼び出される入力機構が立派過ぎるんです(笑)。多分その関係で負荷が高く、平たく言えばこの手の入力テストやると(current-input-port)なり(current-output-port)のflushが上手く行かないんじゃないでしょうか。PLT Schemeの頃はこんな事無かったんだけどな(苦笑)。

まあ、取り合えずテストは通った事にして先に進みますか(ヲイ

Player Class / Computer Class / Tofu Class / Weather Class

先ほども書いた通り、REPLは大まかにはR->E->Pの順序で組み上げて行った方が良い、と言いました。
実は、結構な確率で良くある「LispでLispを作る」例ではこの原則が守られてないんですよね。と言うのも、大体のケースでは「ReadとPrintはLispのそれらを流用する」ってのが前提で、SICPやPAIPなんかの本もその全精力を「Evalの構築」に注ぎます。だから実際にREPLモデルを組む際の順序、と言うのには無頓着なんです。例えばPAIPの著者、Peter Norvigが書いたこのページなんかもそう言う意味ではグチャグチャで、やはり読み込むデータをどう言う風にパーズして渡すのか、決定してからEvalを書いた方が本当は実際的なんじゃないか、って思います。もっとも、本当はそうやってても、テキストを書いた時点で順番入れ替えてるのかもしれませんが。
んで、Eval作成時時点でEvalで使うデータから作っていくわけです。基本的には評価機構がEvalである以上、扱うデータのその殆どは(Printで扱う文字列を除き)Eval絡みになるんじゃないでしょうか。
そんなわけで、まずは(Python版と違って継承が無いので)プレイヤーを表すPlayer Classと対戦相手を表すComputer Classとをそれぞれ、そしてトーフを表すTofu Class、天候を司るWeather Classを作成します。

;;; player クラス
(define-class player ((money 5000) (tofu 0))
()
(money () money)
(money-set! (arg) (set! money arg))
(show-tofu () tofu)
(make-tofu (num env) (let ((maxnum
(maximum (get-tofu env) (get-player env))))
(cond ((> num maxnum) (set! tofu maxnum))
((< num 0) (set! tofu 0))
(else (set! tofu num)))
tofu)))
;;; computer クラス
(define-class computer ((money 5000) (tofu 0))
()
(money () money)
(money-set! (arg) (set! money arg))
(show-tofu () tofu)
(make-tofu (env) (letrec ((calc
(lambda (num)
(let ((maxnum
(quotient money (cost (get-tofu env)))))
(if (> num maxnum)
maxnum
num)))))
; body
(cond ((> (cdr
(assq 'rainy
(weather-report (get-weather env))))
30)
(set! tofu
(is-rainy (get-tofu env))))
((> (cdr
(assq 'sunny
(weather-report (get-weather env))))
49)
(set! tofu (calc (is-sunny (get-tofu env)))))
(else
(set! tofu (calc (is-cloudy (get-tofu env))))))
tofu)))
(define-method money)
(define-method money-set!)
(define-method show-tofu)
(define-method make-tofu)
;;; トーフクラス
(define-class tofu ((cost 40)
(price 50)
(sunny 500)
(cloudy 300)
(rainy 100))
()
(cost () cost)
(price () price)
(is-sunny () sunny)
(is-cloudy () cloudy)
(is-rainy () rainy)
(maximum (player) (quotient (money player) cost)))
(define-method cost)
(define-method price)
(define-method is-sunny)
(define-method is-cloudy)
(define-method is-rainy)
(define-method maximum)
;;; 天候クラス
(define-class weather ((sunny 0)
(cloudy 0)
(rainy 0))
()
; 天気予報の計算
(calc-weather-report () (let ((prob0 (random-integer 100))
(prob1 (random-integer 100)))
; body
(cond ((> prob0 prob1)
(set! sunny (- 100 prob0))
(set! rainy prob1))
(else (set! sunny (- 100 prob1))
(set! rainy prob0)))
(set! cloudy (- 100 sunny rainy))))
; 天気予報
(weather-report () `((sunny . ,sunny)
(cloudy . ,cloudy)
(rainy . ,rainy)))
; 実際の天気
(actual-weather () (let ((r (random-integer 100)))
(cond ((<= r rainy) (values is-rainy 'rainy))
((<= r (+ rainy cloudy)) (values is-cloudy 'cloudy))
(else (values is-sunny 'sunny))))))
(define-method calc-weather-report)
(define-method weather-report)
(define-method actual-weather)



この辺はイイですよね。ロジック的には前回のPython版とほぼ同じですし、シンプルです。フツーに構造体が使える言語でも大体近いカタチで落ち着くんじゃないでしょうか。

Environment Class

で、上記で定義したクラス群を内部に保持する為のEnvironment Classを定義します。これもシンプルに定義出来ますね。

;;; Environment クラス
(define-class environment ((p (player))
(c (computer))
(t (tofu))
(w (weather))
(game-over 30000))
()
(get-player () p)
(player-set! (arg) (set! p (arg)))
(get-computer () c)
(computer-set! (arg) (set! c (arg)))
(get-tofu () t)
(get-weather () w)
(get-game-over () game-over))
(define-method get-player)
(define-method player-set!)
(define-method get-computer)
(define-method computer-set!)
(define-method get-tofu)
(define-method get-weather)
(define-method get-game-over)



これもロジック的には前回とほぼ同じなんでまぁ良いでしょう。ただし、各インスタンスにアクセスするアクセッサもここで定義しておきます。
テストコードの実行結果は以下の通りです。

;; Environment クラスのテスト
(define e (environment)) ; Environment Class のインスタンス変数 e を定義する
(define method-list `(,money ,show-tofu)) ; money , show-tofu と言う二つのメソッドのリストを作成
(map (lambda (x) ; メソッドリストを 環境から (get-player e) で生成されるオブジェクトにマッピングしてみる
(x (get-player e)))
method-list)
(map (lambda (x) ; メソッドリストを 環境から (get-computer e) で生成されるオブジェクトにマッピングしてみる
(x (get-computer e))) 
method-list)
(define tofu-proplist ; トーフの属性から成すリストを作成
`(,price ,cost ,is-sunny ,is-rainy ,is-cloudy))
(map (lambda (x) ; トーフの属性リストを 環境から (get-tofu e) で生成されるオブジェクトにマッピングしてみる
(x (get-tofu e)))
tofu-proplist)
(get-game-over e) ; 環境から game-over になる値を取り出す
;; 実行結果
'(5000 0) ; プレイヤーの初期状態
'(5000 0) ; コンピュータの初期状態
'(50 40 500 100 300) ; トーフのインスタンス変数
30000 ; ゲーム終了条件の金額
>


Lispらしくテストコードでマッピングとかしてみたんですが(笑)。しかし、メソッドの性質によって、どっちがどっちにマッピングしてんだかイマイチ分かりづらいですね(笑)。構文的には逆になってるように見えます(笑)。
ちなみに、例えば(get-player e)ですとこの場合、平たく言うとPlayer Classのインスタンスである、実際のplayerにアクセスしています。要するにplayer変数にアクセスしてるんですね。そしてそれが持ってるインスタンス変数を全部表示するようにして、問題無く各値にアクセス出来る事が分かります。
と言うわけで、いよいよEvalの実装です。

Game-Master Class (Eval)

Game-Master Class(Eval)の大まかな仕様は次の通りです。


  1. インスタンス変数として環境(env: Environment Classのインスタンス)を持つ(もう一つは、YES/NO入力に対しての挙動を変える為のStrange Flagってのをフラグとして持ってますが、これはロジック的には本質的なモノじゃないです)
  2. 唯一、interpメソッドを持っている。これが普通の意味ではEval本体に当たる。
  3. interpは二つの引数を持つ。一つはphase情報、もう一つはReadから渡された入力値、あるいは#fである。
  4. interpはphase情報に従って評価を下し、また次のphase(ゲームステージ)をParserクラスのクラス変数としてセットする。
  5. interpは出力指示情報と計算結果(あれば、あるいは#f)の二つを多値として返す。

とまあ、書く分にはやっぱ簡単で(笑)、特にphaseとして渡されてきたシンボルをcaseで事業仕分け、もとい(古い・笑)適した関数呼び出せばイイんですよね。ロジックは簡単なんですが・・・。
やっぱりPython的にselfで自分のメソッドを呼び出せないんで(笑)、結果としては鬼のようなローカル関数使いまくり、って形式になっちゃってます。

ではソースです。



;;; Eval
(define-class game-master ((env (environment))
(strange-flag #t))
()
(interp (x y) (letrec ((instruction
; ゲームの解説を呼び出す eval
(lambda (x env)
(cond ((eq? x strange-flag)
(set! strange-flag #f)
(values 'instruction #f))
(else (class-var-set! parser phase 'input-integer)
(calc-weather-report (get-weather env))
(values 'show-data env)))))
(calculation
; 翌日にトーフの日割り売上を計上する eval
(lambda (x fact env)
(let ((sold (if (> (show-tofu x) fact)
fact
(show-tofu x))))
(let ((money
(- (+ (money x)
(* sold (price (get-tofu env))))
(* (show-tofu x) (cost (get-tofu env))))))
(money-set! x money)))))
(test-who-is-winner
; ゲームの勝者を計算する eval
(lambda (env)
(letrec ((test
; ゲームの終了条件に達してるか計算
(lambda (env)
(or (>= (money (get-player env))
(get-game-over env))
(>= (money (get-computer env))
(get-game-over env))
(< (money (get-player env))
(cost (get-tofu env)))
(< (money (get-computer env))
(cost (get-tofu env))))))
(who-is-winner
; 終了条件に達してた際に勝者判定
(lambda (env)
(cond ((> (money (get-player env))
(money (get-computer env)))
'you-win)
((< (money (get-player env))
(money (get-computer env)))
'you-lose)
(else 'even)))))
(cond ((test env) (class-var-set! parser phase 'play-again?)
(values 'who-is-winner (who-is-winner env)))
(else (class-var-set! parser phase 'input-integer)
(calc-weather-report (get-weather env))
(values 'show-data env))))))
(play-again?
; 1ゲーム終了後プレイを再開するか尋ねる
(lambda (x env)
(cond (x (class-var-set! parser phase 'input-integer)
(player-set! env player)
(computer-set! env computer)
(calc-weather-report (get-weather env))
(values 'show-data env))
; この両者は Racket 実装依存
; 他の処理系の場合、マニュアルを参照
; Scheme仕様書(R5RS)では実はインタプリタ終了命令
; (exit)が定義されていない。
(else (exit))))))
; body
(case x
((introduction) (class-var-set! parser phase 'instruction)
(values x #f))
((instruction) (instruction y env))
((input-integer) (class-var-set! parser phase 'next-day)
(make-tofu (get-player env) y env)
(let ((num (make-tofu (get-computer env) env)))
(values 'opponent-turn num)))
((next-day) (class-var-set! parser phase 'test)
(let-values (((method sym) (actual-weather (get-weather env))))
(let ((fact (method (get-tofu env))))
(for-each (lambda (x)
(calculation x fact env))
`(,(get-player env) ,(get-computer env)))
(values x sym))))
((test) (test-who-is-winner env))
((play-again?) (play-again? y env))))))
(define-method interp)
view raw eval hosted with ❤ by GitHub
何でしょうね、これは(笑)。ローカル関数内にローカル関数があったりして、たまったモンじゃないです(苦笑)。だから言ったでしょ、フラット(インデントレベルが深くなり過ぎない構文を持つ)に書ける言語にはOOPは合いますが、そもそもこう言う「ネスト大好き!」な言語にはOOPは向かないんですって(笑)。書いた本人でも「何書いてたっけ」って迷子になりました。Python以上ですね(苦笑)。

ではテストコードの実行です。

;; eval のテスト
(define g (game-master)) ; Game Master クラスのインスタンス g を定義。
class-vars-alist ; クラス変数の表示。phase の値に着目。
(interp g 'introduction #t) ; phase が 'introduction、入力値が #t の場合。
class-vars-alist
(interp g 'instruction #t) ; phase が 'instruction、入力値が #t の場合: その1。
class-vars-alist
(interp g 'instruction #t) ; phase が 'instruction、入力値が #t の場合: その2。
class-vars-alist
(interp g 'input-integer 100) ; phase が 'input-integer、入力値が 100 の場合。
class-vars-alist
(interp g 'next-day #f) ; phase が 'next-day、入力値が #f の場合。
class-vars-alist
(interp g 'test #f) ; phase が 'test、入力値が #f の場合。
;; テストの実行結果
'((game-master ()) ; クラス変数はParser Classのみ持ってる事が分かる。値はphase。
(environment ())
(weather ())
(tofu ())
(computer ())
(player ())
(parser ((phase . introduction))))
'introduction ; 返り値はシンボル 'introduction と #f の二つ。
#f
'((parser ((phase . instruction))) ; phase の値が 'instruction に変更されている。
(game-master ())
(environment ())
(weather ())
(tofu ())
(computer ())
(player ()))
'instruction ; 返り値はシンボル 'instruction と #f の二つ。
#f
'((parser ((phase . instruction)))
(game-master ())
(environment ())
(weather ())
(tofu ())
(computer ())
(player ()))
'show-data ; 二回目の呼び出しでは返り値はシンボル 'show-data と クロージャ の二つに変わってる。
#<procedure:...erInIscandar.rkt:47:9> ; (この為だけにstrange-flagがある)
'((parser ((phase . input-integer))) ; phase の値が 'input-integer に変更されている。
(game-master ())
(environment ())
(weather ())
(tofu ())
(computer ())
(player ()))
'opponent-turn ; 返り値はシンボル 'opponent-turn と125と言う整数。
125 ; この125はevalで評価された値で、コンピュータが作ろうとするトーフの数。
'((parser ((phase . next-day))) ; phase の値が 'next-day に変更されている。
(game-master ())
(environment ())
(weather ())
(tofu ())
(computer ())
(player ()))
'next-day ; 返り値は 'next-day と言うシンボルと 'cloudy と言うシンボルの二つ。
'cloudy ; 'cloudy も Evalの評価結果で、「次の日の天気」を確率計算した結果。
'((parser ((phase . test))) ; phase の値が 'test に変更されている。
(game-master ())
(environment ())
(weather ())
(tofu ())
(computer ())
(player ()))
'show-data ; 返り値は 'show-data と言うシンボルとクロージャ。
#<procedure:...erInIscandar.rkt:47:9> ; ここでゲームの二回目のプロセスへと戻る。
view raw test-of-eval hosted with ❤ by GitHub

コードが長い割には結果はシンプルだと言う・・・(笑)。
ま、いっか(笑)。んで、返り値の二つは次のPrint クラスへと手渡されます。

Message Class (Print)

さて、残るはPrint部分だけです。前回のPython版では、ロジック的には「整形表示」を司ってただけでいっちゃん簡単でした。
が・・・・・・。
R5RSでdisplayだけ頼りにして整形表示を自前で計算させる、って無謀な事をやっております(爆)。しまったな、SRFIからformat引っ張ってくれば良かった(とか思っても後の祭り)。
まあ、SRFIを読みこめば読み込む程実装依存度が結果高まってしまうんで(先にも書いた対応処理系自体の事情)しょーがないですか。まあ、formatさえあれば、ホントもっと短く済みます。ホントロジック的には大した事ないんです。

大まかな仕様は以下の通りです。


  1. Message クラスは data と言うインスタンス変数を持ち、それはゲーム中で使う文字列からなるデータに束縛される。より正確には、文字列データをシンボルによりラベル付けされた連想リストがインスタンス変数 data となる。
  2. Message クラスは唯一 Print メソッドを持つ。
  3. Print メソッドは2つの引数をEvalから受け取るものとする。一つ目はどの表示をするか、と言う情報をシンボルで受け取り、二つ目は Eval が出した何らかの評価結果、あるいは #f である。
  4. 評価結果を利用した表示を行う(あるいは#fが入ってきた時は使う必要がない)。

以上です。簡単ですね。
ではコードを。

;;; Print
(define-class message ((data '((introduction . "イスカンダルのトーフ屋ゲーム (scheme版)\n
Copyright (C) 1978-2014 by N.Tsuda\n
ルール説明しますか?[y/n]")
(instruction . "ここはイスカンダル星。あなたはここでトーフ屋を経営し、\n
地球への帰還費用を作り出さなくてはいけません。\n
でもお向かいには、コンピュータが経営するトーフ屋があります。。。\n
\n
トーフの原価は1個40円、販売価格は50円です。\n
1日に売れる個数は天候に左右されます。\n
トーフは日持ちしないので、売れ残った分はすべて廃棄します。\n
そこで、次の日の天気予報を良く見て、何個作るか決心してください。\n
所持金5千円からはじめて早く3万円を超えた方が勝ちです。\n
\n
いいですか?[y/n]")
(1000-yen . #\■)
(empty-yen . #\□)
(next-day . "\n***** 次の日 *****\n")
(weather-is . "今日の天気は")
(result . " です。\n")
(sunny . (#\◎ . "晴れ \\(^o^)/ "))
(cloudy . (#\・ . "くもり (~_~) "))
(rainy . (#\● . "雨 (;_;) "))
(you-win . "あなたの勝ちです。\n\n")
(even . "引き分けです。")
(you-lose . "コンピュータの勝ちです。\n\n")
(play-again? . "play again? [y/n]"))))
()
(print (x y)
(letrec ((show-data
; 現在のデータを表示
(lambda (env)
(letrec ((show-money
; 持ち金に関するデータを表示
(lambda ()
(letrec ((calc
; 整形表示に関する各種演算
(lambda (player)
(letrec ((space-calc
(lambda (x)
(cond ((> x 9999) "")
((> x 999) " ")
((> x 99) " ")
(else " ")))))
(let ((x (money player)))
(let ((y (quotient x 1000)))
(values (space-calc x)
(number->string x)
(make-string y
(cdr (assq '1000-yen data)))
(make-string (- 30 y)
(cdr (assq 'empty-yen data))))))))))
(let-values (((p0 p1 p2 p3) (calc (get-player env))))
(let-values (((c0 c1 c2 c3) (calc (get-computer env))))
(string-append "\n所持金: \nあなた "
p0 p1 "円 " p2 p3
"\nわたし "
c0 c1 "円 " c2 c3
"\n\n"))))))
(show-weather-report
; 天気予報に関するデータを表示
(lambda ()
(letrec
((calc
; 整形表示に関する各種演算
(lambda ()
(let ((wr (weather-report (get-weather env)))
(keys '(sunny cloudy rainy)))
(let ((table (map (lambda (x)
`(,x . ,(quotient (* 40 (cdr (assq x wr))) 100)))
keys)))
(append (map (lambda (x)
(number->string (cdr (assq x wr))))
keys)
(map (lambda (x)
(make-string (cdr (assq x table)) (cadr (assq x data))))
keys)))))))
(let ((string-list (calc)))
(string-append "明日の天気予報: 晴れ "
(list-ref string-list 0)
"% くもり "
(list-ref string-list 1)
"% 雨 "
(list-ref string-list 2)
"%\n"
(list-ref string-list 3)
(list-ref string-list 4)
(list-ref string-list 5)
"\n\n")))))
(show-howmany-tofus
; トーフをいくつ作るか質問表示
(lambda ()
(string-append "\nトーフを何個作りますか? (1~"
(number->string
(maximum (get-tofu env) (get-player env)))
") "))))
(string-append (show-money)
(show-weather-report)
(show-howmany-tofus)))))
(show-computer-reply
; コンピュータの決定を表示
(lambda (num)
(string-append "わたしは"
(number->string num)
"個作ります。\n")))
(show-result
; 翌日のトーフ売上表示
(lambda (sym)
(string-append
(cddr (assq sym data))
(cdr (assq 'result data))))))
; Body
(for-each (lambda (x)
; sleep はRacket 実装依存
; SRFI-18が使える処理系なら
; 冒頭で呼び出し、thread-sleep
; が代わりに使える
; 他の場合は、各実装のマニュアル参照の事
(sleep 0.5)
(display x))
(case x
((show-data) `(,(show-data y)))
((opponent-turn) `(,(show-computer-reply y)))
((next-day) `(,(cdr (assq 'next-day data))
,(cdr (assq 'weather-is data))
"." "." "."
,(show-result y)))
((who-is-winner) (map (lambda (z)
(cdr (assq z data)))
`(,y play-again?)))
(else `(,(cdr (assq x data)))))))))
(define-method print)
view raw print hosted with ❤ by GitHub
ご覧の通りです。
デカくなってる理由は仕様にも書いた通り、ゲームで扱う文字列情報を連想リストとして持ってる為、また、R5RSに準じると、文字列整形用に指定子等が使えない為、ローカル関数の殆どは「整形用の演算」を行ってるのです。先に書いた用に、SRFI辺りからformatを持ってくるとかすれば殆どの処理は書かずに済むでしょう。
(例えば数値表示をケツで揃える為、頭に何個スペースを入れるか、なんて計算したりして、自分でやりながら笑ってました・笑)

ではテストコードです。

;;; Print のテスト
(define p (message)) ; Message クラスのインスタンス p を生成。
(define e (environment)) ; Environment クラスのインスタンス e を生成。
(print p 'introduction #f) ; シンボル 'introduction と #f を引数として print メソッドを呼び出す。
(print p 'instruction #t) ; シンボル 'instruction と #t を引数として print メソッドを呼び出す。
(print p 'instruction #f) ; シンボル 'instruction と #f を引数として print メソッドを呼び出す。
(print p 'show-data e) ; シンボル 'show-data と 環境インスタンス e を引数として print メソッドを呼び出す。
(print p 'opponent-turn (make-tofu (get-computer e) e)) ; シンボル 'opponent-turn と 環境を参照してコンピュータにトーフを作らせる。
(print p 'next-day 'sunny) ; シンボル 'next-day と シンボル 'sunny を引数として print メソッドを呼び出す。
(print p 'next-day 'cloudy) ; シンボル 'next-day と シンボル 'cloudy を引数として print メソッドを呼び出す。
(print p 'next-day 'rainy) ; シンボル 'next-day と シンボル 'rainy を引数として print メソッドを呼び出す。
;;; テスト結果
イスカンダルのトーフ屋ゲーム (scheme版) ; (print p 'introduction #f)の結果
Copyright (C) 1978-2014 by N.Tsuda
ルール説明しますか?[y/n]
ここはイスカンダル星。あなたはここでトーフ屋を経営し、 ; (print p 'instruction #t) の結果
地球への帰還費用を作り出さなくてはいけません。
でもお向かいには、コンピュータが経営するトーフ屋があります。。。
トーフの原価は1個40円、販売価格は50円です。
1日に売れる個数は天候に左右されます。
トーフは日持ちしないので、売れ残った分はすべて廃棄します。
そこで、次の日の天気予報を良く見て、何個作るか決心してください。
所持金5千円からはじめて早く3万円を超えた方が勝ちです。
いいですか?[y/n]
ここはイスカンダル星。あなたはここでトーフ屋を経営し、 ; (print p 'instruction #f) の結果。
地球への帰還費用を作り出さなくてはいけません。 ; もう一度同じモノを表示する理由は、Eval 内の strange-flag の効果。
でもお向かいには、コンピュータが経営するトーフ屋があります。。。
トーフの原価は1個40円、販売価格は50円です。
1日に売れる個数は天候に左右されます。
トーフは日持ちしないので、売れ残った分はすべて廃棄します。
そこで、次の日の天気予報を良く見て、何個作るか決心してください。
所持金5千円からはじめて早く3万円を超えた方が勝ちです。
いいですか?[y/n]
所持金: ; (print p 'show-data e) の結果。
あなた 5000円 ■■■■■□□□□□□□□□□□□□□□□□□□□□□□□□
わたし 5000円 ■■■■■□□□□□□□□□□□□□□□□□□□□□□□□□
明日の天気予報: 晴れ 0% くもり 0% 雨 0%
トーフを何個作りますか? (1~125)
わたしは125個作ります。 ; (print p 'opponent-turn (make-tofu (get-computer e) e)) の結果
***** 次の日 ***** ; (print p 'next-day 'sunny) の結果
今日の天気は...晴れ \(^o^)/ です。
***** 次の日 ***** ; (print p 'next-day 'cloudy) の結果
今日の天気は...くもり (~_~) です。
***** 次の日 ***** ; (print p 'next-day 'rainy) の結果
今日の天気は...雨 (;_;) です。
>
view raw test-of-print hosted with ❤ by GitHub

おお、やっぱ表示が出てくると一気にゲームっぽさが出てきますね。ここに到達するまでが大変で、それまではテストコードなんか打っても無味乾燥な値が返ってくるだけですしねぇ(苦笑)。
まあ、もちろん説明するべくもないでしょうが、このテストコードに引数として与えた値は、実際Evalが返すだろう事を想定した値となっています。
では、いよいよREPLを組み上げます。

REPL(Read-Eval-Print-Loop)

「組み上げる」とは言っても、ここまで来ると大した仕事は残ってないんですけどね。
以下にREPLのコードをあげておきます。

;;; REPL
(define (repl)
(let ((r (parser)) ; Parser クラスのインスタンスを束縛
(e (game-master)) ; Game-Master クラスのインスタンスを束縛
(p (message))) ; Message クラスのインスタンスを束縛
(let loop ()
(let-values (((phase0 info0) (input r)))
(let-values (((phase1 info1) (interp e phase0 info0)))
(print p phase1 info1)))
(loop))))
(repl) ; ゲーム起動
view raw repl hosted with ❤ by GitHub


基本的には大したこたぁないです。
注意点は、今回はRead、Eval、Print、の3つとも多値(2値)を返すメソッドとして実装されてるので、SRFI-11のlet-valuesと言う機能を用いてそれら多値を束縛して次のメソッドに渡すようにしています。
まあ、一番最初の方で書きましたが、Schemeプログラミングに於いてあんま多値使う局面ってそんなに無いんで、使わないで、例えばリストなんかで結果を返しても良いんですが、一方、consは結構計算コストがあるんで、そう言う意味では多値を使う事である程度の「速度向上」は見なせる模様です。

イスカンダルのトーフ屋ゲーム (Scheme 版) のソースコード

では、全部のソースコードを改めて貼っつけておきます。

#lang racket
;;;;; made on PLT Racket
;;;;; Racket:
;;;;; http://racket-lang.org/
; Racket 実装依存
; 他の処理系の場合、SRFI(Schemeの共有ライブラリ)を呼び出すには
; Gauche: http://practical-scheme.net/gauche/index-j.html
; (use srfi-1) ...
; Guile: http://www.gnu.org/software/guile/
; (srfi srfi-1) ...
; 等に書き換える
(require srfi/1 srfi/11 srfi/13 srfi/27)
;; コンパイル用の文字エンコードの指定(Racket 実装依存)
;; Racket のバグの為、日本語版だとコンパイルされたものが落ちる
;(current-input-port (reencode-input-port (current-input-port)
; "shift_jis"))
;(current-output-port (reencode-output-port (current-output-port)
; "shift_jis"))
;;; 乱数の初期化
(random-source-randomize! (make-random-source))
;;; データ駆動型プログラミングの為のマクロ
;; 総称プロシージャ用連想リスト
(define generic-proc '())
;; クラス変数用連想リスト
(define class-vars-alist '())
;; クラス定義用マクロ
(define-syntax define-class
(syntax-rules ()
((_ class (inst-var ...)
((class-var class-val) ...)
(method arg body ...) ...)
(begin
(set! class-vars-alist
(cons `(class ((class-var . ,class-val) ...))
class-vars-alist))
(for-each ensure-generic-proc '(method ...))
(define (class inst-var ...)
(lambda (message)
(case message
((method) (lambda arg body ...))
...)))))))
(define (get-method object message)
(object message))
(define (ensure-generic-proc message)
(if (assq message generic-proc)
#f
(let ((proc (lambda (object . args)
(apply (get-method object message) args))))
(set! generic-proc
(alist-cons message proc generic-proc)))))
(define-syntax get-class-var
(syntax-rules ()
((_ class var)
(cdr (assq 'var
(cadr (assq 'class class-vars-alist)))))))
(define-syntax class-var-set!
(syntax-rules ()
((_ class var val)
(let ((alist
(alist-cons 'var val
(alist-delete 'var
(cadr (assq 'class class-vars-alist))))))
(set! class-vars-alist
(cons `(class ,alist)
(alist-delete 'class class-vars-alist)))))))
;; メソッド定義用マクロ
(define-syntax define-method
(syntax-rules ()
((_ method)
(define method (cdr (assq 'method generic-proc))))))
;;; クラス定義のテスト
;
;(define-class account (name (balance 0))
; ((interest-rate .06))
; (withdraw (amt) (cond ((<= amt balance)
; (set! balance (- balance amt))
; balance)
; (else 'insufficient-funds)))
; (deposit (amt) (set! balance (+ balance amt))
; balance)
; (balance () balance)
; (name () name)
; (interest () (set! balance
; (+ balance (* (get-class-var account interest-rate) balance)))
; balance))
;
;(define-method withdraw)
;(define-method deposit)
;(define-method balance)
;(define-method name)
;(define-method interest)
;
;class-vars-alist
;generic-proc
;
;(define acct (account "A. User" 2000))
;(= (deposit acct 42) 2042)
;(= (interest acct) 2164.52)
;(= (balance acct) 2164.52)
;;; Read
(define-class parser ()
; クラス変数の初期状態は 'introduction とする
((phase 'introduction))
; 入力メソッド
(input () ;(flush-output) ; Racket 実装依存。コンパイル用
; Racket の実装のせいか、read をletrec 内で定義した
; 再帰内で呼び出すと異常な動作になる為、出力機構自体を
; ループで包まないとならない。同じコードを二度書くのが
; メンドいんで、ローカルマクロで出力用ループを定義した。
(let-syntax ((return-values
(syntax-rules ()
((_ phase proc0 (proc1))
(values phase (let loop ((i (proc1)))
(let ((fact (proc0 i)))
(if (null? fact)
(loop (proc1))
fact))))))))
(letrec ((input-integer
; 整数の入力しか受け付けない
; 違反した場合は空リストを返す
(lambda (var)
(if (integer? var)
var
'())))
(yes-or-no?
; yes no に類する入力しか受け付けない
; 違反した場合は空リストを返す
(lambda (var)
(letrec ((y-or-n?
; yes に類する入力には #t を返す
; no に類する入力には #f を返す
(lambda (sym)
(and (memq sym '(Y YES)) #t)))
(symbol-upcase
; 入力されたシンボルを大文字に直す
(lambda (arg)
(if (symbol? arg)
(string->symbol
(string-upcase
(symbol->string arg)))
'()))))
(let ((sym (symbol-upcase var)))
(if (memq sym '(Y YES N NO))
(y-or-n? sym)
'()))))))
(let ((p (get-class-var parser phase)))
(case p
((input-integer)
(return-values p input-integer (read)))
((instruction play-again?)
(return-values p yes-or-no? (read)))
(else (values p #f))))))))
(define-method input)
;; Read のテスト
;
;(define p (parser))
;class-vars-alist
;(class-var-set! parser phase 'input-integer)
;class-vars-alist
;(input p)
;(class-var-set! parser phase 'instruction)
;class-vars-alist
;(input p)
;(class-var-set! parser phase 'play-again)
;class-vars-alist
;(input p)
;(class-var-set! parser phase 'foo)
;class-vars-alist
;(input p)
;;; player クラス
(define-class player ((money 5000) (tofu 0))
()
(money () money)
(money-set! (arg) (set! money arg))
(show-tofu () tofu)
(make-tofu (num env) (let ((maxnum
(maximum (get-tofu env) (get-player env))))
(cond ((> num maxnum) (set! tofu maxnum))
((< num 0) (set! tofu 0))
(else (set! tofu num)))
tofu)))
;;; computer クラス
(define-class computer ((money 5000) (tofu 0))
()
(money () money)
(money-set! (arg) (set! money arg))
(show-tofu () tofu)
(make-tofu (env) (letrec ((calc
(lambda (num)
(let ((maxnum
(quotient money (cost (get-tofu env)))))
(if (> num maxnum)
maxnum
num)))))
; body
(cond ((> (cdr
(assq 'rainy
(weather-report (get-weather env))))
30)
(set! tofu
(is-rainy (get-tofu env))))
((> (cdr
(assq 'sunny
(weather-report (get-weather env))))
49)
(set! tofu (calc (is-sunny (get-tofu env)))))
(else
(set! tofu (calc (is-cloudy (get-tofu env))))))
tofu)))
(define-method money)
(define-method money-set!)
(define-method show-tofu)
(define-method make-tofu)
;;; トーフクラス
(define-class tofu ((cost 40)
(price 50)
(sunny 500)
(cloudy 300)
(rainy 100))
()
(cost () cost)
(price () price)
(is-sunny () sunny)
(is-cloudy () cloudy)
(is-rainy () rainy)
(maximum (player) (quotient (money player) cost)))
(define-method cost)
(define-method price)
(define-method is-sunny)
(define-method is-cloudy)
(define-method is-rainy)
(define-method maximum)
;;; 天候クラス
(define-class weather ((sunny 0)
(cloudy 0)
(rainy 0))
()
; 天気予報の計算
(calc-weather-report () (let ((prob0 (random-integer 100))
(prob1 (random-integer 100)))
; body
(cond ((> prob0 prob1)
(set! sunny (- 100 prob0))
(set! rainy prob1))
(else (set! sunny (- 100 prob1))
(set! rainy prob0)))
(set! cloudy (- 100 sunny rainy))))
; 天気予報
(weather-report () `((sunny . ,sunny)
(cloudy . ,cloudy)
(rainy . ,rainy)))
; 実際の天気
(actual-weather () (let ((r (random-integer 100)))
(cond ((<= r rainy) (values is-rainy 'rainy))
((<= r (+ rainy cloudy)) (values is-cloudy 'cloudy))
(else (values is-sunny 'sunny))))))
(define-method calc-weather-report)
(define-method weather-report)
(define-method actual-weather)
;;; Environment クラス
(define-class environment ((p (player))
(c (computer))
(t (tofu))
(w (weather))
(game-over 30000))
()
(get-player () p)
(player-set! (arg) (set! p (arg)))
(get-computer () c)
(computer-set! (arg) (set! c (arg)))
(get-tofu () t)
(get-weather () w)
(get-game-over () game-over))
(define-method get-player)
(define-method player-set!)
(define-method get-computer)
(define-method computer-set!)
(define-method get-tofu)
(define-method get-weather)
(define-method get-game-over)
;;; Environment クラスのテスト
;
;(define e (environment))
;(define method-list `(,money ,show-tofu))
;(map (lambda (x)
; (x (get-player e)))
; method-list)
;(map (lambda (x)
; (x (get-computer e)))
; method-list)
;(define tofu-proplist
; `(,price ,cost ,is-sunny ,is-rainy ,is-cloudy))
;(map (lambda (x)
; (x (get-tofu e)))
; tofu-proplist)
;(get-game-over e)
;;; Eval
(define-class game-master ((env (environment))
(strange-flag #t))
()
(interp (x y) (letrec ((instruction
; ゲームの解説を呼び出す eval
(lambda (x env)
(cond ((eq? x strange-flag)
(set! strange-flag #f)
(values 'instruction #f))
(else (class-var-set! parser phase 'input-integer)
(calc-weather-report (get-weather env))
(values 'show-data env)))))
(calculation
; 翌日にトーフの日割り売上を計上する eval
(lambda (x fact env)
(let ((sold (if (> (show-tofu x) fact)
fact
(show-tofu x))))
(let ((money
(- (+ (money x)
(* sold (price (get-tofu env))))
(* (show-tofu x) (cost (get-tofu env))))))
(money-set! x money)))))
(test-who-is-winner
; ゲームの勝者を計算する eval
(lambda (env)
(letrec ((test
; ゲームの終了条件に達してるか計算
(lambda (env)
(or (>= (money (get-player env))
(get-game-over env))
(>= (money (get-computer env))
(get-game-over env))
(< (money (get-player env))
(cost (get-tofu env)))
(< (money (get-computer env))
(cost (get-tofu env))))))
(who-is-winner
; 終了条件に達してた際に勝者判定
(lambda (env)
(cond ((> (money (get-player env))
(money (get-computer env)))
'you-win)
((< (money (get-player env))
(money (get-computer env)))
'you-lose)
(else 'even)))))
(cond ((test env) (class-var-set! parser phase 'play-again?)
(values 'who-is-winner (who-is-winner env)))
(else (class-var-set! parser phase 'input-integer)
(calc-weather-report (get-weather env))
(values 'show-data env))))))
(play-again?
; 1ゲーム終了後プレイを再開するか尋ねる
(lambda (x env)
(cond (x (class-var-set! parser phase 'input-integer)
(player-set! env player)
(computer-set! env computer)
(calc-weather-report (get-weather env))
(values 'show-data env))
; この両者は Racket 実装依存
; 他の処理系の場合、マニュアルを参照
; Scheme仕様書(R5RS)では実はインタプリタ終了命令
; (exit)が定義されていない。
(else (exit))))))
; body
(case x
((introduction) (class-var-set! parser phase 'instruction)
(values x #f))
((instruction) (instruction y env))
((input-integer) (class-var-set! parser phase 'next-day)
(make-tofu (get-player env) y env)
(let ((num (make-tofu (get-computer env) env)))
(values 'opponent-turn num)))
((next-day) (class-var-set! parser phase 'test)
(let-values (((method sym) (actual-weather (get-weather env))))
(let ((fact (method (get-tofu env))))
(for-each (lambda (x)
(calculation x fact env))
`(,(get-player env) ,(get-computer env)))
(values x sym))))
((test) (test-who-is-winner env))
((play-again?) (play-again? y env))))))
(define-method interp)
;;; eval のテスト
;
;(define g (game-master))
;class-vars-alist
;(interp g 'introduction #t)
;class-vars-alist
;(interp g 'instruction #t)
;class-vars-alist
;(interp g 'instruction #t)
;class-vars-alist
;(interp g 'input-integer 100)
;class-vars-alist
;(interp g 'next-day #f)
;class-vars-alist
;(interp g 'test #f)
;;; Print
(define-class message ((data '((introduction . "イスカンダルのトーフ屋ゲーム (scheme版)\n
Copyright (C) 1978-2014 by N.Tsuda\n
ルール説明しますか?[y/n]")
(instruction . "ここはイスカンダル星。あなたはここでトーフ屋を経営し、\n
地球への帰還費用を作り出さなくてはいけません。\n
でもお向かいには、コンピュータが経営するトーフ屋があります。。。\n
\n
トーフの原価は1個40円、販売価格は50円です。\n
1日に売れる個数は天候に左右されます。\n
トーフは日持ちしないので、売れ残った分はすべて廃棄します。\n
そこで、次の日の天気予報を良く見て、何個作るか決心してください。\n
所持金5千円からはじめて早く3万円を超えた方が勝ちです。\n
\n
いいですか?[y/n]")
(1000-yen . #\■)
(empty-yen . #\□)
(next-day . "\n***** 次の日 *****\n")
(weather-is . "今日の天気は")
(result . " です。\n")
(sunny . (#\◎ . "晴れ \\(^o^)/ "))
(cloudy . (#\・ . "くもり (~_~) "))
(rainy . (#\● . "雨 (;_;) "))
(you-win . "あなたの勝ちです。\n\n")
(even . "引き分けです。")
(you-lose . "コンピュータの勝ちです。\n\n")
(play-again? . "play again? [y/n]"))))
()
(print (x y)
(letrec ((show-data
; 現在のデータを表示
(lambda (env)
(letrec ((show-money
; 持ち金に関するデータを表示
(lambda ()
(letrec ((calc
; 整形表示に関する各種演算
(lambda (player)
(letrec ((space-calc
(lambda (x)
(cond ((> x 9999) "")
((> x 999) " ")
((> x 99) " ")
(else " ")))))
(let ((x (money player)))
(let ((y (quotient x 1000)))
(values (space-calc x)
(number->string x)
(make-string y
(cdr (assq '1000-yen data)))
(make-string (- 30 y)
(cdr (assq 'empty-yen data))))))))))
(let-values (((p0 p1 p2 p3) (calc (get-player env))))
(let-values (((c0 c1 c2 c3) (calc (get-computer env))))
(string-append "\n所持金: \nあなた "
p0 p1 "円 " p2 p3
"\nわたし "
c0 c1 "円 " c2 c3
"\n\n"))))))
(show-weather-report
; 天気予報に関するデータを表示
(lambda ()
(letrec
((calc
; 整形表示に関する各種演算
(lambda ()
(let ((wr (weather-report (get-weather env)))
(keys '(sunny cloudy rainy)))
(let ((table (map (lambda (x)
`(,x . ,(quotient (* 40 (cdr (assq x wr))) 100)))
keys)))
(append (map (lambda (x)
(number->string (cdr (assq x wr))))
keys)
(map (lambda (x)
(make-string (cdr (assq x table)) (cadr (assq x data))))
keys)))))))
(let ((string-list (calc)))
(string-append "明日の天気予報: 晴れ "
(list-ref string-list 0)
"% くもり "
(list-ref string-list 1)
"% 雨 "
(list-ref string-list 2)
"%\n"
(list-ref string-list 3)
(list-ref string-list 4)
(list-ref string-list 5)
"\n\n")))))
(show-howmany-tofus
; トーフをいくつ作るか質問表示
(lambda ()
(string-append "\nトーフを何個作りますか? (1~"
(number->string
(maximum (get-tofu env) (get-player env)))
") "))))
(string-append (show-money)
(show-weather-report)
(show-howmany-tofus)))))
(show-computer-reply
; コンピュータの決定を表示
(lambda (num)
(string-append "わたしは"
(number->string num)
"個作ります。\n")))
(show-result
; 翌日のトーフ売上表示
(lambda (sym)
(string-append
(cddr (assq sym data))
(cdr (assq 'result data))))))
; Body
(for-each (lambda (x)
; sleep はRacket 実装依存
; SRFI-18が使える処理系なら
; 冒頭で呼び出し、thread-sleep
; が代わりに使える
; 他の場合は、各実装のマニュアル参照の事
(sleep 0.5)
(display x))
(case x
((show-data) `(,(show-data y)))
((opponent-turn) `(,(show-computer-reply y)))
((next-day) `(,(cdr (assq 'next-day data))
,(cdr (assq 'weather-is data))
"." "." "."
,(show-result y)))
((who-is-winner) (map (lambda (z)
(cdr (assq z data)))
`(,y play-again?)))
(else `(,(cdr (assq x data)))))))))
(define-method print)
;;;; Print のテスト
;
;(define p (message))
;(define e (environment))
;(print p 'introduction #f)
;(print p 'instruction #t)
;(print p 'instruction #f)
;(print p 'show-data e)
;(print p 'opponent-turn (make-tofu (get-computer e) e))
;(print p 'next-day 'sunny)
;(print p 'next-day 'cloudy)
;(print p 'next-day 'rainy)
;;; REPL
(define (repl)
(let ((r (parser))
(e (game-master))
(p (message)))
(let loop ()
(let-values (((phase0 info0) (input r)))
(let-values (((phase1 info1) (interp e phase0 info0)))
(print p phase1 info1)))
(loop))))
(repl)

こう見てみると各クラスは大きいわ、長いわ、でサイテーですね(笑)。まあ、コメントなんかもありますが、600行近くあります。
「Schemeらしく」関数型でプログラミングすればもっと縮まるんじゃねぇの、ってんで、実は既に関数プログラミング版作ってみたんですが、案の定 2/3 程度に圧縮されました。しかももっと綺麗(笑)。破壊的操作が一切ありません。
やっぱLisp系には少なくともOOPは向かねえんじゃねぇのかなぁ。良く、グラフィックスに関しては昔はLispが優れてた、とか言いますが、OOP前提での今の世の中ですと、昔日のアドヴァンテージはあんま持てないんじゃないでしょうか。OOPで書かれたライブラリとやり取り(特に多重継承)して、CLIをGUIに簡単に変更、ってなわけにゃ行きそうもないですから。
まあ、あくまで個人的にOOPをもっと理解したい、って為の実験ですし、OOP使うならPythonで書いた方がよりシンプルっぽいですね。

ちなみに、今回も実行形式作ろうってトライしてみたんですが、Racketのコンパイラが文字コード周りにバグがあるらしくって、日本語でコンパイルすると作成されたexecutableがすぐ落ちちゃうんですね。
そんなわけで、今回は実行形式は無し、です。