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