Add controller-name procedure.
[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 (sdl2)
26 #:use-module (sdl2 events)
27 #:use-module ((sdl2 input game-controller) #:prefix sdl2:)
28 #:use-module (sdl2 input joystick)
29 #:use-module ((sdl2 input keyboard) #:prefix sdl2:)
30 #:use-module ((sdl2 input mouse) #:prefix sdl2:)
31 #:use-module (sdl2 input text)
32 #:use-module (sdl2 mixer)
33 #:use-module (sdl2 video)
34 #:use-module (chickadee game-loop)
35 #:use-module (chickadee math matrix)
36 #:use-module (chickadee render)
37 #:use-module (chickadee render color)
38 #:use-module (chickadee render gl)
39 #:use-module (chickadee render gpu)
40 #:use-module (chickadee render viewport)
41 #:use-module (chickadee utils)
42 #:export (current-window
43 controller-button-pressed?
44 controller-axis
45 controller-name
46 key-pressed?
47 key-released?
48 mouse-x
49 mouse-y
50 mouse-button-pressed?
51 mouse-button-released?
52 run-game)
53 #:re-export (abort-game))
54
55 (define (key-pressed? key)
56 "Return #t if KEY is currently being pressed."
57 (sdl2:key-pressed? key))
58
59 (define (key-released? key)
60 "Return #t if KEY is not currently being pressed."
61 (sdl2:key-released? key))
62
63 (define (mouse-x)
64 "Return the current X coordinate of the mouse cursor."
65 (sdl2:mouse-x))
66
67 (define (mouse-y)
68 "Return the current Y coordinate of the mouse cursor."
69 (sdl2:mouse-y))
70
71 (define (mouse-button-pressed? button)
72 "Return #t if BUTTON is currently being pressed."
73 (sdl2:mouse-button-pressed? button))
74
75 (define (mouse-button-released? button)
76 "Return #t if BUTTON is not currently being pressed."
77 (sdl2:mouse-button-released? button))
78
79 (define *controllers* (make-hash-table))
80
81 (define (lookup-controller joystick-id)
82 (hashv-ref *controllers* joystick-id))
83
84 (define (add-controller joystick-index)
85 (let ((controller (sdl2:open-game-controller joystick-index)))
86 (hashv-set! *controllers*
87 (joystick-instance-id
88 (sdl2:game-controller-joystick controller))
89 controller)
90 controller))
91
92 (define (remove-controller joystick-id)
93 (hashv-remove! *controllers* joystick-id))
94
95 (define (open-all-controllers)
96 (let loop ((i 0))
97 (when (< i (num-joysticks))
98 (when (sdl2:game-controller-index? i)
99 (add-controller i))
100 (loop (+ i 1)))))
101
102 (define (controller-button-pressed? controller button)
103 "Return #t if BUTTON is currently being pressed on CONTROLLER."
104 (sdl2:game-controller-button-pressed? controller button))
105
106 (define (controller-axis controller axis)
107 "Return a floating point value in the range [-1, 1] corresponding to
108 how much AXIS is being pushed on CONTROLLER. 0 is returned if AXIS is
109 not being pushed at all."
110 (/ (sdl2:game-controller-axis controller axis)
111 32768.0))
112
113 (define controller-name
114 ;; Memoize to avoid repeated allocation of strings via
115 ;; pointer->string.
116 (memoize
117 (lambda (controller)
118 (sdl2:game-controller-name controller))))
119
120 (define current-window (make-parameter #f))
121
122 (define* (run-game #:key
123 (window-title "Chickadee!")
124 (window-width 640)
125 (window-height 480)
126 window-fullscreen?
127 (update-hz 60)
128 (load (const #t))
129 (update (const #t))
130 (draw (const #t))
131 (quit abort-game)
132 (key-press (const #t))
133 (key-release (const #t))
134 (text-input (const #t))
135 (mouse-press (const #t))
136 (mouse-release (const #t))
137 (mouse-move (const #t))
138 (controller-add (const #t))
139 (controller-remove (const #t))
140 (controller-press (const #t))
141 (controller-release (const #t))
142 (controller-move (const #t))
143 error)
144 (sdl-init)
145 (false-if-exception (mixer-init))
146 (open-audio)
147 (start-text-input)
148 (open-all-controllers)
149 (let* ((window (make-window #:opengl? #t
150 #:title window-title
151 #:size (list window-width window-height)
152 #:fullscreen? window-fullscreen?))
153 (gl-context (make-gl-context window))
154 (default-viewport (make-viewport 0 0 window-width window-height))
155 (default-projection (orthographic-projection 0 window-width
156 window-height 0
157 0 1)))
158 (define (invert-y y)
159 ;; SDL's origin is the top-left, but our origin is the bottom
160 ;; left so we need to invert Y coordinates that SDL gives us.
161 (- window-height y))
162 (define (input-sdl)
163 (define (process-event event)
164 (cond
165 ((quit-event? event)
166 (quit))
167 ((keyboard-down-event? event)
168 (key-press (keyboard-event-key event)
169 (keyboard-event-scancode event)
170 (keyboard-event-modifiers event)
171 (keyboard-event-repeat? event)))
172 ((keyboard-up-event? event)
173 (key-release (keyboard-event-key event)
174 (keyboard-event-scancode event)
175 (keyboard-event-modifiers event)))
176 ((text-input-event? event)
177 (text-input (text-input-event-text event)))
178 ((mouse-button-down-event? event)
179 (mouse-press (mouse-button-event-button event)
180 (mouse-button-event-clicks event)
181 (mouse-button-event-x event)
182 (invert-y (mouse-button-event-y event))))
183 ((mouse-button-up-event? event)
184 (mouse-release (mouse-button-event-button event)
185 (mouse-button-event-x event)
186 (invert-y (mouse-button-event-y event))))
187 ((mouse-motion-event? event)
188 (mouse-move (mouse-motion-event-x event)
189 (invert-y (mouse-motion-event-y event))
190 (mouse-motion-event-x-rel event)
191 (- (mouse-motion-event-y-rel event))
192 (mouse-motion-event-buttons event)))
193 ((and (controller-device-event? event)
194 (eq? (controller-device-event-action event) 'added))
195 (controller-add (add-controller
196 (controller-device-event-which event))))
197 ((and (controller-device-event? event)
198 (eq? (controller-device-event-action event) 'removed))
199 (let ((controller (lookup-controller
200 (controller-device-event-which event))))
201 (controller-remove controller)
202 (remove-controller (controller-device-event-which event))
203 (sdl2:close-game-controller controller)))
204 ((controller-button-down-event? event)
205 (controller-press (lookup-controller
206 (controller-button-event-which event))
207 (controller-button-event-button event)))
208 ((controller-button-up-event? event)
209 (controller-release (lookup-controller
210 (controller-button-event-which event))
211 (controller-button-event-button event)))
212 ((controller-axis-event? event)
213 (controller-move (lookup-controller
214 (controller-axis-event-which event))
215 (controller-axis-event-axis event)
216 (/ (controller-axis-event-value event) 32768.0)))))
217 ;; Process all pending events.
218 (let loop ((event (poll-event)))
219 (when event
220 (process-event event)
221 (loop (poll-event)))))
222 (define (update-sdl dt)
223 (input-sdl)
224 (update dt)
225 ;; Free any GPU resources that have been GC'd.
226 (gpu-reap!))
227 (define (render-sdl-opengl alpha)
228 ;; Switch to the null viewport to ensure that
229 ;; the default viewport will be re-applied and
230 ;; clear the screen.
231 (gpu-state-set! *viewport-state* null-viewport)
232 (with-viewport default-viewport
233 (with-projection default-projection
234 (draw alpha)))
235 (swap-gl-window window))
236 (dynamic-wind
237 (const #t)
238 (lambda ()
239 (parameterize ((current-window window))
240 ;; Attempt to activate vsync, if possible. Some systems do
241 ;; not support setting the OpenGL swap interval.
242 (catch #t
243 (lambda ()
244 (set-gl-swap-interval! 'vsync))
245 (lambda args
246 (display "warning: could not enable vsync\n"
247 (current-error-port))))
248 (load)
249 ;; Notify about all controllers that were already connected
250 ;; when the game was launched because SDL will not create
251 ;; events for them.
252 (hash-for-each (lambda (key controller)
253 (controller-add controller))
254 *controllers*)
255 (run-game* #:update update-sdl
256 #:render render-sdl-opengl
257 #:error error
258 #:time sdl-ticks
259 #:update-hz update-hz)))
260 (lambda ()
261 (delete-gl-context! gl-context)
262 (close-window! window)))))