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