render: Make apply-* procedures public.
[chickadee.git] / chickadee.scm
1 ;;; Chickadee Game Toolkit
2 ;;; Copyright © 2018 David Thompson <davet@gnu.org>
3 ;;;
4 ;;; Chickadee is free software: you can redistribute it and/or modify
5 ;;; it under the terms of the GNU General Public License as published
6 ;;; by the Free Software Foundation, either version 3 of the License,
7 ;;; or (at your option) any later version.
8 ;;;
9 ;;; Chickadee is distributed in the hope that it will be useful, but
10 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 ;;; General Public License for more details.
13 ;;;
14 ;;; You should have received a copy of the GNU General Public License
15 ;;; along with this program. If not, see
16 ;;; <http://www.gnu.org/licenses/>.
17
18 ;;; Commentary:
19 ;;
20 ;; Simple SDL + OpenGL game loop implementation.
21 ;;
22 ;;; Code:
23
24 (define-module (chickadee)
25 #:use-module (chickadee config)
26 #:use-module (chickadee game-loop)
27 #:use-module (chickadee math matrix)
28 #:use-module (chickadee render)
29 #:use-module (chickadee render color)
30 #:use-module (chickadee render gl)
31 #:use-module (chickadee render gpu)
32 #:use-module (chickadee render viewport)
33 #:use-module (chickadee utils)
34 #:use-module (gl)
35 #:use-module (gl enums)
36 #:use-module (ice-9 match)
37 #:use-module (sdl2)
38 #:use-module (sdl2 events)
39 #:use-module ((sdl2 input game-controller) #:prefix sdl2:)
40 #:use-module (sdl2 input joystick)
41 #:use-module ((sdl2 input keyboard) #:prefix sdl2:)
42 #:use-module ((sdl2 input mouse) #:prefix sdl2:)
43 #:use-module (sdl2 input text)
44 #:use-module (sdl2 mixer)
45 #:use-module ((sdl2 video) #:prefix sdl2:)
46 #:use-module (srfi srfi-9)
47 #:export (current-window
48 window?
49 window-width
50 window-height
51 window-x
52 window-y
53 window-title
54 hide-window!
55 show-window!
56 maximize-window!
57 minimize-window!
58 raise-window!
59 restore-window!
60 set-window-border!
61 set-window-title!
62 set-window-size!
63 set-window-position!
64 set-window-fullscreen!
65 controller-button-pressed?
66 controller-axis
67 controller-name
68 key-pressed?
69 key-released?
70 mouse-x
71 mouse-y
72 mouse-button-pressed?
73 mouse-button-released?
74 run-game)
75 #:re-export (abort-game))
76
77 (define (key-pressed? key)
78 "Return #t if KEY is currently being pressed."
79 (sdl2:key-pressed? key))
80
81 (define (key-released? key)
82 "Return #t if KEY is not currently being pressed."
83 (sdl2:key-released? key))
84
85 (define (mouse-x)
86 "Return the current X coordinate of the mouse cursor."
87 (sdl2:mouse-x))
88
89 (define (mouse-y)
90 "Return the current Y coordinate of the mouse cursor."
91 (sdl2:mouse-y))
92
93 (define (mouse-button-pressed? button)
94 "Return #t if BUTTON is currently being pressed."
95 (sdl2:mouse-button-pressed? button))
96
97 (define (mouse-button-released? button)
98 "Return #t if BUTTON is not currently being pressed."
99 (sdl2:mouse-button-released? button))
100
101 (define *controllers* (make-hash-table))
102
103 (define (lookup-controller joystick-id)
104 (hashv-ref *controllers* joystick-id))
105
106 (define (add-controller joystick-index)
107 (let ((controller (sdl2:open-game-controller joystick-index)))
108 (hashv-set! *controllers*
109 (joystick-instance-id
110 (sdl2:game-controller-joystick controller))
111 controller)
112 controller))
113
114 (define (remove-controller joystick-id)
115 (hashv-remove! *controllers* joystick-id))
116
117 (define (controller-button-pressed? controller button)
118 "Return #t if BUTTON is currently being pressed on CONTROLLER."
119 (sdl2:game-controller-button-pressed? controller button))
120
121 (define (controller-axis controller axis)
122 "Return a floating point value in the range [-1, 1] corresponding to
123 how much AXIS is being pushed on CONTROLLER. 0 is returned if AXIS is
124 not being pushed at all."
125 (/ (sdl2:game-controller-axis controller axis)
126 32768.0))
127
128 (define controller-name
129 ;; Memoize to avoid repeated allocation of strings via
130 ;; pointer->string.
131 (memoize
132 (lambda (controller)
133 (sdl2:game-controller-name controller))))
134
135 (define-record-type <window>
136 (wrap-sdl-window sdl-window)
137 window?
138 (sdl-window unwrap-window))
139
140 (define current-window (make-parameter #f))
141
142 (define-syntax-rule (define-window-wrapper (name args ...) sdl-proc docstring)
143 (define (name window args ...)
144 docstring
145 (sdl-proc (unwrap-window window) args ...)))
146
147 (define-window-wrapper (window-title) sdl2:window-title
148 "Return the title of WINDOW.")
149
150 (define-window-wrapper (hide-window!) sdl2:hide-window!
151 "Hide WINDOW.")
152
153 (define-window-wrapper (show-window!) sdl2:show-window!
154 "Show WINDOW.")
155
156 (define-window-wrapper (maximize-window!) sdl2:maximize-window!
157 "Maximize WINDOW.")
158
159 (define-window-wrapper (minimize-window!) sdl2:minimize-window!
160 "Minimize WINDOW.")
161
162 (define-window-wrapper (raise-window!) sdl2:raise-window!
163 "Make WINDOW visible over all other windows.")
164
165 (define-window-wrapper (restore-window!) sdl2:restore-window!
166 "Restore the size and position of a minimized or maximized WINDOW.")
167
168 (define-window-wrapper (set-window-border! border?) sdl2:set-window-border!
169 "Enable/disable the border around WINDOW. If BORDER? is #f, the
170 border is disabled, otherwise it is enabled.")
171
172 (define-window-wrapper (set-window-title! title) sdl2:set-window-title!
173 "Set the title of WINDOW to TITLE.")
174
175 (define-window-wrapper (set-window-fullscreen! fullscreen?) sdl2:set-window-fullscreen!
176 "Enable or disable fullscreen mode for WINDOW. If FULLSCREEN? is
177 #f, fullscreen mode is disabled, otherwise it is enabled.")
178
179 (define (window-width window)
180 "Return the width of WINDOW."
181 (match (sdl2:window-size (unwrap-window window))
182 ((x _) x)))
183
184 (define (window-height window)
185 "Return the height of WINDOW."
186 (match (sdl2:window-size (unwrap-window window))
187 ((_ y) y)))
188
189 (define (window-x window)
190 "Return the X coordinate of the upper-left corner of WINDOW."
191 (match (sdl2:window-position (unwrap-window window))
192 ((x _) x)))
193
194 (define (window-y window)
195 "Return the Y coordinate of the upper-left corner of WINDOW."
196 (match (sdl2:window-position (unwrap-window window))
197 ((_ y) y)))
198
199 (define (set-window-size! window width height)
200 "Change the dimensions of WINDOW to WIDTH x HEIGHT pixels."
201 (sdl2:set-window-size! (unwrap-window window) (list width height)))
202
203 (define (set-window-position! window x y)
204 "Move the upper-left corner of WINDOW to pixel coordinates (X, Y)."
205 (sdl2:set-window-position! (unwrap-window window) (list x y)))
206
207 (define* (run-game #:key
208 (window-title "Chickadee!")
209 (window-width 640)
210 (window-height 480)
211 window-fullscreen?
212 (update-hz 60)
213 (load (const #t))
214 (update (const #t))
215 (draw (const #t))
216 (quit abort-game)
217 (key-press (const #t))
218 (key-release (const #t))
219 (text-input (const #t))
220 (mouse-press (const #t))
221 (mouse-release (const #t))
222 (mouse-move (const #t))
223 (controller-add (const #t))
224 (controller-remove (const #t))
225 (controller-press (const #t))
226 (controller-release (const #t))
227 (controller-move (const #t))
228 error)
229 (sdl-init)
230 (false-if-exception (mixer-init))
231 (open-audio)
232 (start-text-input)
233 (let* ((window (sdl2:make-window #:opengl? #t
234 #:title window-title
235 #:size (list window-width window-height)
236 #:fullscreen? window-fullscreen?))
237 (gl-context (sdl2:make-gl-context window))
238 (gpu (make-gpu gl-context))
239 (default-viewport (make-viewport 0 0 window-width window-height))
240 (default-projection (orthographic-projection 0 window-width
241 window-height 0
242 0 1))
243 (clear-mask (logior (attrib-mask color-buffer)
244 (attrib-mask depth-buffer)
245 (attrib-mask stencil-buffer)
246 (attrib-mask accum-buffer))))
247 (define (invert-y y)
248 ;; SDL's origin is the top-left, but our origin is the bottom
249 ;; left so we need to invert Y coordinates that SDL gives us.
250 (- window-height y))
251 (define (input-sdl)
252 (define (process-event event)
253 (cond
254 ((quit-event? event)
255 (quit))
256 ((keyboard-down-event? event)
257 (key-press (keyboard-event-key event)
258 (keyboard-event-scancode event)
259 (keyboard-event-modifiers event)
260 (keyboard-event-repeat? event)))
261 ((keyboard-up-event? event)
262 (key-release (keyboard-event-key event)
263 (keyboard-event-scancode event)
264 (keyboard-event-modifiers event)))
265 ((text-input-event? event)
266 (text-input (text-input-event-text event)))
267 ((mouse-button-down-event? event)
268 (mouse-press (mouse-button-event-button event)
269 (mouse-button-event-clicks event)
270 (mouse-button-event-x event)
271 (invert-y (mouse-button-event-y event))))
272 ((mouse-button-up-event? event)
273 (mouse-release (mouse-button-event-button event)
274 (mouse-button-event-x event)
275 (invert-y (mouse-button-event-y event))))
276 ((mouse-motion-event? event)
277 (mouse-move (mouse-motion-event-x event)
278 (invert-y (mouse-motion-event-y event))
279 (mouse-motion-event-x-rel event)
280 (- (mouse-motion-event-y-rel event))
281 (mouse-motion-event-buttons event)))
282 ((and (controller-device-event? event)
283 (eq? (controller-device-event-action event) 'added))
284 (controller-add (add-controller
285 (controller-device-event-which event))))
286 ((and (controller-device-event? event)
287 (eq? (controller-device-event-action event) 'removed))
288 (let ((controller (lookup-controller
289 (controller-device-event-which event))))
290 (controller-remove controller)
291 (remove-controller (controller-device-event-which event))
292 (sdl2:close-game-controller controller)))
293 ((controller-button-down-event? event)
294 (controller-press (lookup-controller
295 (controller-button-event-which event))
296 (controller-button-event-button event)))
297 ((controller-button-up-event? event)
298 (controller-release (lookup-controller
299 (controller-button-event-which event))
300 (controller-button-event-button event)))
301 ((controller-axis-event? event)
302 (controller-move (lookup-controller
303 (controller-axis-event-which event))
304 (controller-axis-event-axis event)
305 (/ (controller-axis-event-value event) 32768.0)))))
306 ;; Process all pending events.
307 (let loop ((event (poll-event)))
308 (when event
309 (process-event event)
310 (loop (poll-event)))))
311 (define (update-sdl dt)
312 (input-sdl)
313 (update dt)
314 ;; Free any GPU resources that have been GC'd.
315 (gpu-reap!))
316 (define (render-sdl-opengl alpha)
317 ;; Switch to the default viewport so we can clear the whole screen.
318 (set-gpu-viewport! gpu default-viewport)
319 (gl-clear clear-mask)
320 (with-viewport default-viewport
321 (with-projection default-projection
322 (draw alpha)))
323 (sdl2:swap-gl-window window))
324 (dynamic-wind
325 (const #t)
326 (lambda ()
327 (parameterize ((current-window (wrap-sdl-window window))
328 (current-gpu gpu))
329 ;; Attempt to activate vsync, if possible. Some systems do
330 ;; not support setting the OpenGL swap interval.
331 (catch #t
332 (lambda ()
333 (sdl2:set-gl-swap-interval! 'vsync))
334 (lambda args
335 (display "warning: could not enable vsync\n"
336 (current-error-port))))
337 (load)
338 (sdl2:load-game-controller-mappings!
339 (scope-datadir "gamecontrollerdb.txt"))
340 (run-game* #:update update-sdl
341 #:render render-sdl-opengl
342 #:error error
343 #:time sdl-ticks
344 #:update-hz update-hz)))
345 (lambda ()
346 (sdl2:delete-gl-context! gl-context)
347 (sdl2:close-window! window)))))