イスカンダルのトーフ屋ゲーム 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処理系でもインポート出来る、ってポータブルな意味でのライブラリじゃないんで嫌なんです(笑)。まあでも、今回は、少なくともGaucheとGuileの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
	>

view raw test-of-hand-made-OOP hosted with ❤ by GitHub

と言うわけで、ちと不格好な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 のバグ
	>

view raw test-of-parser-class hosted with ❤ by GitHub

とまあ、最初の方はテストが通るんですが、途中で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)

view raw player-computer-tofu-and-weather-classes hosted with ❤ by GitHub

この辺はイイですよね。ロジック的には前回の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)

view raw envitonment-class hosted with ❤ by GitHub

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

	;; 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 ; ゲーム終了条件の金額
	>

view raw test-of-environment-class hosted with ❤ by GitHub

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)

view raw TofuSellersInIscandar hosted with ❤ by GitHub

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

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