├── notes.md ├── .gitignore ├── .editorconfig ├── skitter.sdl2.asd ├── skitter.glop.asd ├── README.md ├── glop ├── mouse-buttons.lisp ├── glop.lisp ├── package.lisp └── keys.lisp ├── frame-id.lisp ├── skitter.asd ├── sdl2 ├── mouse-buttons.lisp ├── package.lisp ├── keys.lisp └── sdl2.lisp ├── protocode ├── no-cons.lisp └── combo.lisp ├── LICENSE ├── package.lisp ├── listener.lisp ├── utils.lisp ├── common.lisp ├── protocode.lisp ├── control.lisp ├── logical-control.lisp └── input-source.lisp /notes.md: -------------------------------------------------------------------------------- 1 | # Time to make some sense of this shitshow :D 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *.fasl 3 | *.FASL 4 | *.~lock* 5 | \#*\# 6 | *.fas 7 | *.dx64fsl 8 | *.lx64fsl 9 | *.DS_Store -------------------------------------------------------------------------------- /.editorconfig: -------------------------------------------------------------------------------- 1 | # The Essentials 2 | [*] 3 | charset = utf-8 4 | end_of_line = lf 5 | insert_final_newline = true 6 | trim_trailing_whitespace = true 7 | 8 | 9 | # Indentation 10 | [*.{asd,lisp,md}] 11 | indent_style = space 12 | -------------------------------------------------------------------------------- /skitter.sdl2.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem #:skitter.sdl2 2 | :description "An event system for games - backed by sdl2" 3 | :author "Chris Bagley Baggers " 4 | :license "BSD 2 Clause" 5 | :serial t 6 | :depends-on (:skitter :sdl2) 7 | :components ((:file "sdl2/package") 8 | (:file "sdl2/sdl2") 9 | (:file "sdl2/keys") 10 | (:file "sdl2/mouse-buttons"))) 11 | -------------------------------------------------------------------------------- /skitter.glop.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem #:skitter.glop 2 | :description "An event system for games - backed by glop" 3 | :author "Chris Bagley Baggers " 4 | :license "BSD 2 Clause" 5 | :serial t 6 | :depends-on (:skitter :glop) 7 | :components ((:file "glop/package") 8 | (:file "glop/glop") 9 | (:file "glop/keys") 10 | (:file "glop/mouse-buttons"))) 11 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # skitter 2 | 3 | skitter is a repl friendly event system for games. 4 | 5 | ### Breaking API change: 2016-09-30 6 | 7 | All listeners now have 3 manadatory args before the slot key args. `(event timestamp tpref)` 8 | 9 | `tpref` (third party reference) is either nil or whatever argument the user passed to `#'cepl:step-host` 10 | 11 | This assumes that the host passed it on to skitter. Currently I expect Im the only one using this so I can say it does :p 12 | 13 | I have updated `cepl.skitter` to use this field 14 | -------------------------------------------------------------------------------- /glop/mouse-buttons.lisp: -------------------------------------------------------------------------------- 1 | (in-package skitter.glop.mouse-buttons) 2 | 3 | (defun mouse.button-id (name) 4 | (labels ((err () (error "key.id: invalid name ~s" name))) 5 | (if (keywordp name) 6 | (or (position name skitter.glop::*mouse-button-names*) (err)) 7 | (err)))) 8 | 9 | (defconstant mouse.left 1) 10 | (defconstant mouse.middle 2) 11 | (defconstant mouse.right 3) 12 | (defconstant mouse.other0 4) 13 | (defconstant mouse.other1 5) 14 | (defconstant mouse.other2 6) 15 | (defconstant mouse.other3 7) 16 | (defconstant mouse.other4 8) 17 | -------------------------------------------------------------------------------- /frame-id.lisp: -------------------------------------------------------------------------------- 1 | (in-package :skitter) 2 | 3 | (declaim (type (unsigned-byte 16) *frame-id*)) 4 | (defvar *frame-id* 0) 5 | 6 | (declaim (type (function () (unsigned-byte 16)) frame-id) 7 | (inline frame-id)) 8 | (defun frame-id () 9 | (declare (optimize (speed 3) (safety 1) (debug 0))) 10 | *frame-id*) 11 | 12 | (declaim (type (function () (values)) decay-events) 13 | (inline decay-events)) 14 | (defun decay-events () 15 | (declare (optimize (speed 3) (safety 1) (debug 0)) 16 | (inline mod expt values)) 17 | (setf *frame-id* (mod (+ *frame-id* 1) #.(expt 2 16))) 18 | (values)) 19 | -------------------------------------------------------------------------------- /skitter.asd: -------------------------------------------------------------------------------- 1 | ;;;; skitter.asd 2 | 3 | (asdf:defsystem #:skitter 4 | :description "An event system for games" 5 | :author "Chris Bagley Baggers " 6 | :license "BSD 2 Clause" 7 | :serial t 8 | :depends-on (:structy-defclass :rtg-math :alexandria) 9 | :components ((:file "package") 10 | ;; internals 11 | (:file "utils") 12 | (:file "frame-id") 13 | (:file "listener") 14 | (:file "control") 15 | (:file "input-source") 16 | (:file "logical-control") 17 | ;; universal controls & sources 18 | (:file "common"))) 19 | -------------------------------------------------------------------------------- /sdl2/mouse-buttons.lisp: -------------------------------------------------------------------------------- 1 | (in-package skitter.sdl2.mouse-buttons) 2 | 3 | (defun mouse.button-id (name/event) 4 | (etypecase name/event 5 | (keyword 6 | (or (position name/event skitter.sdl2::*mouse-button-names*) 7 | (error "mouse.button-id: invalid name ~s" name/event))) 8 | 9 | (t (error "mouse.button-id: Must be given a keyword name or an instance of the button event.~%Recieved ~s" 10 | name/event)))) 11 | 12 | (defconstant mouse.left 1) 13 | (defconstant mouse.middle 2) 14 | (defconstant mouse.right 3) 15 | (defconstant mouse.other0 4) 16 | (defconstant mouse.other1 5) 17 | (defconstant mouse.other2 6) 18 | (defconstant mouse.other3 7) 19 | (defconstant mouse.other4 8) 20 | -------------------------------------------------------------------------------- /protocode/no-cons.lisp: -------------------------------------------------------------------------------- 1 | #|| No consing 2 | 3 | We need to write data into a control rather than setting it. 4 | 5 | this means we need to know how to do that, that info has to live somewhere. 6 | This sounds like info that needs to live on the control. So we need to have 7 | a functio nthat takes.. well. 8 | 9 | either: 10 | 1. a thing of the same type and copy the contents e.g. (foo (v! 1 2 3)) 11 | 2. the elements of the thing e.g. (foo 1 2 3) 12 | 13 | hmm how does cffi do this? 14 | They use method 1, this would mean we still need to allocate 1 vector per 15 | loop (or to have one squirreled away). 16 | 17 | What about a :from-foreign option, so we can tell it how to get a ptr to 18 | into the foreign object we have. This is nice as we can use cffi and just add 19 | extra functions for each input-source: 20 | 21 | (set-mouse-pos-from-foreign ptr) 22 | 23 | hmm we still need to know how to set the data unless it is scalar or vector. 24 | 25 | Also expand-from-foreign allocates. We would need an expand-from-foreign-into 26 | method. and then arent we in the same place, we still dont know for sure about 27 | length and such. 28 | 29 | maybe we would make define-control also specify a foreign type.. again this 30 | only gets us to the point where we need to pull the data, and cffi is still 31 | gonna allocate. bums 32 | 33 | 34 | 35 | ||# 36 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016, Baggers 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | * Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. 9 | 10 | * Redistributions in binary form must reproduce the above copyright notice, 11 | this list of conditions and the following disclaimer in the documentation 12 | and/or other materials provided with the distribution. 13 | 14 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 15 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 16 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 17 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 18 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 19 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 20 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 21 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 22 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 23 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 24 | -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp 2 | 3 | (uiop:define-package #:skitter-hidden 4 | (:use #:cl)) 5 | 6 | (uiop:define-package #:skitter.internals 7 | (:use #:cl #:structy-defclass #:rtg-math) 8 | (:export 9 | ;; controls 10 | :boolean-control :make-boolean-control 11 | :symbol-control :make-symbol-control 12 | 13 | :float-control :make-float-control 14 | :vec2-control :make-vec2-control 15 | :ivec2-control :make-ivec2-control 16 | :uvec2-control :make-uvec2-control 17 | 18 | :float-decaying-control :make-float-decaying-control 19 | :vec2-decaying-control :make-vec2-decaying-control 20 | :ivec2-decaying-control :make-ivec2-decaying-control 21 | :uvec2-decaying-control :make-uvec2-decaying-control 22 | 23 | ;; sources 24 | :define-input-source :define-control :initialize-kind :add)) 25 | 26 | (uiop:define-package #:skitter 27 | (:use #:cl #:structy-defclass #:rtg-math :skitter.internals) 28 | (:import-from :alexandria :with-gensyms) 29 | (:export :make-event-listener :listen-to :stop-listening :whilst-listening-to 30 | :define-logical-control :remove-control 31 | ;; 32 | :+mice+ :mouse :make-mouse 33 | :mouse-pos :set-mouse-pos 34 | :mouse-move :set-mouse-move 35 | :mouse-button :set-mouse-button 36 | :mouse-wheel :set-mouse-wheel 37 | 38 | :+gamepads+ :gamepad :make-gamepad 39 | :gamepad-button :set-gamepad-button 40 | :gamepad-1d :set-gamepad-1d 41 | :gamepad-2d :set-gamepad-2d 42 | 43 | :+keyboard+ :keyboard :make-keyboard 44 | :keyboard-button :set-keyboard-button 45 | 46 | :+window-manager+ :window-manager :make-window-manager 47 | :window-manager-quitting :set-window-manager-quitting 48 | 49 | :+windows+ :window :make-window 50 | :window-pos :set-window-pos 51 | :window-size :set-window-size 52 | :window-closing :set-window-closing 53 | :window-layout :set-window-layout 54 | ;; 55 | :key-down-p :key-id 56 | :mouse-down-p :mouse-button-id 57 | ;; 58 | :decay-events)) 59 | -------------------------------------------------------------------------------- /listener.lisp: -------------------------------------------------------------------------------- 1 | (in-package :skitter) 2 | 3 | (defgeneric listen-to (listener input-source slot-name &optional index)) 4 | 5 | ;;---------------------------------------------------------------------- 6 | 7 | (defstruct (event-listener (:constructor %make-event-listener)) 8 | (input-source-type nil :type t) 9 | (controls (list) :type list) 10 | (subject nil :type t) 11 | (callback (error "skitter: event-listener must be created with a callback") 12 | :type (function (t t t t t t) t))) 13 | 14 | (defmethod print-object ((el event-listener) stream) 15 | (format stream "#" 16 | (event-listener-input-source-type el) 17 | (type-of (first (event-listener-controls el))) 18 | (if (rest (event-listener-controls el)) 19 | "*" 20 | ""))) 21 | 22 | (defun make-event-listener (callback) 23 | (labels ((adapter (data listener input-source index timestamp tpref) 24 | (declare (ignore listener)) 25 | (funcall callback data input-source index timestamp tpref))) 26 | (%make-event-listener :callback #'adapter))) 27 | 28 | ;;---------------------------------------------------------------------- 29 | 30 | (defmethod listen-to ((listener function) input-source 31 | slot-name &optional index) 32 | ;; listen-to for event-listeners is defined by define-input-source 33 | (let ((listener (make-event-listener listener))) 34 | (listen-to listener input-source slot-name index))) 35 | 36 | ;;---------------------------------------------------------------------- 37 | 38 | (defgeneric remove-listener (listener input)) 39 | 40 | (defun stop-listening (listener) 41 | (assert (typep listener 'event-listener)) 42 | (loop :for control :in (event-listener-controls listener) :do 43 | (remove-listener listener control))) 44 | 45 | ;;---------------------------------------------------------------------- 46 | 47 | (defmacro whilst-listening-to (mappings &body body) 48 | (let* ((callback-vars (loop :for m :in mappings 49 | :do (identity m) 50 | :collect (gensym))) 51 | (callback-attach-to (loop :for m :in mappings :collect 52 | (remove nil m)))) 53 | `(let (,@callback-vars) 54 | (unwind-protect 55 | (progn 56 | ,@(loop :for v :in callback-vars 57 | :for a :in callback-attach-to :collect 58 | `(setf ,v (listen-to ,@a))) 59 | ,@body) 60 | ,@(loop :for v :in callback-vars :collect 61 | `(when ,v (stop-listening ,v))))))) 62 | 63 | ;;---------------------------------------------------------------------- 64 | 65 | (defvar *null-listener* 66 | (make-event-listener 67 | (lambda (_0 _1 _2 _3 _4) 68 | (declare (ignore _0 _1 _2 _3 _4)) 69 | (error "skitter bug: null listener fired")))) 70 | 71 | ;;---------------------------------------------------------------------- 72 | -------------------------------------------------------------------------------- /utils.lisp: -------------------------------------------------------------------------------- 1 | (in-package :skitter) 2 | 3 | ;;---------------------------------------------------------------------- 4 | 5 | (defun denil (x) (remove nil x)) 6 | 7 | ;;---------------------------------------------------------------------- 8 | 9 | (defun make-n-long (array n) 10 | (adjust-array array n :fill-pointer n)) 11 | 12 | (defmacro ensure-n-long (array n &optional init-form) 13 | (let ((arr (gensym "array")) 14 | (len (gensym "n"))) 15 | `(let ((,arr ,array) 16 | (,len ,n)) 17 | (when (< (length ,arr) ,len) 18 | ,(if init-form 19 | `(setf (aref (make-n-long ,arr ,len) (- ,len 1)) ,init-form) 20 | `(make-n-long ,arr ,len))) 21 | ,arr))) 22 | 23 | ;;---------------------------------------------------------------------- 24 | 25 | (defun shifting-remove (arr element &optional blank) 26 | ;; {TODO} why not move last listener to hole rather than 27 | ;; shifting? 28 | (let ((count 0) 29 | (adjustable (adjustable-array-p arr))) 30 | (loop :for e :across arr :for i :from 0 :do 31 | (if (eq e element) 32 | (progn 33 | (setf (aref arr i) blank) 34 | (incf count)) 35 | (when (> count 0) 36 | (setf (aref arr (- i count)) (aref arr i)) 37 | (setf (aref arr i) blank)))) 38 | (when adjustable 39 | (decf (fill-pointer arr) count)) 40 | arr)) 41 | 42 | ;;---------------------------------------------------------------------- 43 | 44 | (defun symb (package name-part &rest name-parts) 45 | (intern (format nil "~{~a~}" (cons name-part name-parts)) 46 | package)) 47 | 48 | (defun symb- (package name-part &rest name-parts) 49 | (intern (format nil "~{~a~^-~}" (cons name-part name-parts)) 50 | package)) 51 | 52 | ;;---------------------------------------------------------------------- 53 | 54 | (defun empty-p (x) 55 | ;; here because import-from alexandria fucked up for some package 56 | ;; lock reason 57 | (alexandria:emptyp x)) 58 | 59 | ;;---------------------------------------------------------------------- 60 | 61 | (defun hide (symbol &optional package) 62 | (when (stringp symbol) (assert package)) 63 | (let* ((symbol-package (or (and (symbolp symbol) (symbol-package symbol)) 64 | package)) 65 | (symbol-name (if (stringp symbol) 66 | symbol 67 | (symbol-name symbol))) 68 | (name (format nil "~a-~a" 69 | (package-name symbol-package) 70 | symbol-name)) 71 | (skitter-hidden (find-package :skitter-hidden))) 72 | 73 | (or (find-symbol name skitter-hidden) 74 | (intern (format nil "~a-~a" 75 | (package-name symbol-package) 76 | symbol-name) 77 | skitter-hidden)))) 78 | 79 | (defun intern-hidden (&rest parts) 80 | (intern (format nil "~{~a~}" parts) :skitter-hidden)) 81 | 82 | ;;---------------------------------------------------------------------- 83 | -------------------------------------------------------------------------------- /common.lisp: -------------------------------------------------------------------------------- 1 | (in-package :skitter) 2 | 3 | ;;---------------------------------------------------------------------- 4 | 5 | (define-control boolean-control (:static t) boolean nil) 6 | (define-control symbol-control (:static t) symbol :unknown) 7 | 8 | (define-control float-control (:static t) single-float 0f0) 9 | (define-control vec2-control (:static t) rtg-math.types:vec2 (v! 0 0)) 10 | (define-control ivec2-control (:static t) rtg-math.types:ivec2 (v!int 0 0)) 11 | (define-control uvec2-control (:static t) rtg-math.types:uvec2 (v!uint 0 0)) 12 | 13 | (define-control float-decaying-control (:static t) single-float 0f0 14 | :decays t) 15 | (define-control vec2-decaying-control (:static t) rtg-math.types:vec2 16 | (v! 0 0) :decays t) 17 | (define-control ivec2-decaying-control (:static t) rtg-math.types:ivec2 18 | (v!int 0 0) :decays t) 19 | (define-control uvec2-decaying-control (:static t) rtg-math.types:uvec2 20 | (v!uint 0 0) :decays t) 21 | 22 | ;;---------------------------------------------------------------------- 23 | 24 | (define-input-source mouse (:static t) 25 | (pos vec2-control) 26 | (move vec2-decaying-control) 27 | (wheel vec2-control) 28 | (button boolean-control *)) 29 | 30 | (define-input-source gamepad (:static t) 31 | (button boolean-control *) 32 | (1d float-control *) 33 | (2d vec2-control *)) 34 | 35 | (define-input-source keyboard (:static t) 36 | (button boolean-control *)) 37 | 38 | (define-input-source window-manager (:static t) 39 | (quitting boolean-control)) 40 | 41 | (define-input-source window (:static t) 42 | (pos ivec2-control) 43 | (size uvec2-control) 44 | (closing boolean-control) 45 | (layout symbol-control)) 46 | 47 | ;;---------------------------------------------------------------------- 48 | 49 | ;; {TODO} better name 50 | (defvar +window-manager+ (make-window-manager)) 51 | 52 | ;;---------------------------------------------------------------------- 53 | 54 | (defvar +keyboards+ (make-array 1 :element-type '(or keyboard null) 55 | :adjustable t :fill-pointer 0)) 56 | 57 | (defun keyboard (&optional (n 0)) 58 | (when (> (1+ n) (length +keyboards+)) 59 | (adjust-array +keyboards+ (1+ n) :fill-pointer (1+ n) :initial-element nil) 60 | (setf (aref +keyboards+ n) (make-keyboard))) 61 | (aref +keyboards+ n)) 62 | 63 | (defun key-down-p (index &optional (keyboard (keyboard 0))) 64 | (keyboard-button keyboard index)) 65 | 66 | ;;---------------------------------------------------------------------- 67 | 68 | 69 | (defvar +mice+ (make-array 1 :element-type '(or null mouse) 70 | :adjustable t :fill-pointer 0)) 71 | 72 | (defun mouse (&optional (n 0)) 73 | (when (> (1+ n) (length +mice+)) 74 | (adjust-array +mice+ (1+ n) :fill-pointer (1+ n) :initial-element nil) 75 | (setf (aref +mice+ n) (make-mouse))) 76 | (aref +mice+ n)) 77 | 78 | (defun mouse-down-p (index &optional (mouse (mouse 0))) 79 | (mouse-button mouse index)) 80 | 81 | ;;---------------------------------------------------------------------- 82 | 83 | (defvar +gamepads+ (make-array 1 :element-type '(or gamepad null) 84 | :adjustable t :fill-pointer 0)) 85 | 86 | (defun gamepad (&optional (n 0)) 87 | (when (> (1+ n) (length +gamepads+)) 88 | (adjust-array +gamepads+ (1+ n) :fill-pointer (1+ n) :initial-element nil) 89 | (setf (aref +gamepads+ n) (make-gamepad))) 90 | (aref +gamepads+ n)) 91 | 92 | ;;---------------------------------------------------------------------- 93 | 94 | (defvar +windows+ (make-array 1 :element-type '(or null window) 95 | :adjustable t :fill-pointer 0)) 96 | 97 | (defun window (n) 98 | (when (> (1+ n) (length +windows+)) 99 | (adjust-array +windows+ (1+ n) :fill-pointer (1+ n) :initial-element nil) 100 | (setf (aref +windows+ n) (make-window))) 101 | (aref +windows+ n)) 102 | 103 | ;;---------------------------------------------------------------------- 104 | -------------------------------------------------------------------------------- /protocode/combo.lisp: -------------------------------------------------------------------------------- 1 | (in-package :skitter) 2 | 3 | ;;---------------------------------------------------------------------- 4 | 5 | (defmacro resetting-when (predicate-form &body body) 6 | (declare (ignore predicate-form body)) 7 | (error "Skitter's resetting-when macro can only be used within defcombo")) 8 | 9 | (defmacro defcombo (name (event-var &rest controls) slots &body body) 10 | (assert (string= (first controls) :&control)) 11 | (let* ((slots (append `((%step 0 fixnum) 12 | (%last-event-time 0 fixnum) 13 | (%last-step-time 0 fixnum)) 14 | slots)) 15 | (raw-controls controls) 16 | (controls (mapcar (lambda (x) 17 | `(,(first x) ,(second x) 18 | ,@(when (third x) 19 | (list (intern (symbol-name (third x)) 20 | :keyword))))) 21 | (cdr controls))) 22 | (top (gensym "top")) 23 | (reset-harder (gensym "reset-harder"))) 24 | `(define-predicate-control ,name (,event-var ,@raw-controls) ,slots 25 | (macrolet ((resetting-when (predicate-form &body body) 26 | `(if ,predicate-form 27 | (progn ,@body) 28 | (reset))) 29 | ,@(loop :for (name kind slot) :in controls :append 30 | (let* ((acc (intern (format nil "~a-~a" kind slot) 31 | (symbol-package kind))) 32 | (pred 33 | `(eq (control-container-slot ,event-var) 34 | ',acc))) 35 | `((,name (&optional index) 36 | (if index 37 | `(,',acc ,',kind index) 38 | `(,',acc ,',kind))) 39 | (,(intern (format nil "~s-P" name) 40 | (symbol-package name)) 41 | (&optional index) 42 | (if index 43 | (list 'and ',pred 44 | (list '= '(control-container-index 45 | ,event-var) 46 | index)) 47 | ',pred)))))) 48 | (let ((%time (get-internal-real-time)) 49 | (,reset-harder nil)) 50 | (block ,top 51 | (labels ((reset () 52 | (if ,reset-harder 53 | (reset-hard) 54 | (progn 55 | (setf %step 0) 56 | (setf ,reset-harder t) 57 | (return-from ,top (body ,event-var))))) 58 | (reset-hard () 59 | (setf %step 0) 60 | (return-from ,top)) 61 | (before (offset) 62 | (< (- %time %last-step-time) offset)) 63 | (after (offset) 64 | (> (- %time %last-step-time) offset)) 65 | (between (start-offset end-offset) 66 | (and (after start-offset) (before end-offset))) 67 | (body (,event-var) 68 | (case= %step 69 | ,@(loop for b in body for i from 0 collect 70 | `(,i ,b))))) 71 | (declare (ignorable #'reset #'reset-hard #'before 72 | #'after #'between)) 73 | (let ((result (body ,event-var))) 74 | (setf %last-event-time %time) 75 | (when result 76 | (setf %last-step-time %time) 77 | (if (= %step ,(length body)) 78 | (progn (setf %step 0) t) 79 | (progn (incf %step 1) nil))))))))))) 80 | -------------------------------------------------------------------------------- /protocode.lisp: -------------------------------------------------------------------------------- 1 | (in-package :skitter) 2 | 3 | ;; to define a combo 4 | (defcombo boom ((m mouse) (g gamepad) (k keyboard)) 5 | (then (and (keyboard-button k :lctrl) 6 | (keyboard-button k :c)) 7 | (before 200 (keboard-button k :a)) 8 | (before 100 (gamepad-button g 0)))) 9 | 10 | ;; to get the combo listener 11 | (make-boom :m some-mouse :g gpad :k kbd) 12 | 13 | 14 | (defun make-boom (m g k) 15 | (tlambda () 16 | (then (until (and (keyboard-button k :lctrl) 17 | (keyboard-button k :c))) 18 | (before 200 19 | (if (keboard-button k :a) 20 | (skip-step) 21 | ???????????)) 22 | (before 100 23 | (if (gamepad-button g 0) 24 | (boom!) 25 | ???????????))))) 26 | 27 | (defun boom! () 28 | (print "BOOM!")) 29 | 30 | ;; ah so it turns out the problem is that the state machien for input need to be 31 | ;; based on the timestamps, but temporal-functions are based on real-time. 32 | ;; Lets just make a macro that is the syntactic dual of temporal functions 33 | 34 | (defcombo boom (evt &source (m mouse) (g gamepad) (k keyboard)) 35 | (and (keyboard-button k :lctrl) 36 | (keyboard-button k :c)) 37 | (before 200 (keboard-button k :a)) 38 | (before 100 (gamepad-button g 0))) 39 | 40 | (defun make-boom (evt) 41 | (let ((step 0)) 42 | (lambda (evt) 43 | (tagbody top 44 | (case= step 45 | (0 ()) 46 | (1 ()) 47 | (2 ())))))) 48 | 49 | ;; - ok so we need to know every event for every input 50 | ;; - but wait what about mouse button combos...we dont want to be disturbed by 51 | ;; mouse movement...Ok os maybe we need to specify the input and the source. 52 | ;; that means we need: 53 | ;; - the source.. 54 | 55 | ;; Cant we just have: 56 | ;; 57 | ;; :step-predicate 58 | ;; :reset-predicate 59 | ;; 60 | ;; for each step? 61 | ;; then we need to see every event..thing is that we have 'apply' instead 62 | ;; of 'true' events 63 | 64 | (defcombo boom (evt &source (m mouse) (g gamepad) (k keyboard)) 65 | :step (and (keyboard-button k :lctrl) 66 | (keyboard-button k :c)) 67 | :reset (any other k g event or any m-button event) 68 | 69 | :step (before 200 (keboard-button k :a)) 70 | :reset (expire or any other k g event or any m-button event ) 71 | 72 | :step (before 100 (gamepad-button g 0)) 73 | :reset (expire or any other k g event or any m-button event )) 74 | 75 | ;; remeber that each time an apply happens, the whole chain propagates. 76 | ;; So any depenmdent combo will see the event (with timestamp). 77 | ;; So how does the combo.. 78 | 79 | ;; trying again 80 | 81 | (defcombo boom (evt &source (m mouse button) (key keyboard button)) () 82 | (or (and (print 1) 83 | (or (print (key-p 0)) 84 | (key-p x)) 85 | (button-down-p evt)) 86 | (progn (print "reset") (reset))) 87 | 88 | (or (and (or (key-p 0) 89 | (key-p key.rctrl)) 90 | (not (button-down-p evt)) 91 | (print 2)) 92 | (reset)) 93 | 94 | (or (and (before 200) 95 | (key-p key.a) 96 | (button-down-p evt)) 97 | (reset)) 98 | 99 | (or (and (before 200) 100 | (key-p key.a) 101 | (button-down-p evt)) 102 | (reset)) 103 | 104 | (or (and (before 100) 105 | (button-down-p evt)) 106 | (reset))) 107 | 108 | 109 | ;; ok so now, how shall we use this? 110 | ;; most common will be basic input, keys bound to actions 111 | ;; need to check if a key is down 112 | 113 | (defcombo alias (evt &source (key keyboard button)) 114 | ((index (get-index-by-name 'keyboard 'button :a) fixnum)) 115 | (when ()) 116 | (button-down-p evt)) 117 | ;; nah 118 | 119 | (defun key-watcher (name &optional keyboard) 120 | (let ((index (get-index-by-name 'keyboard :button name))) 121 | (if keyboard 122 | (lambda () (button-down-p (keyboard-button keyboard index))) 123 | (lambda (keyboard) (button-down-p (keyboard-button keyboard index)))))) 124 | ;; nah 125 | 126 | 127 | (defun key-down-p (index &optional (keyboard (keyboard 0))) 128 | (button-down-p (keyboard-button keyboard index))) 129 | 130 | (defun key-id (name) 131 | (get-index-by-name 'keyboard :button name)) 132 | 133 | ;; well this is more sane 134 | 135 | ;; get-index-by-name is stupid, it still ends up backend specific so just use 136 | ;; constants 137 | -------------------------------------------------------------------------------- /glop/glop.lisp: -------------------------------------------------------------------------------- 1 | (in-package :skitter.glop) 2 | 3 | ;;-------------------------------------------- 4 | ;; scancode lookup 5 | 6 | (defvar *mouse-button-names* 7 | #(:0 :left :middle :right :other0 :other1 :other2 :other3 :other4)) 8 | 9 | (defvar *key-button-names* 10 | #(:unknown nil nil nil :a :b 11 | :c :d :e :f 12 | :g :h :i :j 13 | :k :l :m :n 14 | :o :p :q :r 15 | :s :t :u :v 16 | :w :x :y :z 17 | :1 :2 :3 :4 18 | :5 :6 :7 :8 19 | :9 :0 :return :escape 20 | :backspace :tab :space 21 | :minus :equals :leftbracket 22 | :rightbracket :backslash :nonushash 23 | :semicolon :apostrophe :grave 24 | :comma :period :slash 25 | :capslock :f1 :f2 :f3 26 | :f4 :f5 :f6 :f7 27 | :f8 :f9 :f10 :f11 28 | :f12 :printscreen :scrolllock 29 | :pause :insert :home 30 | :pageup :delete :end 31 | :pagedown :right :left 32 | :down :up :numlockclear 33 | :kp_divide :kp_multiply :kp_minus 34 | :kp_plus :kp_enter :kp_1 35 | :kp_2 :kp_3 :kp_4 :kp_5 36 | :kp_6 :kp_7 :kp_8 :kp_9 37 | :kp_0 :kp_period :nonusbackslash 38 | :application :power :kp_equals 39 | :f13 :f14 :f15 :f16 40 | :f17 :f18 :f19 :f20 41 | :f21 :f22 :f23 :f24 42 | :execute :help :menu 43 | :select :stop :again 44 | :undo :cut :copy :paste 45 | :find :mute :volumeup 46 | :volumedown :lockingcapslock 47 | :lockingnumlock :lockingscrolllock 48 | :kp_comma :kp_equalsas400 49 | :international1 :international2 50 | :international3 :international4 51 | :international5 :international6 52 | :international7 :international8 53 | :international9 :lang1 :lang2 54 | :lang3 :lang4 :lang5 55 | :lang6 :lang7 :lang8 56 | :lang9 :alterase :sysreq 57 | :cancel :clear :prior 58 | :return2 :separator :out 59 | :oper :clearagain :crsel 60 | :exsel nil nil nil nil nil nil nil nil nil nil nil 61 | :kp_00 :kp_000 :thousandsseparator 62 | :decimalseparator :currencyunit 63 | :currencysubunit :kp_leftparen 64 | :kp_rightparen :kp_leftbrace 65 | :kp_rightbrace :kp_tab :kp_backspace 66 | :kp_a :kp_b :kp_c :kp_d 67 | :kp_e :kp_f :kp_xor 68 | :kp_power :kp_percent :kp_less 69 | :kp_greater :kp_ampersand 70 | :kp_dblampersand :kp_verticalbar 71 | :kp_dblverticalbar :kp_colon :kp_hash 72 | :kp_space :kp_at :kp_exclam 73 | :kp_memstore :kp_memrecall 74 | :kp_memclear :kp_memadd 75 | :kp_memsubtract :kp_memmultiply 76 | :kp_memdivide :kp_plusminus :kp_clear 77 | :kp_clearentry :kp_binary :kp_octal 78 | :kp_decimal :kp_hexadecimal nil nil 79 | :lctrl :lshift :lalt 80 | :lgui :rctrl :rshift 81 | :ralt :rgui nil nil nil nil nil nil nil nil nil nil 82 | nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil 83 | :mode :audionext :audioprev 84 | :audiostop :audioplay :audiomute 85 | :mediaselect :www :mail 86 | :calculator :computer :ac_search 87 | :ac_home :ac_back :ac_forward 88 | :ac_stop :ac_refresh :ac_bookmarks 89 | :brightnessdown :brightnessup 90 | :displayswitch :kbdillumtoggle 91 | :kbdillumdown :kbdillumup :eject 92 | :sleep)) 93 | 94 | ;;-------------------------------------------- 95 | ;; glop event helpers 96 | 97 | (defmacro %case-event ((event) &body type-handlers) 98 | `(typecase ,event 99 | ,@type-handlers)) 100 | 101 | (defun on-event (event &optional tpref) 102 | (%case-event (event) 103 | (glop:close-event 104 | (set-window-manager-quitting 105 | +window-manager+ (get-internal-real-time) t tpref)) 106 | 107 | (glop:resize-event 108 | (set-window-size (window 0) (get-internal-real-time) 109 | (v!uint (glop:width event) (glop:height event)) 110 | tpref)) 111 | 112 | (glop:mouse-motion-event 113 | (let* ((mouse-id 0) 114 | (mouse (mouse mouse-id))) 115 | (set-mouse-pos mouse 116 | (get-internal-real-time) 117 | (v! (glop:x event) (glop:y event)) 118 | tpref) 119 | (set-mouse-move mouse 120 | (get-internal-real-time) 121 | (v! (glop:dx event) (glop:dy event)) 122 | tpref))) 123 | 124 | (glop:button-press-event 125 | (let* ((mouse-id 0) 126 | (mouse (mouse mouse-id))) 127 | (set-mouse-button 128 | mouse (glop:button event) (get-internal-real-time) t tpref))) 129 | 130 | (glop:button-release-event 131 | (let* ((mouse-id 0) 132 | (mouse (mouse mouse-id))) 133 | (set-mouse-button 134 | mouse (glop:button event) (get-internal-real-time) nil tpref))) 135 | 136 | (glop:key-press-event 137 | ;; (glop:keycode #:g1761) 138 | ;; (glop:keysym #:g1761) 139 | ;; (glop:text #:g1761) 140 | (let ((kbd (keyboard 0))) 141 | (set-keyboard-button 142 | kbd (glop:keycode event) (get-internal-real-time) t tpref))) 143 | 144 | (glop:key-release-event 145 | ;; (glop:keycode #:g1761) 146 | ;; (glop:keysym #:g1761) 147 | ;; (glop:text #:g1761) 148 | (let ((kbd (keyboard 0))) 149 | (set-keyboard-button 150 | kbd (glop:keycode event) (get-internal-real-time) nil tpref))) 151 | 152 | ;; (glop:expose-event 153 | ;; (glop:on-resize win (glop:width #:g1761) (glop:height #:g1761)) 154 | ;; (glop:on-draw win)) 155 | 156 | ;; (glop:visibility-event 157 | ;; (glop::on-visibility win (glop:visible #:g1761))) 158 | 159 | ;; (glop:focus-event (glop::on-focus win (glop:focused #:g1761))) 160 | )) 161 | 162 | (defun collect-glop-events (win &optional tpref) 163 | (loop :for event := (glop:next-event win :blocking nil) :while event :do 164 | (on-event event tpref))) 165 | 166 | ;;-------------------------------------------- 167 | ;; intializing 168 | 169 | (defmethod initialize-kind :after ((kind keyboard)) 170 | (loop for nil across *key-button-names* do 171 | (add kind (make-boolean-control)))) 172 | 173 | (defmethod initialize-kind :after ((kind mouse)) 174 | (loop for nil across *mouse-button-names* do 175 | (add kind (make-boolean-control)))) 176 | -------------------------------------------------------------------------------- /control.lisp: -------------------------------------------------------------------------------- 1 | (in-package :skitter) 2 | 3 | ;; - We only hold the latest state in a control 4 | ;; - if you need a signal that is a composition of events then use a combo 5 | ;; - 6 | 7 | ;;---------------------------------------------------------------------- 8 | 9 | ;; We used to have a supertype called control but has to remove it as we want 10 | ;; to be able to have some controls be dynamically redefinable (using classes) 11 | ;; and some to be static (using structs) 12 | 13 | (defgeneric add (inst control)) 14 | (defgeneric control-listeners (control)) 15 | (defgeneric remove-control (control) 16 | (:method ((control t)) nil)) 17 | 18 | ;;---------------------------------------------------------------------- 19 | 20 | (defun control-hidden-constructor-name (control-type) 21 | (intern-hidden "%MAKE-" control-type)) 22 | 23 | (defun control-constructor-name (control-type) 24 | (symb (package-name (symbol-package control-type)) "MAKE-" control-type)) 25 | 26 | (defun control-data-acc-name (control-type) 27 | (symb (package-name (symbol-package control-type)) control-type "-DATA")) 28 | 29 | (defun control-hidden-data-name (control-type) 30 | (hide (control-data-acc-name control-type))) 31 | 32 | (defun control-container-slot-name (control-type) 33 | (intern-hidden control-type "-CONTAINER-SLOT")) 34 | 35 | (defun control-container-index-name (control-type) 36 | (intern-hidden control-type "-CONTAINER-INDEX")) 37 | 38 | (defun control-listeners-name (control-type) 39 | (intern-hidden control-type "-LISTENERS")) 40 | 41 | (defun control-decay-name (control-type) 42 | (intern-hidden (package-name (symbol-package control-type)) "-" control-type "-DECAYS-P")) 43 | 44 | (defun control-last-frame-name (control-type) 45 | (intern-hidden (package-name (symbol-package control-type)) "-" control-type "-LAST-FRAME")) 46 | 47 | (defmacro define-control (name (&key static) type init-val &key decays) 48 | (let* ((constructor (control-hidden-constructor-name name)) 49 | (def (if static 'defstruct 'deftclass))) 50 | `(progn 51 | (,def (,name (:conc-name nil) 52 | (:constructor ,constructor)) 53 | (,(control-decay-name name) ,decays :type boolean) 54 | (,(control-last-frame-name name) 0 :type (unsigned-byte 16)) 55 | (,(control-hidden-data-name name) ,init-val :type ,type) 56 | (,(control-container-slot-name name) :unknown-slot :type symbol) 57 | (,(control-container-index-name name) -1 :type fixnum) 58 | (,(control-listeners-name name) 59 | (make-array 0 :element-type 'event-listener :adjustable t 60 | :fill-pointer 0) 61 | :type (array event-listener (*)))) 62 | 63 | ;; This exists so people can't set values via the constructor 64 | (defun ,(control-constructor-name name) () 65 | (,constructor)) 66 | ;; set & get the data 67 | (declaim (type (function (,name (unsigned-byte 16)) ,type) 68 | ,(control-data-acc-name name)) 69 | (inline ,(control-data-acc-name name))) 70 | (defun ,(control-data-acc-name name) (control) 71 | (declare (optimize (speed 3) (safety 1) (debug 0)) 72 | (inline frame-id ,(control-decay-name name) 73 | ,(control-last-frame-name name) 74 | ,(control-hidden-data-name name)) 75 | (type ,name control)) 76 | (let ((frame-id (frame-id))) 77 | (if (and (,(control-decay-name name) control) 78 | (/= (,(control-last-frame-name name) control) frame-id)) 79 | (progn 80 | (setf (,(control-last-frame-name name) control) frame-id) 81 | (setf (,(control-hidden-data-name name) control) ,init-val)) 82 | (,(control-hidden-data-name name) control)))) 83 | (defun (setf ,(control-data-acc-name name)) (value control) 84 | (declare (optimize (speed 3) (safety 1) (debug 0)) 85 | (inline frame-id ,(control-last-frame-name name) 86 | ,(control-hidden-data-name name)) 87 | (type ,name control) 88 | (type ,type value)) 89 | (let ((frame-id (frame-id))) 90 | (setf (,(control-last-frame-name name) control) frame-id) 91 | (setf (,(control-hidden-data-name name) control) value))) 92 | ;; 93 | (defmethod control-listeners ((control ,name)) 94 | (,(control-listeners-name name) control)) 95 | (defmethod remove-listener ((listener event-listener) (control ,name)) 96 | (shifting-remove (,(control-listeners-name name) control) 97 | listener 98 | *null-listener*) 99 | nil)))) 100 | 101 | ;;---------------------------------------------------------------------- 102 | 103 | (defgeneric listen-to-control (control listener) 104 | (:method (control (listener event-listener)) 105 | (let ((arr (control-listeners control))) 106 | (vector-push-extend listener arr) 107 | (push control (event-listener-controls listener)) 108 | listener))) 109 | 110 | ;; {TODO} make this control specific as it's the only one using 111 | ;; control-listeners. 112 | ;; Would also need adding to logical-control 113 | (defun propagate (data control input-source index timestamp tpref) 114 | (loop :for listener :across (control-listeners control) :do 115 | (funcall (event-listener-callback listener) 116 | data listener input-source index timestamp tpref))) 117 | 118 | ;;---------------------------------------------------------------------- 119 | 120 | (defmacro set-control-slots (control-type control slot-name index) 121 | "Set all the slots of an event source" 122 | (with-gensyms (ctrl current s-name idx) 123 | `(let* ((,ctrl ,control) 124 | (,s-name ,slot-name) 125 | (,idx ,index) 126 | (,current 127 | (or (unless (eq (,(control-container-slot-name control-type) 128 | ,ctrl) 129 | :unknown-slot) 130 | ,s-name) 131 | (unless (= (,(control-container-index-name control-type) 132 | ,ctrl) 133 | -1) 134 | ,idx)))) 135 | (assert (null ,current) () "SKITTER: ~a is already used in ~a" 136 | ,current ,ctrl) 137 | (setf (,(control-container-slot-name control-type) ,ctrl) ,s-name 138 | (,(control-container-index-name control-type) ,ctrl) ,idx)))) 139 | 140 | ;;---------------------------------------------------------------------- 141 | -------------------------------------------------------------------------------- /glop/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp 2 | 3 | (uiop:define-package #:skitter.glop 4 | (:use #:cl #:skitter #:rtg-math #:skitter.internals) 5 | (:export :collect-glop-events)) 6 | 7 | (uiop:define-package #:skitter.glop.keys 8 | (:use #:cl) 9 | (:export :key.id 10 | :key.a 11 | :key.b 12 | :key.c 13 | :key.d 14 | :key.e 15 | :key.f 16 | :key.g 17 | :key.h 18 | :key.i 19 | :key.j 20 | :key.k 21 | :key.l 22 | :key.m 23 | :key.n 24 | :key.o 25 | :key.p 26 | :key.q 27 | :key.r 28 | :key.s 29 | :key.t 30 | :key.u 31 | :key.v 32 | :key.w 33 | :key.x 34 | :key.y 35 | :key.z 36 | :key.1 37 | :key.2 38 | :key.3 39 | :key.4 40 | :key.5 41 | :key.6 42 | :key.7 43 | :key.8 44 | :key.9 45 | :key.0 46 | :key.return 47 | :key.escape 48 | :key.backspace 49 | :key.tab 50 | :key.space 51 | :key.minus 52 | :key.equals 53 | :key.leftbracket 54 | :key.rightbracket 55 | :key.backslash 56 | :key.nonushash 57 | :key.semicolon 58 | :key.apostrophe 59 | :key.grave 60 | :key.comma 61 | :key.period 62 | :key.slash 63 | :key.capslock 64 | :key.f1 65 | :key.f2 66 | :key.f3 67 | :key.f4 68 | :key.f5 69 | :key.f6 70 | :key.f7 71 | :key.f8 72 | :key.f9 73 | :key.f10 74 | :key.f11 75 | :key.f12 76 | :key.printscreen 77 | :key.scrolllock 78 | :key.pause 79 | :key.insert 80 | :key.home 81 | :key.pageup 82 | :key.delete 83 | :key.end 84 | :key.pagedown 85 | :key.right 86 | :key.left 87 | :key.down 88 | :key.up 89 | :key.numlockclear 90 | :key.kp_divide 91 | :key.kp_multiply 92 | :key.kp_minus 93 | :key.kp_plus 94 | :key.kp_enter 95 | :key.kp_1 96 | :key.kp_2 97 | :key.kp_3 98 | :key.kp_4 99 | :key.kp_5 100 | :key.kp_6 101 | :key.kp_7 102 | :key.kp_8 103 | :key.kp_9 104 | :key.kp_0 105 | :key.kp_period 106 | :key.nonusbackslash 107 | :key.application 108 | :key.power 109 | :key.kp_equals 110 | :key.f13 111 | :key.f14 112 | :key.f15 113 | :key.f16 114 | :key.f17 115 | :key.f18 116 | :key.f19 117 | :key.f20 118 | :key.f21 119 | :key.f22 120 | :key.f23 121 | :key.f24 122 | :key.execute 123 | :key.help 124 | :key.menu 125 | :key.select 126 | :key.stop 127 | :key.again 128 | :key.undo 129 | :key.cut 130 | :key.copy 131 | :key.paste 132 | :key.find 133 | :key.mute 134 | :key.volumeup 135 | :key.volumedown 136 | :key.lockingcapslock 137 | :key.lockingnumlock 138 | :key.lockingscrolllock 139 | :key.kp_comma 140 | :key.kp_equalsas400 141 | :key.international1 142 | :key.international2 143 | :key.international3 144 | :key.international4 145 | :key.international5 146 | :key.international6 147 | :key.international7 148 | :key.international8 149 | :key.international9 150 | :key.lang1 151 | :key.lang2 152 | :key.lang3 153 | :key.lang4 154 | :key.lang5 155 | :key.lang6 156 | :key.lang7 157 | :key.lang8 158 | :key.lang9 159 | :key.alterase 160 | :key.sysreq 161 | :key.cancel 162 | :key.clear 163 | :key.prior 164 | :key.return2 165 | :key.separator 166 | :key.out 167 | :key.oper 168 | :key.clearagain 169 | :key.crsel 170 | :key.exsel 171 | :key.kp_00 172 | :key.kp_000 173 | :key.thousandsseparator 174 | :key.decimalseparator 175 | :key.currencyunit 176 | :key.currencysubunit 177 | :key.kp_leftparen 178 | :key.kp_rightparen 179 | :key.kp_leftbrace 180 | :key.kp_rightbrace 181 | :key.kp_tab 182 | :key.kp_backspace 183 | :key.kp_a 184 | :key.kp_b 185 | :key.kp_c 186 | :key.kp_d 187 | :key.kp_e 188 | :key.kp_f 189 | :key.kp_xor 190 | :key.kp_power 191 | :key.kp_percent 192 | :key.kp_less 193 | :key.kp_greater 194 | :key.kp_ampersand 195 | :key.kp_dblampersand 196 | :key.kp_verticalbar 197 | :key.kp_dblverticalbar 198 | :key.kp_colon 199 | :key.kp_hash 200 | :key.kp_space 201 | :key.kp_at 202 | :key.kp_exclam 203 | :key.kp_memstore 204 | :key.kp_memrecall 205 | :key.kp_memclear 206 | :key.kp_memadd 207 | :key.kp_memsubtract 208 | :key.kp_memmultiply 209 | :key.kp_memdivide 210 | :key.kp_plusminus 211 | :key.kp_clear 212 | :key.kp_clearentry 213 | :key.kp_binary 214 | :key.kp_octal 215 | :key.kp_decimal 216 | :key.kp_hexadecimal 217 | :key.lctrl 218 | :key.lshift 219 | :key.lalt 220 | :key.lgui 221 | :key.rctrl 222 | :key.rshift 223 | :key.ralt 224 | :key.rgui 225 | :key.mode 226 | :key.audionext 227 | :key.audioprev 228 | :key.audiostop 229 | :key.audioplay 230 | :key.audiomute 231 | :key.mediaselect 232 | :key.www 233 | :key.mail 234 | :key.calculator 235 | :key.computer 236 | :key.ac_search 237 | :key.ac_home 238 | :key.ac_back 239 | :key.ac_forward 240 | :key.ac_stop 241 | :key.ac_refresh 242 | :key.ac_bookmarks 243 | :key.brightnessdown 244 | :key.brightnessup 245 | :key.displayswitch 246 | :key.kbdillumtoggle 247 | :key.kbdillumdown 248 | :key.kbdillumup 249 | :key.eject 250 | :key.sleep)) 251 | 252 | (defpackage #:skitter.glop.mouse-buttons 253 | (:use #:cl) 254 | (:export :mouse.button-id 255 | :mouse.left 256 | :mouse.middle 257 | :mouse.right 258 | :mouse.other0 259 | :mouse.other1 260 | :mouse.other2 261 | :mouse.other3 262 | :mouse.other4)) 263 | -------------------------------------------------------------------------------- /sdl2/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp 2 | 3 | (uiop:define-package #:skitter.sdl2 4 | (:use #:cl #:skitter #:rtg-math #:skitter.internals) 5 | (:export :collect-sdl-events :enable-background-joystick-events)) 6 | 7 | (defpackage #:skitter.sdl2.keys 8 | (:use #:cl) 9 | (:export :key.id 10 | :key.a 11 | :key.b 12 | :key.c 13 | :key.d 14 | :key.e 15 | :key.f 16 | :key.g 17 | :key.h 18 | :key.i 19 | :key.j 20 | :key.k 21 | :key.l 22 | :key.m 23 | :key.n 24 | :key.o 25 | :key.p 26 | :key.q 27 | :key.r 28 | :key.s 29 | :key.t 30 | :key.u 31 | :key.v 32 | :key.w 33 | :key.x 34 | :key.y 35 | :key.z 36 | :key.1 37 | :key.2 38 | :key.3 39 | :key.4 40 | :key.5 41 | :key.6 42 | :key.7 43 | :key.8 44 | :key.9 45 | :key.0 46 | :key.return 47 | :key.escape 48 | :key.backspace 49 | :key.tab 50 | :key.space 51 | :key.minus 52 | :key.equals 53 | :key.leftbracket 54 | :key.rightbracket 55 | :key.backslash 56 | :key.nonushash 57 | :key.semicolon 58 | :key.apostrophe 59 | :key.grave 60 | :key.comma 61 | :key.period 62 | :key.slash 63 | :key.capslock 64 | :key.f1 65 | :key.f2 66 | :key.f3 67 | :key.f4 68 | :key.f5 69 | :key.f6 70 | :key.f7 71 | :key.f8 72 | :key.f9 73 | :key.f10 74 | :key.f11 75 | :key.f12 76 | :key.printscreen 77 | :key.scrolllock 78 | :key.pause 79 | :key.insert 80 | :key.home 81 | :key.pageup 82 | :key.delete 83 | :key.end 84 | :key.pagedown 85 | :key.right 86 | :key.left 87 | :key.down 88 | :key.up 89 | :key.numlockclear 90 | :key.kp_divide 91 | :key.kp_multiply 92 | :key.kp_minus 93 | :key.kp_plus 94 | :key.kp_enter 95 | :key.kp_1 96 | :key.kp_2 97 | :key.kp_3 98 | :key.kp_4 99 | :key.kp_5 100 | :key.kp_6 101 | :key.kp_7 102 | :key.kp_8 103 | :key.kp_9 104 | :key.kp_0 105 | :key.kp_period 106 | :key.nonusbackslash 107 | :key.application 108 | :key.power 109 | :key.kp_equals 110 | :key.f13 111 | :key.f14 112 | :key.f15 113 | :key.f16 114 | :key.f17 115 | :key.f18 116 | :key.f19 117 | :key.f20 118 | :key.f21 119 | :key.f22 120 | :key.f23 121 | :key.f24 122 | :key.execute 123 | :key.help 124 | :key.menu 125 | :key.select 126 | :key.stop 127 | :key.again 128 | :key.undo 129 | :key.cut 130 | :key.copy 131 | :key.paste 132 | :key.find 133 | :key.mute 134 | :key.volumeup 135 | :key.volumedown 136 | :key.lockingcapslock 137 | :key.lockingnumlock 138 | :key.lockingscrolllock 139 | :key.kp_comma 140 | :key.kp_equalsas400 141 | :key.international1 142 | :key.international2 143 | :key.international3 144 | :key.international4 145 | :key.international5 146 | :key.international6 147 | :key.international7 148 | :key.international8 149 | :key.international9 150 | :key.lang1 151 | :key.lang2 152 | :key.lang3 153 | :key.lang4 154 | :key.lang5 155 | :key.lang6 156 | :key.lang7 157 | :key.lang8 158 | :key.lang9 159 | :key.alterase 160 | :key.sysreq 161 | :key.cancel 162 | :key.clear 163 | :key.prior 164 | :key.return2 165 | :key.separator 166 | :key.out 167 | :key.oper 168 | :key.clearagain 169 | :key.crsel 170 | :key.exsel 171 | :key.kp_00 172 | :key.kp_000 173 | :key.thousandsseparator 174 | :key.decimalseparator 175 | :key.currencyunit 176 | :key.currencysubunit 177 | :key.kp_leftparen 178 | :key.kp_rightparen 179 | :key.kp_leftbrace 180 | :key.kp_rightbrace 181 | :key.kp_tab 182 | :key.kp_backspace 183 | :key.kp_a 184 | :key.kp_b 185 | :key.kp_c 186 | :key.kp_d 187 | :key.kp_e 188 | :key.kp_f 189 | :key.kp_xor 190 | :key.kp_power 191 | :key.kp_percent 192 | :key.kp_less 193 | :key.kp_greater 194 | :key.kp_ampersand 195 | :key.kp_dblampersand 196 | :key.kp_verticalbar 197 | :key.kp_dblverticalbar 198 | :key.kp_colon 199 | :key.kp_hash 200 | :key.kp_space 201 | :key.kp_at 202 | :key.kp_exclam 203 | :key.kp_memstore 204 | :key.kp_memrecall 205 | :key.kp_memclear 206 | :key.kp_memadd 207 | :key.kp_memsubtract 208 | :key.kp_memmultiply 209 | :key.kp_memdivide 210 | :key.kp_plusminus 211 | :key.kp_clear 212 | :key.kp_clearentry 213 | :key.kp_binary 214 | :key.kp_octal 215 | :key.kp_decimal 216 | :key.kp_hexadecimal 217 | :key.lctrl 218 | :key.lshift 219 | :key.lalt 220 | :key.lgui 221 | :key.rctrl 222 | :key.rshift 223 | :key.ralt 224 | :key.rgui 225 | :key.mode 226 | :key.audionext 227 | :key.audioprev 228 | :key.audiostop 229 | :key.audioplay 230 | :key.audiomute 231 | :key.mediaselect 232 | :key.www 233 | :key.mail 234 | :key.calculator 235 | :key.computer 236 | :key.ac_search 237 | :key.ac_home 238 | :key.ac_back 239 | :key.ac_forward 240 | :key.ac_stop 241 | :key.ac_refresh 242 | :key.ac_bookmarks 243 | :key.brightnessdown 244 | :key.brightnessup 245 | :key.displayswitch 246 | :key.kbdillumtoggle 247 | :key.kbdillumdown 248 | :key.kbdillumup 249 | :key.eject 250 | :key.sleep)) 251 | 252 | (defpackage #:skitter.sdl2.mouse-buttons 253 | (:use #:cl) 254 | (:export :mouse.button-id 255 | :mouse.left 256 | :mouse.middle 257 | :mouse.right 258 | :mouse.other0 259 | :mouse.other1 260 | :mouse.other2 261 | :mouse.other3 262 | :mouse.other4)) 263 | -------------------------------------------------------------------------------- /glop/keys.lisp: -------------------------------------------------------------------------------- 1 | (in-package skitter.glop.keys) 2 | 3 | (defun key.id (name) 4 | (labels ((err () (error "key.id: invalid name ~s" name))) 5 | (if (keywordp name) 6 | (or (position name skitter.glop::*key-button-names*) (err)) 7 | (err)))) 8 | 9 | (defconstant key.a 4) 10 | (defconstant key.b 5) 11 | (defconstant key.c 6) 12 | (defconstant key.d 7) 13 | (defconstant key.e 8) 14 | (defconstant key.f 9) 15 | (defconstant key.g 10) 16 | (defconstant key.h 11) 17 | (defconstant key.i 12) 18 | (defconstant key.j 13) 19 | (defconstant key.k 14) 20 | (defconstant key.l 15) 21 | (defconstant key.m 16) 22 | (defconstant key.n 17) 23 | (defconstant key.o 18) 24 | (defconstant key.p 19) 25 | (defconstant key.q 20) 26 | (defconstant key.r 21) 27 | (defconstant key.s 22) 28 | (defconstant key.t 23) 29 | (defconstant key.u 24) 30 | (defconstant key.v 25) 31 | (defconstant key.w 26) 32 | (defconstant key.x 27) 33 | (defconstant key.y 28) 34 | (defconstant key.z 29) 35 | (defconstant key.1 30) 36 | (defconstant key.2 31) 37 | (defconstant key.3 32) 38 | (defconstant key.4 33) 39 | (defconstant key.5 34) 40 | (defconstant key.6 35) 41 | (defconstant key.7 36) 42 | (defconstant key.8 37) 43 | (defconstant key.9 38) 44 | (defconstant key.0 39) 45 | (defconstant key.return 40) 46 | (defconstant key.escape 41) 47 | (defconstant key.backspace 42) 48 | (defconstant key.tab 43) 49 | (defconstant key.space 44) 50 | (defconstant key.minus 45) 51 | (defconstant key.equals 46) 52 | (defconstant key.leftbracket 47) 53 | (defconstant key.rightbracket 48) 54 | (defconstant key.backslash 49) 55 | (defconstant key.nonushash 50) 56 | (defconstant key.semicolon 51) 57 | (defconstant key.apostrophe 52) 58 | (defconstant key.grave 53) 59 | (defconstant key.comma 54) 60 | (defconstant key.period 55) 61 | (defconstant key.slash 56) 62 | (defconstant key.capslock 57) 63 | (defconstant key.f1 58) 64 | (defconstant key.f2 59) 65 | (defconstant key.f3 60) 66 | (defconstant key.f4 61) 67 | (defconstant key.f5 62) 68 | (defconstant key.f6 63) 69 | (defconstant key.f7 64) 70 | (defconstant key.f8 65) 71 | (defconstant key.f9 66) 72 | (defconstant key.f10 67) 73 | (defconstant key.f11 68) 74 | (defconstant key.f12 69) 75 | (defconstant key.printscreen 70) 76 | (defconstant key.scrolllock 71) 77 | (defconstant key.pause 72) 78 | (defconstant key.insert 73) 79 | (defconstant key.home 74) 80 | (defconstant key.pageup 75) 81 | (defconstant key.delete 76) 82 | (defconstant key.end 77) 83 | (defconstant key.pagedown 78) 84 | (defconstant key.right 79) 85 | (defconstant key.left 80) 86 | (defconstant key.down 81) 87 | (defconstant key.up 82) 88 | (defconstant key.numlockclear 83) 89 | (defconstant key.kp_divide 84) 90 | (defconstant key.kp_multiply 85) 91 | (defconstant key.kp_minus 86) 92 | (defconstant key.kp_plus 87) 93 | (defconstant key.kp_enter 88) 94 | (defconstant key.kp_1 89) 95 | (defconstant key.kp_2 90) 96 | (defconstant key.kp_3 91) 97 | (defconstant key.kp_4 92) 98 | (defconstant key.kp_5 93) 99 | (defconstant key.kp_6 94) 100 | (defconstant key.kp_7 95) 101 | (defconstant key.kp_8 96) 102 | (defconstant key.kp_9 97) 103 | (defconstant key.kp_0 98) 104 | (defconstant key.kp_period 99) 105 | (defconstant key.nonusbackslash 100) 106 | (defconstant key.application 101) 107 | (defconstant key.power 102) 108 | (defconstant key.kp_equals 103) 109 | (defconstant key.f13 104) 110 | (defconstant key.f14 105) 111 | (defconstant key.f15 106) 112 | (defconstant key.f16 107) 113 | (defconstant key.f17 108) 114 | (defconstant key.f18 109) 115 | (defconstant key.f19 110) 116 | (defconstant key.f20 111) 117 | (defconstant key.f21 112) 118 | (defconstant key.f22 113) 119 | (defconstant key.f23 114) 120 | (defconstant key.f24 115) 121 | (defconstant key.execute 116) 122 | (defconstant key.help 117) 123 | (defconstant key.menu 118) 124 | (defconstant key.select 119) 125 | (defconstant key.stop 120) 126 | (defconstant key.again 121) 127 | (defconstant key.undo 122) 128 | (defconstant key.cut 123) 129 | (defconstant key.copy 124) 130 | (defconstant key.paste 125) 131 | (defconstant key.find 126) 132 | (defconstant key.mute 127) 133 | (defconstant key.volumeup 128) 134 | (defconstant key.volumedown 129) 135 | (defconstant key.lockingcapslock 130) 136 | (defconstant key.lockingnumlock 131) 137 | (defconstant key.lockingscrolllock 132) 138 | (defconstant key.kp_comma 133) 139 | (defconstant key.kp_equalsas400 134) 140 | (defconstant key.international1 135) 141 | (defconstant key.international2 136) 142 | (defconstant key.international3 137) 143 | (defconstant key.international4 138) 144 | (defconstant key.international5 139) 145 | (defconstant key.international6 140) 146 | (defconstant key.international7 141) 147 | (defconstant key.international8 142) 148 | (defconstant key.international9 143) 149 | (defconstant key.lang1 144) 150 | (defconstant key.lang2 145) 151 | (defconstant key.lang3 146) 152 | (defconstant key.lang4 147) 153 | (defconstant key.lang5 148) 154 | (defconstant key.lang6 149) 155 | (defconstant key.lang7 150) 156 | (defconstant key.lang8 151) 157 | (defconstant key.lang9 152) 158 | (defconstant key.alterase 153) 159 | (defconstant key.sysreq 154) 160 | (defconstant key.cancel 155) 161 | (defconstant key.clear 156) 162 | (defconstant key.prior 157) 163 | (defconstant key.return2 158) 164 | (defconstant key.separator 159) 165 | (defconstant key.out 160) 166 | (defconstant key.oper 161) 167 | (defconstant key.clearagain 162) 168 | (defconstant key.crsel 163) 169 | (defconstant key.exsel 164) 170 | (defconstant key.kp_00 176) 171 | (defconstant key.kp_000 177) 172 | (defconstant key.thousandsseparator 178) 173 | (defconstant key.decimalseparator 179) 174 | (defconstant key.currencyunit 180) 175 | (defconstant key.currencysubunit 181) 176 | (defconstant key.kp_leftparen 182) 177 | (defconstant key.kp_rightparen 183) 178 | (defconstant key.kp_leftbrace 184) 179 | (defconstant key.kp_rightbrace 185) 180 | (defconstant key.kp_tab 186) 181 | (defconstant key.kp_backspace 187) 182 | (defconstant key.kp_a 188) 183 | (defconstant key.kp_b 189) 184 | (defconstant key.kp_c 190) 185 | (defconstant key.kp_d 191) 186 | (defconstant key.kp_e 192) 187 | (defconstant key.kp_f 193) 188 | (defconstant key.kp_xor 194) 189 | (defconstant key.kp_power 195) 190 | (defconstant key.kp_percent 196) 191 | (defconstant key.kp_less 197) 192 | (defconstant key.kp_greater 198) 193 | (defconstant key.kp_ampersand 199) 194 | (defconstant key.kp_dblampersand 200) 195 | (defconstant key.kp_verticalbar 201) 196 | (defconstant key.kp_dblverticalbar 202) 197 | (defconstant key.kp_colon 203) 198 | (defconstant key.kp_hash 204) 199 | (defconstant key.kp_space 205) 200 | (defconstant key.kp_at 206) 201 | (defconstant key.kp_exclam 207) 202 | (defconstant key.kp_memstore 208) 203 | (defconstant key.kp_memrecall 209) 204 | (defconstant key.kp_memclear 210) 205 | (defconstant key.kp_memadd 211) 206 | (defconstant key.kp_memsubtract 212) 207 | (defconstant key.kp_memmultiply 213) 208 | (defconstant key.kp_memdivide 214) 209 | (defconstant key.kp_plusminus 215) 210 | (defconstant key.kp_clear 216) 211 | (defconstant key.kp_clearentry 217) 212 | (defconstant key.kp_binary 218) 213 | (defconstant key.kp_octal 219) 214 | (defconstant key.kp_decimal 220) 215 | (defconstant key.kp_hexadecimal 221) 216 | (defconstant key.lctrl 224) 217 | (defconstant key.lshift 225) 218 | (defconstant key.lalt 226) 219 | (defconstant key.lgui 227) 220 | (defconstant key.rctrl 228) 221 | (defconstant key.rshift 229) 222 | (defconstant key.ralt 230) 223 | (defconstant key.rgui 231) 224 | (defconstant key.mode 257) 225 | (defconstant key.audionext 258) 226 | (defconstant key.audioprev 259) 227 | (defconstant key.audiostop 260) 228 | (defconstant key.audioplay 261) 229 | (defconstant key.audiomute 262) 230 | (defconstant key.mediaselect 263) 231 | (defconstant key.www 264) 232 | (defconstant key.mail 265) 233 | (defconstant key.calculator 266) 234 | (defconstant key.computer 267) 235 | (defconstant key.ac_search 268) 236 | (defconstant key.ac_home 269) 237 | (defconstant key.ac_back 270) 238 | (defconstant key.ac_forward 271) 239 | (defconstant key.ac_stop 272) 240 | (defconstant key.ac_refresh 273) 241 | (defconstant key.ac_bookmarks 274) 242 | (defconstant key.brightnessdown 275) 243 | (defconstant key.brightnessup 276) 244 | (defconstant key.displayswitch 277) 245 | (defconstant key.kbdillumtoggle 278) 246 | (defconstant key.kbdillumdown 279) 247 | (defconstant key.kbdillumup 280) 248 | (defconstant key.eject 281) 249 | (defconstant key.sleep 282) 250 | -------------------------------------------------------------------------------- /sdl2/keys.lisp: -------------------------------------------------------------------------------- 1 | (in-package skitter.sdl2.keys) 2 | 3 | (defun key.id (name/event) 4 | (etypecase name/event 5 | (keyword 6 | (or (position name/event skitter.sdl2::*key-button-names*) 7 | (error "key.id: invalid name ~s" name/event))) 8 | 9 | (t (error "key.id: Must be given a keyword name or an instance of the button event.~%Recieved ~s" 10 | name/event)))) 11 | 12 | (defconstant key.a 4) 13 | (defconstant key.b 5) 14 | (defconstant key.c 6) 15 | (defconstant key.d 7) 16 | (defconstant key.e 8) 17 | (defconstant key.f 9) 18 | (defconstant key.g 10) 19 | (defconstant key.h 11) 20 | (defconstant key.i 12) 21 | (defconstant key.j 13) 22 | (defconstant key.k 14) 23 | (defconstant key.l 15) 24 | (defconstant key.m 16) 25 | (defconstant key.n 17) 26 | (defconstant key.o 18) 27 | (defconstant key.p 19) 28 | (defconstant key.q 20) 29 | (defconstant key.r 21) 30 | (defconstant key.s 22) 31 | (defconstant key.t 23) 32 | (defconstant key.u 24) 33 | (defconstant key.v 25) 34 | (defconstant key.w 26) 35 | (defconstant key.x 27) 36 | (defconstant key.y 28) 37 | (defconstant key.z 29) 38 | (defconstant key.1 30) 39 | (defconstant key.2 31) 40 | (defconstant key.3 32) 41 | (defconstant key.4 33) 42 | (defconstant key.5 34) 43 | (defconstant key.6 35) 44 | (defconstant key.7 36) 45 | (defconstant key.8 37) 46 | (defconstant key.9 38) 47 | (defconstant key.0 39) 48 | (defconstant key.return 40) 49 | (defconstant key.escape 41) 50 | (defconstant key.backspace 42) 51 | (defconstant key.tab 43) 52 | (defconstant key.space 44) 53 | (defconstant key.minus 45) 54 | (defconstant key.equals 46) 55 | (defconstant key.leftbracket 47) 56 | (defconstant key.rightbracket 48) 57 | (defconstant key.backslash 49) 58 | (defconstant key.nonushash 50) 59 | (defconstant key.semicolon 51) 60 | (defconstant key.apostrophe 52) 61 | (defconstant key.grave 53) 62 | (defconstant key.comma 54) 63 | (defconstant key.period 55) 64 | (defconstant key.slash 56) 65 | (defconstant key.capslock 57) 66 | (defconstant key.f1 58) 67 | (defconstant key.f2 59) 68 | (defconstant key.f3 60) 69 | (defconstant key.f4 61) 70 | (defconstant key.f5 62) 71 | (defconstant key.f6 63) 72 | (defconstant key.f7 64) 73 | (defconstant key.f8 65) 74 | (defconstant key.f9 66) 75 | (defconstant key.f10 67) 76 | (defconstant key.f11 68) 77 | (defconstant key.f12 69) 78 | (defconstant key.printscreen 70) 79 | (defconstant key.scrolllock 71) 80 | (defconstant key.pause 72) 81 | (defconstant key.insert 73) 82 | (defconstant key.home 74) 83 | (defconstant key.pageup 75) 84 | (defconstant key.delete 76) 85 | (defconstant key.end 77) 86 | (defconstant key.pagedown 78) 87 | (defconstant key.right 79) 88 | (defconstant key.left 80) 89 | (defconstant key.down 81) 90 | (defconstant key.up 82) 91 | (defconstant key.numlockclear 83) 92 | (defconstant key.kp_divide 84) 93 | (defconstant key.kp_multiply 85) 94 | (defconstant key.kp_minus 86) 95 | (defconstant key.kp_plus 87) 96 | (defconstant key.kp_enter 88) 97 | (defconstant key.kp_1 89) 98 | (defconstant key.kp_2 90) 99 | (defconstant key.kp_3 91) 100 | (defconstant key.kp_4 92) 101 | (defconstant key.kp_5 93) 102 | (defconstant key.kp_6 94) 103 | (defconstant key.kp_7 95) 104 | (defconstant key.kp_8 96) 105 | (defconstant key.kp_9 97) 106 | (defconstant key.kp_0 98) 107 | (defconstant key.kp_period 99) 108 | (defconstant key.nonusbackslash 100) 109 | (defconstant key.application 101) 110 | (defconstant key.power 102) 111 | (defconstant key.kp_equals 103) 112 | (defconstant key.f13 104) 113 | (defconstant key.f14 105) 114 | (defconstant key.f15 106) 115 | (defconstant key.f16 107) 116 | (defconstant key.f17 108) 117 | (defconstant key.f18 109) 118 | (defconstant key.f19 110) 119 | (defconstant key.f20 111) 120 | (defconstant key.f21 112) 121 | (defconstant key.f22 113) 122 | (defconstant key.f23 114) 123 | (defconstant key.f24 115) 124 | (defconstant key.execute 116) 125 | (defconstant key.help 117) 126 | (defconstant key.menu 118) 127 | (defconstant key.select 119) 128 | (defconstant key.stop 120) 129 | (defconstant key.again 121) 130 | (defconstant key.undo 122) 131 | (defconstant key.cut 123) 132 | (defconstant key.copy 124) 133 | (defconstant key.paste 125) 134 | (defconstant key.find 126) 135 | (defconstant key.mute 127) 136 | (defconstant key.volumeup 128) 137 | (defconstant key.volumedown 129) 138 | (defconstant key.lockingcapslock 130) 139 | (defconstant key.lockingnumlock 131) 140 | (defconstant key.lockingscrolllock 132) 141 | (defconstant key.kp_comma 133) 142 | (defconstant key.kp_equalsas400 134) 143 | (defconstant key.international1 135) 144 | (defconstant key.international2 136) 145 | (defconstant key.international3 137) 146 | (defconstant key.international4 138) 147 | (defconstant key.international5 139) 148 | (defconstant key.international6 140) 149 | (defconstant key.international7 141) 150 | (defconstant key.international8 142) 151 | (defconstant key.international9 143) 152 | (defconstant key.lang1 144) 153 | (defconstant key.lang2 145) 154 | (defconstant key.lang3 146) 155 | (defconstant key.lang4 147) 156 | (defconstant key.lang5 148) 157 | (defconstant key.lang6 149) 158 | (defconstant key.lang7 150) 159 | (defconstant key.lang8 151) 160 | (defconstant key.lang9 152) 161 | (defconstant key.alterase 153) 162 | (defconstant key.sysreq 154) 163 | (defconstant key.cancel 155) 164 | (defconstant key.clear 156) 165 | (defconstant key.prior 157) 166 | (defconstant key.return2 158) 167 | (defconstant key.separator 159) 168 | (defconstant key.out 160) 169 | (defconstant key.oper 161) 170 | (defconstant key.clearagain 162) 171 | (defconstant key.crsel 163) 172 | (defconstant key.exsel 164) 173 | (defconstant key.kp_00 176) 174 | (defconstant key.kp_000 177) 175 | (defconstant key.thousandsseparator 178) 176 | (defconstant key.decimalseparator 179) 177 | (defconstant key.currencyunit 180) 178 | (defconstant key.currencysubunit 181) 179 | (defconstant key.kp_leftparen 182) 180 | (defconstant key.kp_rightparen 183) 181 | (defconstant key.kp_leftbrace 184) 182 | (defconstant key.kp_rightbrace 185) 183 | (defconstant key.kp_tab 186) 184 | (defconstant key.kp_backspace 187) 185 | (defconstant key.kp_a 188) 186 | (defconstant key.kp_b 189) 187 | (defconstant key.kp_c 190) 188 | (defconstant key.kp_d 191) 189 | (defconstant key.kp_e 192) 190 | (defconstant key.kp_f 193) 191 | (defconstant key.kp_xor 194) 192 | (defconstant key.kp_power 195) 193 | (defconstant key.kp_percent 196) 194 | (defconstant key.kp_less 197) 195 | (defconstant key.kp_greater 198) 196 | (defconstant key.kp_ampersand 199) 197 | (defconstant key.kp_dblampersand 200) 198 | (defconstant key.kp_verticalbar 201) 199 | (defconstant key.kp_dblverticalbar 202) 200 | (defconstant key.kp_colon 203) 201 | (defconstant key.kp_hash 204) 202 | (defconstant key.kp_space 205) 203 | (defconstant key.kp_at 206) 204 | (defconstant key.kp_exclam 207) 205 | (defconstant key.kp_memstore 208) 206 | (defconstant key.kp_memrecall 209) 207 | (defconstant key.kp_memclear 210) 208 | (defconstant key.kp_memadd 211) 209 | (defconstant key.kp_memsubtract 212) 210 | (defconstant key.kp_memmultiply 213) 211 | (defconstant key.kp_memdivide 214) 212 | (defconstant key.kp_plusminus 215) 213 | (defconstant key.kp_clear 216) 214 | (defconstant key.kp_clearentry 217) 215 | (defconstant key.kp_binary 218) 216 | (defconstant key.kp_octal 219) 217 | (defconstant key.kp_decimal 220) 218 | (defconstant key.kp_hexadecimal 221) 219 | (defconstant key.lctrl 224) 220 | (defconstant key.lshift 225) 221 | (defconstant key.lalt 226) 222 | (defconstant key.lgui 227) 223 | (defconstant key.rctrl 228) 224 | (defconstant key.rshift 229) 225 | (defconstant key.ralt 230) 226 | (defconstant key.rgui 231) 227 | (defconstant key.mode 257) 228 | (defconstant key.audionext 258) 229 | (defconstant key.audioprev 259) 230 | (defconstant key.audiostop 260) 231 | (defconstant key.audioplay 261) 232 | (defconstant key.audiomute 262) 233 | (defconstant key.mediaselect 263) 234 | (defconstant key.www 264) 235 | (defconstant key.mail 265) 236 | (defconstant key.calculator 266) 237 | (defconstant key.computer 267) 238 | (defconstant key.ac_search 268) 239 | (defconstant key.ac_home 269) 240 | (defconstant key.ac_back 270) 241 | (defconstant key.ac_forward 271) 242 | (defconstant key.ac_stop 272) 243 | (defconstant key.ac_refresh 273) 244 | (defconstant key.ac_bookmarks 274) 245 | (defconstant key.brightnessdown 275) 246 | (defconstant key.brightnessup 276) 247 | (defconstant key.displayswitch 277) 248 | (defconstant key.kbdillumtoggle 278) 249 | (defconstant key.kbdillumdown 279) 250 | (defconstant key.kbdillumup 280) 251 | (defconstant key.eject 281) 252 | (defconstant key.sleep 282) 253 | -------------------------------------------------------------------------------- /logical-control.lisp: -------------------------------------------------------------------------------- 1 | (in-package :skitter) 2 | 3 | ;;---------------------------------------------------------------------- 4 | 5 | (defun valid-control-form-p (control-form) 6 | (labels ((valid-control-arg (arg) 7 | (destructuring-bind (control-var-name control-type) arg 8 | (and (symbolp control-var-name) (symbolp control-type))))) 9 | (destructuring-bind (arg . body) control-form 10 | (declare (ignore body)) 11 | (valid-control-arg arg)))) 12 | 13 | (defun gen-control-logic-func (logi-control-name 14 | internal-slot-names 15 | internal-acc-names 16 | logic-func-name 17 | control-form) 18 | 19 | (destructuring-bind (arg . body) control-form 20 | (destructuring-bind (var-name control-type) arg 21 | (declare (ignorable control-type)) 22 | (let* ((this (gensym "THIS")) 23 | (listener (gensym "LISTENER"))) 24 | `(defun ,logic-func-name 25 | (,var-name ,listener input-source index timestamp tpref) 26 | (declare (ignorable ,var-name tpref timestamp)) 27 | (let ((,this (event-listener-subject ,listener))) 28 | (labels ((fire (new-val &optional tpref) 29 | (setf (,(control-data-acc-name logi-control-name) 30 | ,this) 31 | new-val) 32 | (propagate new-val ,this input-source index timestamp 33 | tpref))) 34 | (symbol-macrolet 35 | (,@(mapcar (lambda (n a) `(,n (,a ,this))) 36 | internal-slot-names 37 | internal-acc-names)) 38 | (locally 39 | (declare (optimize (speed 1) (debug 1) (space 1) 40 | (safety 1) (compilation-speed 1))) 41 | ,@body 42 | (values)))))))))) 43 | 44 | (defmacro define-logical-control 45 | ((name &key (type 'boolean) (initform nil) decays) internal-slots 46 | &body control-forms) 47 | (assert control-forms () "SKITTER: ~a must have at least one control form" 48 | name) 49 | (assert (every #'valid-control-form-p control-forms)) 50 | (let* ((p (symbol-package name)) 51 | ;; funcs 52 | (add (symb p "ADD-" name)) 53 | (constructor (symb p "%MAKE-" name)) 54 | 55 | ;; control slots 56 | (control-arg-forms (mapcar #'first control-forms)) 57 | (control-slot-names (loop :for i :below (length control-arg-forms) 58 | :collect (intern-hidden name "-CONTROL-" i))) 59 | (logic-func-names (loop :for name :in control-slot-names 60 | :collect (intern-hidden name "-LOGIC" ))) 61 | (control-types (mapcar #'second control-arg-forms)) 62 | (add-arg-names (mapcar #'caar control-forms)) 63 | ;; state-slots 64 | (internal-slot-names (mapcar #'first internal-slots)) 65 | (internal-acc-names (mapcar (lambda (x) (symb p name "-" x)) 66 | internal-slot-names))) 67 | `(progn 68 | (deftclass (,name (:conc-name nil) 69 | (:constructor ,constructor)) 70 | ;; the state for this control 71 | (,(control-hidden-data-name name) ,initform :type ,type) 72 | ;; state decay logic 73 | (,(control-decay-name name) ,decays :type boolean) 74 | (,(control-last-frame-name name) 0 :type (unsigned-byte 16)) 75 | ;; the details for things listening to this control 76 | (,(control-container-slot-name name) :unknown-slot :type symbol) 77 | (,(control-container-index-name name) -1 :type fixnum) 78 | (,(control-listeners-name name) 79 | (make-array 0 :element-type 'event-listener :adjustable t 80 | :fill-pointer 0) 81 | :type (array event-listener (*))) 82 | ;; the internal state for this control. Usable by the user defined 83 | ;; code, but doesnt get passed anywhere implicitly 84 | ,@(mapcar (lambda (n s) 85 | (destructuring-bind (_ init type) s 86 | (declare (ignore _)) 87 | `(,n ,init :type ,type))) 88 | internal-acc-names 89 | internal-slots) 90 | ;; 91 | ,@(mapcar (lambda (slot-name slot-type) 92 | `(,slot-name nil :type (or null ,slot-type))) 93 | control-slot-names 94 | control-types)) 95 | ;; set & get the for the data 96 | (declaim (type (function (,name (unsigned-byte 16)) ,type) 97 | ,(control-data-acc-name name)) 98 | (inline ,(control-data-acc-name name))) 99 | (defun ,(control-data-acc-name name) (control) 100 | (declare (optimize (speed 3) (safety 1) (debug 0)) 101 | (inline frame-id ,(control-decay-name name) 102 | ,(control-last-frame-name name) 103 | ,(control-hidden-data-name name)) 104 | (type ,name control)) 105 | (let ((frame-id (frame-id))) 106 | (if (and (,(control-decay-name name) control) 107 | (/= (the (unsigned-byte 16) (,(control-last-frame-name name) control)) 108 | frame-id)) 109 | (progn 110 | (setf (,(control-last-frame-name name) control) frame-id) 111 | (setf (,(control-hidden-data-name name) control) ,initform)) 112 | (,(control-hidden-data-name name) control)))) 113 | (defun (setf ,(control-data-acc-name name)) (value control) 114 | (declare (optimize (speed 3) (safety 1) (debug 0)) 115 | (inline frame-id ,(control-last-frame-name name) 116 | ,(control-hidden-data-name name)) 117 | (type ,name control) 118 | (type ,type value)) 119 | (let ((frame-id (frame-id))) 120 | (setf (,(control-last-frame-name name) control) frame-id) 121 | (setf (,(control-hidden-data-name name) control) value))) 122 | 123 | (defun ,add (input-source &key ,@add-arg-names) 124 | (let ((result (,constructor)) 125 | ,@(loop :for arg-name :in add-arg-names :append 126 | `((,arg-name (if (listp ,arg-name) 127 | ,arg-name 128 | (list ,arg-name)))))) 129 | ,@(loop :for control-slot-name :in control-slot-names 130 | :for control-type :in control-types 131 | :for arg-name :in add-arg-names 132 | :for func :in logic-func-names :append 133 | `((assert (typep (get-control input-source 134 | (first ,arg-name) 135 | (second ,arg-name)) 136 | ',control-type)) 137 | (setf (,control-slot-name result) 138 | (listen-to (%make-event-listener 139 | :callback #',func 140 | :subject ,arg-name) 141 | input-source 142 | (first ,arg-name) 143 | (second ,arg-name))))) 144 | result)) 145 | ,@(loop :for form :in control-forms :for func-name :in logic-func-names 146 | :collect (gen-control-logic-func 147 | name 148 | internal-slot-names 149 | internal-acc-names 150 | func-name 151 | form)) 152 | (defmethod remove-control ((control ,name)) 153 | ;; remove this logical-control from the things it was listening to and 154 | ;; free all the slots, just in case someone holds onto anything 155 | ,@(loop :for s :in control-slot-names :append 156 | `((stop-listening (,s control)) 157 | (setf (,s control) nil))) 158 | ;; remove anything it was listening to 159 | (setf (,(control-listeners-name name) control) 160 | (make-array 0 :element-type 'event-listener :adjustable t 161 | :fill-pointer 0))) 162 | (defmethod control-listeners ((control ,name)) 163 | (,(control-listeners-name name) control))))) 164 | 165 | 166 | ;; (define-logical-control (double-click :decays t) 167 | ;; ((last-press nil integer)) 168 | ;; ((button boolean-control) 169 | ;; (when (< (- timestamp last-press) 10) 170 | ;; (fire t)) 171 | ;; (setf last-press timestamp))) 172 | -------------------------------------------------------------------------------- /input-source.lisp: -------------------------------------------------------------------------------- 1 | (in-package :skitter) 2 | 3 | (defgeneric initialize-kind (obj)) 4 | 5 | (defgeneric get-control 6 | (input-source &optional slot-name index allow-arr-result)) 7 | 8 | (defun isource-array-slot-p (slot) 9 | (or (string= :* (third slot)) 10 | (numberp (third slot)))) 11 | 12 | ;;---------------------------------------------------------------------- 13 | 14 | (defun gen-populate-control (control-type 15 | hidden-slot-name 16 | length 17 | original-slot-name) 18 | ;; {TODO} needs better explanation 19 | "gens nil when there is a length as then you add the event controls using 20 | the add methods" 21 | (when (not length) 22 | `(set-control-slots 23 | ,control-type 24 | (,hidden-slot-name result) 25 | ',original-slot-name 26 | -1))) 27 | 28 | (defun gen-add-methods (name 29 | types 30 | hidden-slot-names 31 | lengths 32 | original-slot-names) 33 | "This is a partner in crimer to #'gen-populate-control in that we 34 | on need add methods when there is a length" 35 | (denil 36 | (loop :for type :in types 37 | :for hidden-slot-name :in hidden-slot-names 38 | :for length :in lengths 39 | :for original-slot-name :in original-slot-names 40 | :when length :collect 41 | (when length 42 | (let ((push (if (numberp length) 43 | 'vector-push 44 | 'vector-push-extend))) 45 | `(defmethod add ((inst ,name) (control ,type)) 46 | (let ((arr (,hidden-slot-name inst))) 47 | (,push control arr) 48 | (set-control-slots ,type 49 | control 50 | ',original-slot-name 51 | (position control arr))))))))) 52 | 53 | (defun gen-input-source-slot-getter (original-slot-name 54 | hidden-slot 55 | control-type) 56 | (if (isource-array-slot-p hidden-slot) 57 | `(defun ,original-slot-name (input-source index) 58 | (ensure-n-long (,(first hidden-slot) input-source) 59 | (+ index 1) 60 | (,(control-constructor-name control-type))) 61 | (,(control-data-acc-name control-type) 62 | (aref (,(first hidden-slot) input-source) index))) 63 | `(defun ,original-slot-name (input-source) 64 | (,(control-data-acc-name control-type) 65 | (,(first hidden-slot) input-source))))) 66 | 67 | (defun gen-input-source-slot-setter (original-slot-name 68 | hidden-slot 69 | control-type) 70 | (let* ((p (symbol-package original-slot-name)) 71 | (func-name (symb p "SET-" original-slot-name))) 72 | (if (isource-array-slot-p hidden-slot) 73 | `(defun ,func-name (input-source index timestamp data &optional tpref) 74 | ;; {TODO} I still dont like this being in the aref 75 | (ensure-n-long 76 | (,(first hidden-slot) input-source) 77 | (+ index 1) 78 | (,(control-constructor-name control-type))) 79 | (let* ((control (aref (,(first hidden-slot) input-source) 80 | index))) 81 | (setf (,(control-data-acc-name control-type) control) 82 | data) 83 | (propagate data control input-source index timestamp tpref) 84 | data)) 85 | `(defun ,func-name (input-source timestamp data &optional tpref) 86 | (let* ((control (,(first hidden-slot) input-source))) 87 | (setf (,(control-data-acc-name control-type) control) 88 | data) 89 | (propagate data control input-source -1 timestamp tpref) 90 | data))))) 91 | 92 | (defun gen-struct-slot-from-input-source-slot (s) 93 | (let* ((name (first s)) 94 | (array? (isource-array-slot-p s)) 95 | (elem-type (when array? (second s))) 96 | (len (when array? (third s))) 97 | (type (if array? 98 | `(array ,elem-type (,len)) 99 | (second s))) 100 | (init (if array? 101 | (if (numberp len) 102 | `(make-array ,len :element-type ',elem-type 103 | :fill-pointer 0) 104 | `(make-array 0 :element-type ',elem-type 105 | :adjustable t :fill-pointer 0)) 106 | `(,(intern (format nil "MAKE-~a" type) 107 | (symbol-package type)))))) 108 | `(,name ,init :type ,type))) 109 | 110 | (defun gen-input-source-slot-name (type-name user-slot-name) 111 | (symb (symbol-package type-name) type-name :- user-slot-name)) 112 | 113 | (defun input-source-hidden-constructor-name (type-name) 114 | (intern-hidden "%MAKE-~a" type-name)) 115 | 116 | (defun input-source-constructor-name (type-name) 117 | (intern (format nil "MAKE-~a" type-name) (symbol-package type-name))) 118 | 119 | (defmacro define-input-source (name (&key static) &body slots) 120 | (let* ((original-slot-names (mapcar (lambda (x) (gen-input-source-slot-name 121 | name x)) 122 | (mapcar #'first slots))) 123 | (types (mapcar #'second slots)) 124 | (lengths (mapcar #'third slots)) 125 | ;; 126 | (hidden-slot-names (mapcar #'hide original-slot-names)) 127 | (hidden-slots (mapcar #'cons hidden-slot-names (mapcar #'rest slots))) 128 | ;; 129 | (constructor (input-source-hidden-constructor-name name)) 130 | (def (if static 'defstruct 'deftclass))) 131 | `(progn 132 | ;; Type 133 | (,def (,name (:constructor ,constructor) 134 | (:conc-name nil)) 135 | ,@(mapcar #'gen-struct-slot-from-input-source-slot hidden-slots)) 136 | 137 | (defmethod print-object ((obj ,name) stream) 138 | (print-unreadable-object (obj stream :type t :identity t))) 139 | 140 | ;; public constructor 141 | (defun ,(input-source-constructor-name name) () 142 | (let ((result (,constructor))) 143 | ,@(denil 144 | (mapcar #'gen-populate-control 145 | types 146 | hidden-slot-names 147 | lengths 148 | original-slot-names)) 149 | (initialize-kind result) 150 | result)) 151 | 152 | ;; - Internal - 153 | ;; Exists so backends can hook onto this event and populate the device 154 | ;; elements. E.g. adding whatever keys or buttons the backend supports 155 | (defmethod initialize-kind ((obj ,name)) 156 | obj) 157 | 158 | ;; 159 | ,@(denil 160 | (mapcar #'gen-input-source-slot-getter 161 | original-slot-names 162 | hidden-slots 163 | types)) 164 | ,@(denil 165 | (mapcar #'gen-input-source-slot-setter 166 | original-slot-names 167 | hidden-slots 168 | types)) 169 | 170 | ,@(gen-add-methods name types hidden-slot-names lengths 171 | original-slot-names) 172 | 173 | (defmethod get-control ((input-source ,name) 174 | &optional slot-name index allow-arr-result) 175 | (declare (ignorable allow-arr-result)) 176 | (ecase slot-name 177 | ,@(loop :for (cname type length) :in slots 178 | :for slot-name :in hidden-slot-names :collect 179 | (let ((kwd (intern (symbol-name cname) :keyword)) 180 | (msg0 (format nil "SKITTER: ~a in ~a is a array of ~a" 181 | cname name type)) 182 | (msg1 (format nil "SKITTER: ~a in ~a is not an array of controls. No index is required" 183 | cname name))) 184 | (if length 185 | `(,kwd 186 | (cond 187 | (index (aref (,slot-name input-source) index)) 188 | (allow-arr-result (,slot-name input-source)) 189 | (t (error ,msg0)))) 190 | `(,kwd 191 | (assert (null index) () ,msg1) 192 | (,slot-name input-source))))))) 193 | 194 | (defmethod listen-to ((listener event-listener) (input-source ,name) 195 | slot-name &optional index) 196 | (let ((control/s (get-control input-source slot-name index t))) 197 | (setf (event-listener-input-source-type listener) 198 | (type-of input-source)) 199 | (if (arrayp control/s) 200 | (loop :for control :across control/s :do 201 | (listen-to-control control listener)) 202 | (listen-to-control control/s listener)) 203 | listener))))) 204 | 205 | ;;---------------------------------------------------------------------- 206 | -------------------------------------------------------------------------------- /sdl2/sdl2.lisp: -------------------------------------------------------------------------------- 1 | (in-package :skitter.sdl2) 2 | 3 | ;;-------------------------------------------- 4 | ;; scancode lookup 5 | 6 | (defvar *window-event-names* 7 | #(:none :shown :hidden :exposed :moved :resized 8 | :size-changed :minimized :maximized :restored 9 | :enter :leave :focus-gained :focus-lost :close 10 | :take-focus :hit-test)) 11 | 12 | (defvar *mouse-button-names* 13 | #(:0 :left :middle :right :other0 :other1 :other2 :other3 :other4)) 14 | 15 | (defvar *key-button-names* 16 | #(:unknown nil nil nil :a :b 17 | :c :d :e :f 18 | :g :h :i :j 19 | :k :l :m :n 20 | :o :p :q :r 21 | :s :t :u :v 22 | :w :x :y :z 23 | :1 :2 :3 :4 24 | :5 :6 :7 :8 25 | :9 :0 :return :escape 26 | :backspace :tab :space 27 | :minus :equals :leftbracket 28 | :rightbracket :backslash :nonushash 29 | :semicolon :apostrophe :grave 30 | :comma :period :slash 31 | :capslock :f1 :f2 :f3 32 | :f4 :f5 :f6 :f7 33 | :f8 :f9 :f10 :f11 34 | :f12 :printscreen :scrolllock 35 | :pause :insert :home 36 | :pageup :delete :end 37 | :pagedown :right :left 38 | :down :up :numlockclear 39 | :kp_divide :kp_multiply :kp_minus 40 | :kp_plus :kp_enter :kp_1 41 | :kp_2 :kp_3 :kp_4 :kp_5 42 | :kp_6 :kp_7 :kp_8 :kp_9 43 | :kp_0 :kp_period :nonusbackslash 44 | :application :power :kp_equals 45 | :f13 :f14 :f15 :f16 46 | :f17 :f18 :f19 :f20 47 | :f21 :f22 :f23 :f24 48 | :execute :help :menu 49 | :select :stop :again 50 | :undo :cut :copy :paste 51 | :find :mute :volumeup 52 | :volumedown :lockingcapslock 53 | :lockingnumlock :lockingscrolllock 54 | :kp_comma :kp_equalsas400 55 | :international1 :international2 56 | :international3 :international4 57 | :international5 :international6 58 | :international7 :international8 59 | :international9 :lang1 :lang2 60 | :lang3 :lang4 :lang5 61 | :lang6 :lang7 :lang8 62 | :lang9 :alterase :sysreq 63 | :cancel :clear :prior 64 | :return2 :separator :out 65 | :oper :clearagain :crsel 66 | :exsel nil nil nil nil nil nil nil nil nil nil nil 67 | :kp_00 :kp_000 :thousandsseparator 68 | :decimalseparator :currencyunit 69 | :currencysubunit :kp_leftparen 70 | :kp_rightparen :kp_leftbrace 71 | :kp_rightbrace :kp_tab :kp_backspace 72 | :kp_a :kp_b :kp_c :kp_d 73 | :kp_e :kp_f :kp_xor 74 | :kp_power :kp_percent :kp_less 75 | :kp_greater :kp_ampersand 76 | :kp_dblampersand :kp_verticalbar 77 | :kp_dblverticalbar :kp_colon :kp_hash 78 | :kp_space :kp_at :kp_exclam 79 | :kp_memstore :kp_memrecall 80 | :kp_memclear :kp_memadd 81 | :kp_memsubtract :kp_memmultiply 82 | :kp_memdivide :kp_plusminus :kp_clear 83 | :kp_clearentry :kp_binary :kp_octal 84 | :kp_decimal :kp_hexadecimal nil nil 85 | :lctrl :lshift :lalt 86 | :lgui :rctrl :rshift 87 | :ralt :rgui nil nil nil nil nil nil nil nil nil nil 88 | nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil 89 | :mode :audionext :audioprev 90 | :audiostop :audioplay :audiomute 91 | :mediaselect :www :mail 92 | :calculator :computer :ac_search 93 | :ac_home :ac_back :ac_forward 94 | :ac_stop :ac_refresh :ac_bookmarks 95 | :brightnessdown :brightnessup 96 | :displayswitch :kbdillumtoggle 97 | :kbdillumdown :kbdillumup :eject 98 | :sleep)) 99 | 100 | ;;-------------------------------------------- 101 | ;; sdl timestamp conversion 102 | 103 | ;; {TODO} optimize 104 | (let ((sdl->lisp-time-offset 0)) 105 | (defun set-sdl->lisp-time-offset () 106 | (setf sdl->lisp-time-offset (cl:- (get-internal-real-time) (sdl2::get-ticks)))) 107 | (defun sdl->lisp-time (sdl-time) 108 | (when (= sdl->lisp-time-offset 0) 109 | (set-sdl->lisp-time-offset)) 110 | (cl:+ sdl-time sdl->lisp-time-offset)) 111 | (defun lisp->sdl-time (lisp-time) 112 | (when (= sdl->lisp-time-offset 0) 113 | (set-sdl->lisp-time-offset)) 114 | (cl:- lisp-time sdl->lisp-time-offset))) 115 | 116 | ;;-------------------------------------------- 117 | ;; sdl event helpers 118 | 119 | (defmacro %case-event ((event) &body event-handlers) 120 | (assert (symbolp event)) 121 | `(case (sdl2::get-event-type ,event) 122 | ,@(loop :for (type params . forms) :in event-handlers 123 | :append (let ((type (if (listp type) 124 | type 125 | (list type)))) 126 | (loop :for typ :in type :collect 127 | (sdl2::expand-handler event typ params forms))) 128 | :into results 129 | :finally (return (remove nil results))))) 130 | 131 | ;; 2d axis can go down to -32768 but 1d axis can only go up to 32767 132 | (defconstant +axis-norm-factor-2d+ #.(/ 1f0 32768)) 133 | (defconstant +axis-norm-factor-1d+ #.(/ 1f0 32767)) 134 | 135 | (defun on-event (event &optional tpref) 136 | (%case-event (event) 137 | (:quit 138 | (:timestamp ts) 139 | (set-window-manager-quitting +window-manager+ (sdl->lisp-time ts) t tpref)) 140 | 141 | (:windowevent 142 | (:timestamp ts :event e :data1 x :data2 y) 143 | (let ((action (aref *window-event-names* e)) 144 | (ts (sdl->lisp-time ts)) 145 | (win (window 0))) 146 | (case action 147 | (:moved (set-window-pos win ts (v!int x y) tpref)) 148 | (:resized (set-window-size win ts (v!uint x y) tpref)) 149 | (:size-changed (set-window-size win ts (v!uint x y) tpref)) 150 | (:minimized (set-window-layout win ts :minimized tpref)) 151 | (:maximized (set-window-layout win ts :maximized tpref)) 152 | (:restored (set-window-layout win ts :restored tpref)) 153 | (:close (set-window-layout win ts t tpref))))) 154 | 155 | (:mousewheel 156 | (:timestamp ts :which id :x x :y y) 157 | (let ((mouse (mouse id))) 158 | (set-mouse-wheel mouse (sdl->lisp-time ts) (v! x y) tpref))) 159 | 160 | ((:mousebuttondown :mousebuttonup) 161 | (:timestamp ts :which id :button b :state s :x x :y y) 162 | ;; what should we do with clicks? (:clicks c) 163 | (let ((mouse (mouse id))) 164 | (set-mouse-button mouse b (sdl->lisp-time ts) (= 1 s) tpref) 165 | (set-mouse-pos mouse (sdl->lisp-time ts) (v! x y) tpref))) 166 | 167 | (:mousemotion 168 | (:timestamp ts :which id :x x :y y :xrel xrel :yrel yrel) 169 | ;; what should we do with state? (:state s) 170 | (let ((mouse (mouse id))) 171 | (set-mouse-pos mouse (sdl->lisp-time ts) (v! x y) tpref) 172 | (set-mouse-move mouse (sdl->lisp-time ts) (v! xrel yrel) tpref))) 173 | 174 | ((:keydown :keyup) 175 | (:timestamp ts :state s :keysym keysym) 176 | ;; what should we do with repeat (:repeat r) 177 | (let ((kbd (keyboard 0))) 178 | (set-keyboard-button 179 | kbd 180 | (plus-c:c-ref keysym sdl2-ffi:sdl-keysym :scancode) 181 | (sdl->lisp-time ts) 182 | (= 1 s) 183 | tpref))) 184 | ((:controlleraxismotion) 185 | (:timestamp ts :which id :axis axis :value value) 186 | (let ((ts (sdl->lisp-time ts)) 187 | (gpad (gamepad id))) 188 | (cond 189 | ((= axis sdl2-ffi:+sdl-controller-axis-leftx+) 190 | (let ((curr (gamepad-2d gpad 0)) 191 | (val (* (float value 0f0) +axis-norm-factor-2d+))) 192 | (set-gamepad-2d gpad 0 ts (v2:make val (y curr)) tpref))) 193 | ((= axis sdl2-ffi:+sdl-controller-axis-lefty+) 194 | (let ((curr (gamepad-2d gpad 0)) 195 | (val (* (float value 0f0) +axis-norm-factor-2d+))) 196 | (set-gamepad-2d gpad 0 ts (v2:make (x curr) (- val)) tpref))) 197 | 198 | ((= axis sdl2-ffi:+sdl-controller-axis-rightx+) 199 | (let ((curr (gamepad-2d gpad 0)) 200 | (val (* (float value 0f0) +axis-norm-factor-2d+))) 201 | (set-gamepad-2d gpad 1 ts (v2:make val (y curr)) tpref))) 202 | ((= axis sdl2-ffi:+sdl-controller-axis-righty+) 203 | (let ((curr (gamepad-2d gpad 0)) 204 | (val (* (float value 0f0) +axis-norm-factor-2d+))) 205 | (set-gamepad-2d gpad 1 ts (v2:make (x curr) (- val)) tpref))) 206 | 207 | ((= axis sdl2-ffi:+sdl-controller-axis-triggerleft+) 208 | (let ((val (* (float value 0f0) +axis-norm-factor-1d+))) 209 | (set-gamepad-1d gpad 0 ts val tpref))) 210 | ((= axis sdl2-ffi:+sdl-controller-axis-triggerright+) 211 | (let ((val (* (float value 0f0) +axis-norm-factor-1d+))) 212 | (set-gamepad-1d gpad 1 ts val tpref))) 213 | ;; ((= axis sdl2-ffi:+sdl-controller-axis-max+)) 214 | ;; ((= axis sdl2-ffi:+sdl-controller-axis-invalid+)) 215 | ))) 216 | ((:controllerbuttondown 217 | :controllerbuttonup) 218 | (:timestamp ts :which id :button b :state s) 219 | (let ((ts (sdl->lisp-time ts)) 220 | (gpad (gamepad id)) 221 | (downp (= s sdl2-ffi:+sdl-pressed+))) 222 | (set-gamepad-button gpad b ts downp tpref))) 223 | ;; ((:controllerdeviceadded 224 | ;; :controllerdeviceremoved 225 | ;; :controllerdeviceremapped) 226 | ;; () 227 | ;; (print (SDL2:GET-EVENT-TYPE EVENT))) 228 | )) 229 | 230 | (defun collect-sdl-events (win &optional tpref) 231 | (declare (ignore win)) 232 | (let ((event (sdl2:new-event))) 233 | (loop :until (= 0 (sdl2:next-event event :poll)) :do 234 | (on-event event tpref)) 235 | (sdl2:free-event event))) 236 | 237 | ;;-------------------------------------------- 238 | ;; intializing 239 | 240 | (defmethod initialize-kind :after ((kind keyboard)) 241 | (loop for nil across *key-button-names* do 242 | (add kind (make-boolean-control)))) 243 | 244 | (defmethod initialize-kind :after ((kind mouse)) 245 | (loop for nil across *mouse-button-names* do 246 | (add kind (make-boolean-control)))) 247 | 248 | (defmethod initialize-kind :after ((pad gamepad)) 249 | ;; add two 2d axis controls 250 | (add pad (make-vec2-control)) 251 | (add pad (make-vec2-control)) 252 | ;; add two 1d axis controls 253 | (add pad (make-float-control)) 254 | (add pad (make-float-control)) 255 | ;; 17 is the number of button kinds there are 256 | (loop :for i :below 17 :do 257 | (add pad (make-boolean-control)))) 258 | 259 | ;;---------------------------------------------------------------------- 260 | 261 | (defun enable-background-joystick-events () 262 | (cffi:with-foreign-string (on "1") 263 | (sdl2-ffi.functions:sdl-set-hint 264 | sdl2-ffi:+sdl-hint-joystick-allow-background-events+ 265 | on))) 266 | --------------------------------------------------------------------------------