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 (in-package :gacela)
  19
  20 ;;; SDL Events
  21 (defconstant SDL_NOEVENT          0)
  22 (defconstant SDL_ACTIVEEVENT      1)
  23 (defconstant SDL_KEYDOWN          2)
  24 (defconstant SDL_KEYUP            3)
  25 (defconstant SDL_MOUSEMOTION      4)
  26 (defconstant SDL_MOUSEBUTTONDOWN  5)
  27 (defconstant SDL_MOUSEBUTTONUP    6)
  28 (defconstant SDL_JOYAXISMOTION    7)
  29 (defconstant SDL_JOYBALLMOTION    8)
  30 (defconstant SDL_JOYHATMOTION     9)
  31 (defconstant SDL_JOYBUTTONDOWN    10)
  32 (defconstant SDL_JOYBUTTONUP      11)
  33 (defconstant SDL_QUIT             12)
  34 (defconstant SDL_SYSWMEVENT       13)
  35 (defconstant SDL_EVENT_RESERVEDA  14)
  36 (defconstant SDL_EVENT_RESERVEDB  15)
  37 (defconstant SDL_VIDEORESIZE      16)
  38 (defconstant SDL_VIDEOEXPOSE      17)
  39 (defconstant SDL_EVENT_RESERVED2  18)
  40 (defconstant SDL_EVENT_RESERVED3  19)
  41 (defconstant SDL_EVENT_RESERVED4  20)
  42 (defconstant SDL_EVENT_RESERVED5  21)
  43 (defconstant SDL_EVENT_RESERVED6  22)
  44 (defconstant SDL_EVENT_RESERVED7  23)
  45 (defconstant SDL_USEREVENT        24)
  46 (defconstant SDL_NUMEVENTS        32)
  47
  48 ;;; Functions
  49 (defun get-event (events &rest types)
  50   (remove nil (mapcar
  51                (lambda (l)
  52                  (cond ((member (getf l :type) types) l)))
  53                events)))
  54
  55 (defun poll-events ()
  56   (let ((event (SDL_PollEvent)))
  57     (cond ((null event) nil)
  58           (t (cons event (poll-events))))))
  59
  60 (defun process-events ()
  61   (let ((events (poll-events)))
  62     (quit? t (and (get-event events SDL_QUIT) t))
  63     (clear-key-state)
  64     (process-keyboard-events (get-event events SDL_KEYDOWN SDL_KEYUP))))
  65
  66 (let (will-happen happenings)
  67   (defun next-happenings ()
  68     (setq happenings will-happen)
  69     (setq will-happen nil))
  70
  71   (defun will-happen (happening)
  72     (setq will-happen (cons happening will-happen)))
  73
  74   (defun is-happening? (happening &optional (test #'eql))
  75     (remove nil (mapcar
  76                  (lambda (l)
  77                    (cond ((funcall test happening l) l)))
  78                  happenings))))
  79
  80 (let (quit)
  81   (defun quit? (&optional change newquit)
  82     (if change (setq quit newquit) quit)))
  83
  84 (defun process-keyboard-events (events)
  85   (cond (events
  86          (let ((event (car events)))
  87            (cond ((= (getf event :type) SDL_KEYDOWN) (key-press (getf event :key.keysym.sym)))
  88                  ((= (getf event :type) SDL_KEYUP) (key-release (getf event :key.keysym.sym)))))
  89          (process-keyboard-events (cdr events)))))
  90
  91 (let ((keymap (make-hash-table))
  92       (pressed (make-hash-table))
  93       (released (make-hash-table)))
  94   (defun key? (key)
  95     (gethash (get-keycode key) keymap))
  96
  97   (defun key-pressed? (key)
  98     (gethash (get-keycode key) pressed))
  99
 100   (defun key-released? (key)
 101     (gethash (get-keycode key) released))
 102
 103   (defun key-press (key-code)
 104     (setf (gethash key-code keymap) t)
 105     (setf (gethash key-code pressed) t)
 106     (setf (gethash key-code released) nil))
 107
 108   (defun key-release (key-code)
 109     (setf (gethash key-code keymap) nil)
 110     (setf (gethash key-code pressed) nil)
 111     (setf (gethash key-code released) t))
 112
 113   (defun clear-keymap ()
 114     (clrhash keymap))
 115
 116   (defun clear-key-state ()
 117     (clrhash pressed)
 118     (clrhash released)))
 119
 120 (let ((keys
 121        '((269 . minus)
 122          (270 . plus)
 123          (273 . up)
 124          (274 . down)
 125          (275 . right)
 126          (276 . left)
 127          (282 . f1)
 128          (283 . f2)
 129          (284 . f3)
 130          (285 . f4)
 131          (286 . f5)
 132          (287 . f6)
 133          (288 . f7)
 134          (289 . f8)
 135          (290 . f9)
 136          (291 . f10)
 137          (292 . f11)
 138          (293 . f12))))
 139
 140   (defun get-keycode (keyname)
 141     (car (rassoc keyname keys)))
 142
 143   (defun get-keyname (keycode)
 144     (cdr (assoc keycode keys))))