blob: 306787ba092ce2754b0530683c1086c0399e165c (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
|
;;; guile-2d
;;; Copyright (C) 2013 David Thompson <dthompson2@worcester.edu>
;;;
;;; Guile-2d is free software: you can redistribute it and/or modify it
;;; under the terms of the GNU Lesser General Public License as
;;; published by the Free Software Foundation, either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; Guile-2d is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Lesser General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this program. If not, see
;;; <http://www.gnu.org/licenses/>.
;;; Commentary:
;;
;; Stages represent the game state at the present time.
;;
;;; Code:
(define-module (2d stage)
#:use-module (srfi srfi-9)
#:use-module (2d agenda)
#:use-module (2d observer)
#:use-module (2d scene)
#:export (make-stage
stage?
stage-agenda
stage-observer
stage-env
stage-scene
init-stage
enter-stage
exit-stage
draw-stage
update-stage
stage-trigger
make-stage-variable
define-stage-variable
stage-on
stage-off
current-stage
push-stage
pop-stage
replace-stage))
(define-record-type <stage>
(%make-stage agenda observer env scene)
stage?
(agenda stage-agenda)
(observer stage-observer)
(env stage-env)
(scene stage-scene))
(define (make-stage scene)
"Create a new stage object for SCENE."
(%make-stage (make-agenda) (make-observer) (make-hash-table) scene))
;;;
;;; Scene callbacks
;;;
(define (init-stage stage)
"Call the scene init callback for STAGE."
(with-agenda (stage-agenda stage)
((scene-init (stage-scene stage)))))
(define (enter-stage stage)
"Call the scene enter callback for STAGE."
(with-agenda (stage-agenda stage)
((scene-enter (stage-scene stage)))))
(define (exit-stage stage)
"Call the scene exit callback for STAGE."
(with-agenda (stage-agenda stage)
((scene-exit (stage-scene stage)))))
(define (update-stage stage)
"Call the scene update callback for STAGE."
(with-agenda (stage-agenda stage)
(update-agenda)
((scene-update (stage-scene stage)))))
(define (draw-stage stage)
"Call the scene draw callback for STAGE."
(with-agenda (stage-agenda stage)
((scene-draw (stage-scene stage)))))
(define (stage-trigger stage event . args)
(apply observer-trigger (stage-observer stage) event args))
;;;
;;; Stage environment
;;;
(define uuid-counter 1)
(define (next-uuid)
"Return the next available uuid and increment the uuid counter."
(let ((uuid uuid-counter))
(set! uuid-counter (1+ uuid-counter))
uuid))
(define (make-stage-variable init-thunk)
"Create a new stage variable that is initialized by INIT-THUNK."
(let ((uuid (next-uuid)))
(case-lambda
(()
(stage-ref-or-init uuid init-thunk))
((new-value)
(stage-set! uuid new-value)))))
(define (%stage-ref-or-init stage key init-thunk)
"Return the value stored in STAGE associated with KEY. If there is
no association for KEY then create it and set the value returned by
INIT-THUNK."
(let* ((env (stage-env stage))
(handle (hash-get-handle env key)))
(if handle
(cdr handle)
(cdr (hash-create-handle! env key (init-thunk))))))
(define (%stage-set! stage key value)
"Associate KEY with VALUE in the STAGE environment. An error is
thrown if there is no value associated with KEY."
(let ((handle (hash-get-handle (stage-env stage) key)))
(if handle
(set-cdr! handle value)
(error 'stage-unbound-variable key))))
(define (stage-ref-or-init key init)
(%stage-ref-or-init (current-stage) key init))
(define (stage-set! key value)
(%stage-set! (current-stage) key value))
(define-syntax-rule (define-stage-variable name value)
"Define a stage variable named NAME with value VALUE. VALUE is
lazily evaluated the first time it is referenced in a stage object."
(define name (make-stage-variable (lambda () value))))
(define (stage-on event callback)
(observer-on (stage-observer (current-stage)) event callback))
(define (stage-off event callback)
(observer-off (stage-observer (current-stage)) event callback))
;;;
;;; Stage management
;;;
(define stack '())
(define (current-stage)
"Return the top of the stage stack or #f if the stack is empty."
(if (null? stack) #f (car stack)))
(define (push-stage stage)
"Make STAGE active and push it to the top of the stack."
(let ((prev-stage (current-stage)))
(when prev-stage
(exit-stage prev-stage))
(set! stack (cons stage stack))
(init-stage stage)
(enter-stage stage)))
(define (pop-stage)
"Replace the current stage with the next one on the stack, if
present."
(let ((prev-stage (current-stage)))
(when prev-stage
(exit-stage prev-stage))
(set! stack (cdr stack))
(when (current-stage)
(enter-stage (car stack)))))
(define (replace-stage stage)
"Replace the current stage with STAGE."
(let ((prev-stage (current-stage)))
(when prev-stage
(exit-stage prev-stage))
(set! stack (cons stage (cdr stack)))
(init-stage stage)
(enter-stage stage)))
|
