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