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))))