]> git.jsancho.org Git - gacela.git/blob - src/gacela_events.scm
(no commit message)
[gacela.git] / src / gacela_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 (get-event events types)
19   (cond ((null? events) '())
20         (else
21          (let ((res (get-event (cdr events) types))
22                (event (car events)))
23            (cond ((member (assoc-ref event 'type) types) (cons event res))
24                  (else res))))))
25
26 (define (poll-events)
27   (let ((event (SDL_PollEvent)))
28     (cond ((null? event) '())
29           (else (cons event (poll-events))))))
30
31 (define (process-events)
32   (let ((events (poll-events)))
33     (quit! (not (null? (get-event events `(,SDL_QUIT)))))
34     (clear-key-state)
35     (process-keyboard-events (get-event events `(,SDL_KEYDOWN ,SDL_KEYUP)))))
36
37 (define quit? #f)
38 (define quit! #f)
39
40 (let ((quit #f))
41   (set! quit?
42         (lambda ()
43           quit))
44
45   (set! quit!
46         (lambda (value)
47           (set! quit value))))
48
49 (define (process-keyboard-events events)
50   (cond ((not (null? events))
51          (let ((event (car events)))
52            (cond ((= (assoc-ref event 'type) SDL_KEYDOWN) (key-press (assoc-ref event 'key.keysym.sym)))
53                  ((= (assoc-ref event 'type) SDL_KEYUP) (key-release (assoc-ref event 'key.keysym.sym)))))
54          (process-keyboard-events (cdr events)))))
55
56 (define key? #f)
57 (define key-pressed? #f)
58 (define key-released? #f)
59 (define key-press #f)
60 (define key-release #f)
61 (define clear-keymap #f)
62 (define clear-key-state #f)
63
64 (let ((keymap (make-hash-table))
65       (pressed (make-hash-table))
66       (released (make-hash-table)))
67   (set! key?
68         (lambda (key)
69           (hash-ref keymap (get-keycode key))))
70
71   (set! key-pressed?
72         (lambda (key)
73           (hash-ref pressed (get-keycode key))))
74
75   (set! key-released?
76         (lambda (key)
77           (hash-ref released (get-keycode key))))
78
79   (set! key-press
80         (lambda (key-code)
81           (hash-set! keymap key-code #t)
82           (hash-set! pressed key-code #t)
83           (hash-set! released key-code #f)))
84
85   (set! key-release
86         (lambda (key-code)
87           (hash-set! keymap key-code #f)
88           (hash-set! pressed key-code #f)
89           (hash-set! released key-code #t)))
90
91   (set! clear-keymap
92         (lambda ()
93           (hash-clear! keymap)))
94
95   (set! clear-key-state
96         (lambda ()
97           (hash-clear! pressed)
98           (hash-clear! released))))
99
100 (define get-keycode #f)
101 (define get-keyname #f)
102
103 (let* ((keys
104         '((8 . backspace)
105           (9 . tab)
106           (12 . clear)
107           (13 . return)
108           (19 . pause)
109           (27 . escape)
110           (32 . space)
111           (33 . exclaim)
112           (34 . quotedbl)
113           (35 . hash)
114           (36 . dollar)
115           (38 . ampersand)
116           (39 . quote)
117           (40 . leftparen)
118           (41 . rightparen)
119           (42 . asterisk)
120           (43 . plus)
121           (44 . comma)
122           (45 . minus)
123           (46 . period)
124           (47 . slash)
125           (48 . 0)
126           (49 . 1)
127           (50 . 2)
128           (51 . 3)
129           (52 . 4)
130           (53 . 5)
131           (54 . 6)
132           (55 . 7)
133           (56 . 8)
134           (57 . 9)
135           (58 . colon)
136           (59 . semicolon)
137           (60 . less)
138           (61 . equals)
139           (62 . greater)
140           (63 . question)
141           (64 . at)
142           (269 . kp-minus)
143           (270 . kp-plus)
144           (273 . up)
145           (274 . down)
146           (275 . right)
147           (276 . left)
148           (282 . f1)
149           (283 . f2)
150           (284 . f3)
151           (285 . f4)
152           (286 . f5)
153           (287 . f6)
154           (288 . f7)
155           (289 . f8)
156           (290 . f9)
157           (291 . f10)
158           (292 . f11)
159           (293 . f12)))
160        (keynames (map (lambda (k) (cons (cdr k) (car k))) keys)))
161
162   (set! get-keycode
163         (lambda (keyname)
164           (assoc-ref keynames keyname)))
165
166   (set! get-keyname
167         (lambda (keycode)
168           (assoc-ref keys keycode))))