TofuSellersInIscandar

#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)