gacela_events.lisp

   1 ;;; Gacela, a GNU Common Lisp 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 (eval-when (compile load eval)
  19            (when (not (find-package 'gacela)) (make-package 'gacela :nicknames '(gg) :use '(lisp)))
  20            (in-package 'gacela :nicknames '(gg) :use '(lisp)))
  21
  22
  23 ;;; SDL Events
  24 (defconstant SDL_NOEVENT          0)
  25 (defconstant SDL_ACTIVEEVENT      1)
  26 (defconstant SDL_KEYDOWN          2)
  27 (defconstant SDL_KEYUP            3)
  28 (defconstant SDL_MOUSEMOTION      4)
  29 (defconstant SDL_MOUSEBUTTONDOWN  5)
  30 (defconstant SDL_MOUSEBUTTONUP    6)
  31 (defconstant SDL_JOYAXISMOTION    7)
  32 (defconstant SDL_JOYBALLMOTION    8)
  33 (defconstant SDL_JOYHATMOTION     9)
  34 (defconstant SDL_JOYBUTTONDOWN    10)
  35 (defconstant SDL_JOYBUTTONUP      11)
  36 (defconstant SDL_QUIT             12)
  37 (defconstant SDL_SYSWMEVENT       13)
  38 (defconstant SDL_EVENT_RESERVEDA  14)
  39 (defconstant SDL_EVENT_RESERVEDB  15)
  40 (defconstant SDL_VIDEORESIZE      16)
  41 (defconstant SDL_VIDEOEXPOSE      17)
  42 (defconstant SDL_EVENT_RESERVED2  18)
  43 (defconstant SDL_EVENT_RESERVED3  19)
  44 (defconstant SDL_EVENT_RESERVED4  20)
  45 (defconstant SDL_EVENT_RESERVED5  21)
  46 (defconstant SDL_EVENT_RESERVED6  22)
  47 (defconstant SDL_EVENT_RESERVED7  23)
  48 (defconstant SDL_USEREVENT        24)
  49 (defconstant SDL_NUMEVENTS        32)
  50
  51 ;;; Functions
  52 (defun get-event (events &rest types)
  53   (remove nil (mapcar
  54                (lambda (l)
  55                  (cond ((member (getf l :type) types) l)))
  56                events)))
  57
  58 (defun poll-events ()
  59   (let ((event (SDL_PollEvent)))
  60     (cond ((null event) nil)
  61           (t (cons event (poll-events))))))
  62
  63 (defun process-events ()
  64   (let ((events (poll-events)))
  65     (quit? t (and (get-event events SDL_QUIT) t))
  66     (clear-key-state)
  67     (process-keyboard-events (get-event events SDL_KEYDOWN SDL_KEYUP))))
  68
  69 (let (will-happen happenings)
  70   (defun next-happenings ()
  71     (setq happenings will-happen)
  72     (setq will-happen nil))
  73
  74   (defun will-happen (happening)
  75     (setq will-happen (cons happening will-happen)))
  76
  77   (defun is-happening? (happening &optional (test #'eql))
  78     (remove nil (mapcar
  79                  (lambda (l)
  80                    (cond ((funcall test happening l) l)))
  81                  happenings))))
  82
  83 (let (quit)
  84   (defun quit? (&optional change newquit)
  85     (if change (setq quit newquit) quit)))
  86
  87 (defun process-keyboard-events (events)
  88   (cond (events
  89          (let ((event (car events)))
  90            (cond ((= (getf event :type) SDL_KEYDOWN) (key-press (getf event :key.keysym.sym)))
  91                  ((= (getf event :type) SDL_KEYUP) (key-release (getf event :key.keysym.sym)))))
  92          (process-keyboard-events (cdr events)))))
  93
  94 (let ((keymap (make-hash-table))
  95       (pressed (make-hash-table))
  96       (released (make-hash-table)))
  97   (defun key? (key)
  98     (gethash (get-keycode key) keymap))
  99
 100   (defun key-pressed? (key)
 101     (gethash (get-keycode key) pressed))
 102
 103   (defun key-released? (key)
 104     (gethash (get-keycode key) released))
 105
 106   (defun key-press (key-code)
 107     (setf (gethash key-code keymap) t)
 108     (setf (gethash key-code pressed) t)
 109     (setf (gethash key-code released) nil))
 110
 111   (defun key-release (key-code)
 112     (setf (gethash key-code keymap) nil)
 113     (setf (gethash key-code pressed) nil)
 114     (setf (gethash key-code released) t))
 115
 116   (defun clear-keymap ()
 117     (clrhash keymap))
 118
 119   (defun clear-key-state ()
 120     (clrhash pressed)
 121     (clrhash released)))
 122
 123 (let ((keys
 124        '((8 . backspace)
 125          (9 . tab)
 126          (12 . clear)
 127          (13 . return)
 128          (19 . pause)
 129          (27 . escape)
 130          (32 . space)
 131          (33 . exclaim)
 132          (34 . quotedbl)
 133          (35 . hash)
 134          (36 . dollar)
 135          (38 . ampersand)
 136          (39 . quote)
 137          (40 . leftparen)
 138          (41 . rightparen)
 139          (42 . asterisk)
 140          (43 . plus)
 141          (44 . comma)
 142          (45 . minus)
 143          (46 . period)
 144          (47 . slash)
 145          (48 . 0)
 146          (49 . 1)
 147          (50 . 2)
 148          (51 . 3)
 149          (52 . 4)
 150          (53 . 5)
 151          (54 . 6)
 152          (55 . 7)
 153          (56 . 8)
 154          (57 . 9)
 155          (58 . colon)
 156          (59 . semicolon)
 157          (60 . less)
 158          (61 . equals)
 159          (62 . greater)
 160          (63 . question)
 161          (64 . at)
 162          (269 . kp-minus)
 163          (270 . kp-plus)
 164          (273 . up)
 165          (274 . down)
 166          (275 . right)
 167          (276 . left)
 168          (282 . f1)
 169          (283 . f2)
 170          (284 . f3)
 171          (285 . f4)
 172          (286 . f5)
 173          (287 . f6)
 174          (288 . f7)
 175          (289 . f8)
 176          (290 . f9)
 177          (291 . f10)
 178          (292 . f11)
 179          (293 . f12))))
 180
 181   (defun get-keycode (keyname)
 182     (car (rassoc keyname keys)))
 183
 184   (defun get-keyname (keycode)
 185     (cdr (assoc keycode keys))))