#lang racket
(require 2htdp/universe 2htdp/image)
;;; シナリオのロード
(define *scenario*
(with-input-from-file "img8/scenario-rkt.txt"
(lambda ()
(let loop ((s-expression (read)) (acc '()))
(if (eof-object? s-expression)
(reverse acc)
(loop (read) (cons s-expression acc)))))))
;;; World構造体の定義
(struct world
(back branches characters color message scenario)
#:transparent)
;;; 画像サイズ、位置情報
(define *width* 900)
(define *height* 460)
(define *window* (empty-scene *width* *height* "Medium Gray"))
;;; メッセージの初期状態
(define *init-message* "Enter/Spaceでスタート")
;;; 終了メッセージ
(define *end-message* "終わり")
;;; バックグラウンドの設計
(define (place-back back scene)
(if back
(place-image (bitmap/file back)
(/ *width* 2)
(/ *height* 2)
scene)
scene))
;;; キャラクター表示
(define (place-character char-info scene)
(place-image
(bitmap/file (car char-info))
(case (cadr char-info)
((L) 200)
((R) 700)
(else 450))
160
scene))
(define (place-characters characters scene)
(if (null? characters)
scene
(place-characters (cdr characters)
(place-character
(car characters)
scene))))
;;; メッセージ表示関連
(define (message-area scene)
(place-image
(rectangle 840 100 "solid" "white")
(/ *width* 2)
(* (/ *height* 4) 3)
scene))
(define (place-message message scene)
(place-image/align
(text (string-replace message "~%" "\n") 17 "black")
60
294
"left" "top"
scene))
;;; 選択肢表示
(define (place-branch branch color scene)
(let ((num (car branch)))
(place-image (text (second branch) 20 "black")
(/ *width* 2)
(+ 70 (* num 70))
(place-image
(rectangle 300 25 "solid"
(if (= num color) "white" "Medium gray"))
(/ *width* 2)
(+ 70 (* num 70))
scene))))
(define (place-branches branches color scene)
(if (null? branches)
scene
(place-branches (cdr branches) color
(place-branch
(car branches) color scene))))
;;; ウィンドゥ表示
(define (place-world w)
(place-branches
(world-branches w)
(world-color w)
(place-message
(world-message w)
(message-area
(place-characters
(world-characters w)
(place-back
(world-back w)
*window*))))))
;; ジャンプ先を探す補助関数定義
(define (find-label x scenario)
(unless (null? scenario)
(let ((s-expression (car scenario)))
(let ((head (car s-expression)) (tail (cdr s-expression)))
(if (and (eq? head 'label) (eq? (car tail) x))
(cdr scenario)
(find-label x (cdr scenario)))))))
;; シナリオ制御
(define (world-go w delta)
(let loop ((back (world-back w))
(branches (world-branches w))
(characters (world-characters w))
(color (world-color w))
(message (world-message w))
(scenario (world-scenario w)))
(let ((s-expression (car scenario)))
(let ((head (car s-expression)) (tail (cdr s-expression)))
; ;; デバッグ用
; (display
; (format "branches: ~a\ncolor: ~a
;instruction: ~a\ntail: ~a\ninput: ~a\n"
; branches color head tail delta))
(case head
((back) (loop (car tail) branches '()
color message (cdr scenario)))
((branch) (loop back (cons tail branches) characters
color message (cdr scenario)))
((break) (cond ((string=? delta "up")
(world back branches characters
1 message scenario))
((string=? delta "down")
(world back branches characters
2 message scenario))
((or (string=? delta "1")
(string=? delta "2"))
(world-go
(world back '() characters
color message
(find-label
(third (assv
(string->number delta)
branches))
scenario)) "\r"))
((or (string=? delta "y")
(string=? delta "n"))
(world-go
(world back '() characters
color message
(find-label
(second (assoc delta
(map reverse branches)))
scenario)) "\r"))
((or (string=? "\r")
(string=? " "))
(world-go
(world back '() characters
color message
(find-label
(third
(assv color branches))
scenario))
"\r"))
(else
(world back branches characters
color message scenario))))
((end) (world back branches characters
color *end-message* scenario))
((jump) (world-go
(world back branches characters
color message (find-label
(car tail) scenario))
"\r"))
((label) (world back branches characters color message
(cons '(break) scenario)))
((msg) (world back branches characters
color (car tail)
(if (or (string=? delta " ")
(string=? delta "\r"))
(cdr scenario)
scenario)))
((putChar) (loop back branches
(if (member tail characters)
characters
(cons tail characters))
color message (cdr scenario)))
(else (error "Can't do " head)))))))
;; 入力制御
(define (change w a-key)
(cond ((key=? a-key "\r") (world-go w "\r"))
((key=? a-key " ") (world-go w " "))
((key=? a-key "1") (world-go w "1"))
((key=? a-key "2") (world-go w "2"))
((key=? a-key "y") (world-go w "y"))
((key=? a-key "n") (world-go w "n"))
((key=? a-key "up") (world-go w "up"))
((key=? a-key "down") (world-go w "down"))
(else w)))
;; ゲーム終了条件
(define (game-ends? w)
(string=? (world-message w) *end-message*))
;; イベントループ
(big-bang (world #f '() '() 1 *init-message* *scenario*)
(on-key change)
(to-draw place-world)
(stop-when game-ends? place-world)
(name "よろしくアドベンチャー")
;; デバッグ用
; (state world)
)