]> git.jsancho.org Git - gacela.git/blob - src/events.scm
Gacela as Guile modules.
[gacela.git] / src / events.scm
1 ;;; Gacela, a GNU Guile extension for fast games development
2 ;;; Copyright (C) 2009 by Javier Sancho Fernandez <jsf at jsancho dot org>
3 ;;;
4 ;;; This program is free software: you can redistribute it and/or modify
5 ;;; it under the terms of the GNU General Public License as published by
6 ;;; the Free Software Foundation, either version 3 of the License, or
7 ;;; (at your option) any later version.
8 ;;;
9 ;;; This program is distributed in the hope that it will be useful,
10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
12 ;;; GNU 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 <http://www.gnu.org/licenses/>.
16
17
18 (define-module (gacela events)
19   #:use-module (gacela sdl)
20   #:export (process-events
21             quit?
22             key?
23             key-pressed?
24             key-released?))
25
26
27 (define (get-event events types)
28   (cond ((null? events) '())
29         (else
30          (let ((res (get-event (cdr events) types))
31                (event (car events)))
32            (cond ((member (assoc-ref event 'type) types) (cons event res))
33                  (else res))))))
34
35 (define (poll-events)
36   (let ((event (SDL_PollEvent)))
37     (cond ((null? event) '())
38           (else (cons event (poll-events))))))
39
40 (define (process-events)
41   (let ((events (poll-events)))
42     (quit! (not (null? (get-event events `(,SDL_QUIT)))))
43     (clear-key-state)
44     (process-keyboard-events (get-event events `(,SDL_KEYDOWN ,SDL_KEYUP)))))
45
46 (define quit? #f)
47 (define quit! #f)
48
49 (let ((quit #f))
50   (set! quit?
51         (lambda ()
52           quit))
53
54   (set! quit!
55         (lambda (value)
56           (set! quit value))))
57
58 (define (process-keyboard-events events)
59   (cond ((not (null? events))
60          (let ((event (car events)))
61            (cond ((= (assoc-ref event 'type) SDL_KEYDOWN) (key-press (assoc-ref event 'key.keysym.sym)))
62                  ((= (assoc-ref event 'type) SDL_KEYUP) (key-release (assoc-ref event 'key.keysym.sym)))))
63          (process-keyboard-events (cdr events)))))
64
65 (define key? #f)
66 (define key-pressed? #f)
67 (define key-released? #f)
68 (define key-press #f)
69 (define key-release #f)
70 (define clear-keymap #f)
71 (define clear-key-state #f)
72
73 (let ((keymap (make-hash-table))
74       (pressed (make-hash-table))
75       (released (make-hash-table)))
76   (set! key?
77         (lambda (key)
78           (hash-ref keymap (get-keycode key))))
79
80   (set! key-pressed?
81         (lambda (key)
82           (hash-ref pressed (get-keycode key))))
83
84   (set! key-released?
85         (lambda (key)
86           (hash-ref released (get-keycode key))))
87
88   (set! key-press
89         (lambda (key-code)
90           (hash-set! keymap key-code #t)
91           (hash-set! pressed key-code #t)
92           (hash-set! released key-code #f)))
93
94   (set! key-release
95         (lambda (key-code)
96           (hash-set! keymap key-code #f)
97           (hash-set! pressed key-code #f)
98           (hash-set! released key-code #t)))
99
100   (set! clear-keymap
101         (lambda ()
102           (hash-clear! keymap)))
103
104   (set! clear-key-state
105         (lambda ()
106           (hash-clear! pressed)
107           (hash-clear! released))))
108
109 (define get-keycode #f)
110 (define get-keyname #f)
111
112 (let* ((keys
113         '((8 . backspace)
114           (9 . tab)
115           (12 . clear)
116           (13 . return)
117           (19 . pause)
118           (27 . escape)
119           (32 . space)
120           (33 . exclaim)
121           (34 . quotedbl)
122           (35 . hash)
123           (36 . dollar)
124           (38 . ampersand)
125           (39 . quote)
126           (40 . leftparen)
127           (41 . rightparen)
128           (42 . asterisk)
129           (43 . plus)
130           (44 . comma)
131           (45 . minus)
132           (46 . period)
133           (47 . slash)
134           (48 . 0)
135           (49 . 1)
136           (50 . 2)
137           (51 . 3)
138           (52 . 4)
139           (53 . 5)
140           (54 . 6)
141           (55 . 7)
142           (56 . 8)
143           (57 . 9)
144           (58 . colon)
145           (59 . semicolon)
146           (60 . less)
147           (61 . equals)
148           (62 . greater)
149           (63 . question)
150           (64 . at)
151           (269 . kp-minus)
152           (270 . kp-plus)
153           (273 . up)
154           (274 . down)
155           (275 . right)
156           (276 . left)
157           (282 . f1)
158           (283 . f2)
159           (284 . f3)
160           (285 . f4)
161           (286 . f5)
162           (287 . f6)
163           (288 . f7)
164           (289 . f8)
165           (290 . f9)
166           (291 . f10)
167           (292 . f11)
168           (293 . f12)))
169        (keynames (map (lambda (k) (cons (cdr k) (car k))) keys)))
170
171   (set! get-keycode
172         (lambda (keyname)
173           (assoc-ref keynames keyname)))
174
175   (set! get-keyname
176         (lambda (keycode)
177           (assoc-ref keys keycode))))