TofuSellersInIscandarFn

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