fork download
  1. #lang racket
  2.  
  3. (require 2htdp/universe 2htdp/image)
  4.  
  5. ;;; シナリオのロード
  6.  
  7. (define *scenario*
  8. (with-input-from-file "img8/scenario-rkt.txt"
  9. (lambda ()
  10. (let loop ((s-expression (read)) (acc '()))
  11. (if (eof-object? s-expression)
  12. (reverse acc)
  13. (loop (read) (cons s-expression acc)))))))
  14.  
  15. ;;; World構造体の定義
  16.  
  17. (struct world
  18. (back branches characters color message scenario)
  19. #:transparent)
  20.  
  21. ;;; 画像サイズ、位置情報
  22.  
  23. (define *width* 900)
  24. (define *height* 460)
  25.  
  26. (define *window* (empty-scene *width* *height* "Medium Gray"))
  27.  
  28. ;;; メッセージの初期状態
  29.  
  30. (define *init-message* "Enter/Spaceでスタート")
  31.  
  32. ;;; 終了メッセージ
  33.  
  34. (define *end-message* "終わり")
  35.  
  36. ;;; バックグラウンドの設計
  37.  
  38. (define (place-back back scene)
  39. (if back
  40. (place-image (bitmap/file back)
  41. (/ *width* 2)
  42. (/ *height* 2)
  43. scene)
  44. scene))
  45.  
  46. ;;; キャラクター表示
  47.  
  48. (define (place-character char-info scene)
  49. (place-image
  50. (bitmap/file (car char-info))
  51. (case (cadr char-info)
  52. ((L) 200)
  53. ((R) 700)
  54. (else 450))
  55. 160
  56. scene))
  57.  
  58. (define (place-characters characters scene)
  59. (if (null? characters)
  60. scene
  61. (place-characters (cdr characters)
  62. (place-character
  63. (car characters)
  64. scene))))
  65.  
  66. ;;; メッセージ表示関連
  67.  
  68. (define (message-area scene)
  69. (place-image
  70. (rectangle 840 100 "solid" "white")
  71. (/ *width* 2)
  72. (* (/ *height* 4) 3)
  73. scene))
  74.  
  75. (define (place-message message scene)
  76. (place-image/align
  77. (text (string-replace message "~%" "\n") 17 "black")
  78. 60
  79. 294
  80. "left" "top"
  81. scene))
  82.  
  83. ;;; 選択肢表示
  84.  
  85. (define (place-branch branch color scene)
  86. (let ((num (car branch)))
  87. (place-image (text (second branch) 20 "black")
  88. (/ *width* 2)
  89. (+ 70 (* num 70))
  90. (place-image
  91. (rectangle 300 25 "solid"
  92. (if (= num color) "white" "Medium gray"))
  93. (/ *width* 2)
  94. (+ 70 (* num 70))
  95. scene))))
  96.  
  97. (define (place-branches branches color scene)
  98. (if (null? branches)
  99. scene
  100. (place-branches (cdr branches) color
  101. (place-branch
  102. (car branches) color scene))))
  103.  
  104. ;;; ウィンドゥ表示
  105.  
  106. (define (place-world w)
  107. (place-branches
  108. (world-branches w)
  109. (world-color w)
  110. (place-message
  111. (world-message w)
  112. (message-area
  113. (place-characters
  114. (world-characters w)
  115. (place-back
  116. (world-back w)
  117. *window*))))))
  118.  
  119. ;; ジャンプ先を探す補助関数定義
  120.  
  121. (define (find-label x scenario)
  122. (unless (null? scenario)
  123. (let ((s-expression (car scenario)))
  124. (let ((head (car s-expression)) (tail (cdr s-expression)))
  125. (if (and (eq? head 'label) (eq? (car tail) x))
  126. (cdr scenario)
  127. (find-label x (cdr scenario)))))))
  128.  
  129. ;; シナリオ制御
  130.  
  131. (define (world-go w delta)
  132. (let loop ((back (world-back w))
  133. (branches (world-branches w))
  134. (characters (world-characters w))
  135. (color (world-color w))
  136. (message (world-message w))
  137. (scenario (world-scenario w)))
  138. (let ((s-expression (car scenario)))
  139. (let ((head (car s-expression)) (tail (cdr s-expression)))
  140. ; ;; デバッグ用
  141. ; (display
  142. ; (format "branches: ~a\ncolor: ~a
  143. ;instruction: ~a\ntail: ~a\ninput: ~a\n"
  144. ; branches color head tail delta))
  145. (case head
  146. ((back) (loop (car tail) branches '()
  147. color message (cdr scenario)))
  148. ((branch) (loop back (cons tail branches) characters
  149. color message (cdr scenario)))
  150. ((break) (cond ((string=? delta "up")
  151. (world back branches characters
  152. 1 message scenario))
  153. ((string=? delta "down")
  154. (world back branches characters
  155. 2 message scenario))
  156. ((or (string=? delta "1")
  157. (string=? delta "2"))
  158. (world-go
  159. (world back '() characters
  160. color message
  161. (find-label
  162. (third (assv
  163. (string->number delta)
  164. branches))
  165. scenario)) "\r"))
  166. ((or (string=? delta "y")
  167. (string=? delta "n"))
  168. (world-go
  169. (world back '() characters
  170. color message
  171. (find-label
  172. (second (assoc delta
  173. (map reverse branches)))
  174. scenario)) "\r"))
  175. ((or (string=? "\r")
  176. (string=? " "))
  177. (world-go
  178. (world back '() characters
  179. color message
  180. (find-label
  181. (third
  182. (assv color branches))
  183. scenario))
  184. "\r"))
  185. (else
  186. (world back branches characters
  187. color message scenario))))
  188. ((end) (world back branches characters
  189. color *end-message* scenario))
  190. ((jump) (world-go
  191. (world back branches characters
  192. color message (find-label
  193. (car tail) scenario))
  194. "\r"))
  195. ((label) (world back branches characters color message
  196. (cons '(break) scenario)))
  197. ((msg) (world back branches characters
  198. color (car tail)
  199. (if (or (string=? delta " ")
  200. (string=? delta "\r"))
  201. (cdr scenario)
  202. scenario)))
  203. ((putChar) (loop back branches
  204. (if (member tail characters)
  205. characters
  206. (cons tail characters))
  207. color message (cdr scenario)))
  208. (else (error "Can't do " head)))))))
  209.  
  210. ;; 入力制御
  211.  
  212. (define (change w a-key)
  213. (cond ((key=? a-key "\r") (world-go w "\r"))
  214. ((key=? a-key " ") (world-go w " "))
  215. ((key=? a-key "1") (world-go w "1"))
  216. ((key=? a-key "2") (world-go w "2"))
  217. ((key=? a-key "y") (world-go w "y"))
  218. ((key=? a-key "n") (world-go w "n"))
  219. ((key=? a-key "up") (world-go w "up"))
  220. ((key=? a-key "down") (world-go w "down"))
  221. (else w)))
  222.  
  223. ;; ゲーム終了条件
  224.  
  225. (define (game-ends? w)
  226. (string=? (world-message w) *end-message*))
  227.  
  228. ;; イベントループ
  229.  
  230. (big-bang (world #f '() '() 1 *init-message* *scenario*)
  231. (on-key change)
  232. (to-draw place-world)
  233. (stop-when game-ends? place-world)
  234. (name "よろしくアドベンチャー")
  235. ;; デバッグ用
  236. ; (state world)
  237. )
  238.  
Success #stdin #stdout 1.01s 139800KB
stdin
Standard input is empty
stdout
Standard output is empty