;;;; wh-engine/input/input-system.lisp ;;;; input system main code (defpackage wh-engine/input (:nicknames whe/input) (:use common-lisp 3d-vectors 3d-matrices) (:import-from sb-ext weak-pointer weak-pointer-p make-weak-pointer weak-pointer-value) (:import-from objective-lisp O!) (:export keypress make-keypress keypress-key keypress-controlp keypress-metap keypress-shiftp keypress-superp keyspec)) (in-package wh-engine/input) (defun input-system-init () "Initialize the input system." ()) (defun input-system-update () ()) (defparameter *keyspec-parsing-table* nil) (defparameter *keycode-translation-reverse-table* nil) (defun setup-keycode-translation-table (&rest rest) (let ((table (make-hash-table :size (+ (truncate (length rest) 2) 64))) (reverse (make-hash-table)) (parsing (make-hash-table :test #'equal))) (loop for x from #x21 to #x40 do (setf (gethash x table) (code-char x) (gethash (code-char x) reverse) x)) (loop for x from #x5b to #x7a do (setf (gethash x table) (code-char x) (gethash (code-char x) reverse) x)) (loop for (k v) on rest by #'cddr do (setf (gethash k table) v) (cond ((and (consp v) (keywordp (cdr v))) (setf (gethash (format nil "K-<~A>" (cdr v)) parsing) (cdr v))) ((and (consp v) (stringp (cdr v))) (setf (gethash (format nil "K-~A" (cdr v)) parsing) (cdr v))) ((keywordp v) (setf (gethash (format nil "<~A>" v) parsing) v)) ((stringp v) (setf (gethash v parsing) v))) unless (gethash v reverse) do (setf (gethash v reverse) k)) (setf *keycode-translation-reverse-table* reverse) (setf *keyspec-parsing-table* parsing) table)) (defparameter *keycode-translation-table* (setup-keycode-translation-table #x08 :backspace #x09 :tab #x0d :return #x1b :escape #x20 :space #x7f :delete #x40000039 :caps-lock #x4000003A :f1 #x4000003B :f2 #x4000003C :f3 #x4000003D :f4 #x4000003E :f5 #x4000003F :f6 #x40000040 :f7 #x40000041 :f8 #x40000042 :f9 #x40000043 :f10 #x40000044 :f11 #x40000045 :f12 #x40000046 :print-screen #x40000047 :scroll-lock #x40000048 :pause #x40000049 :insert #x4000004A :home #x4000004B :page-up #x4000004D :end #x4000004E :page-down #x4000004F :right #x40000050 :left #x40000051 :down #x40000052 :up #x40000053 :num-lock #x40000054 '(:keypad . #\/) #x40000055 '(:keypad . #\*) #x40000056 '(:keypad . #\-) #x40000057 '(:keypad . #\+) #x40000058 '(:keypad . :return) #x40000059 '(:keypad . #\1) #x4000005A '(:keypad . #\2) #x4000005B '(:keypad . #\3) #x4000005C '(:keypad . #\4) #x4000005D '(:keypad . #\5) #x4000005E '(:keypad . #\6) #x4000005F '(:keypad . #\7) #x40000060 '(:keypad . #\8) #x40000061 '(:keypad . #\9) #x40000062 '(:keypad . #\0) #x40000063 '(:keypad . #\.) #x40000065 :application #x40000066 :power #x40000067 '(:keypad . #\=) #x40000068 :f13 #x40000069 :f14 #x4000006A :f15 #x4000006B :f16 #x4000006C :f17 #x4000006D :f18 #x4000006E :f19 #x4000006F :f20 #x40000070 :f21 #x40000071 :f22 #x40000072 :f23 #x40000073 :f24 #x40000074 :execute #x40000075 :help #x40000076 :menu #x40000077 :select #x40000078 :stop #x40000079 :again #x4000007A :undo #x4000007B :cut #x4000007C :copy #x4000007D :paste #x4000007E :find #x4000007F :mute #x40000080 :volume+ #x40000081 :volume- #x40000085 '(:keypad . #\,) #x40000086 '(:keypad . :as400=) #x40000099 :alt-erase #x4000009A :sys-req #x4000009B :cancel #x4000009C :clear #x4000009D :prior #x4000009E :return-2 #x4000009F :separator #x400000A0 :out #x400000A1 :oper #x400000A2 :clear-again #x400000A3 :crsel #x400000A4 :exsel #x400000B0 '(:keypad "00") #x400000B1 '(:keypad "000") #x400000B2 :thousands-separator #x400000B3 :decimal-separator #x400000B4 :currency-unit #x400000B5 :currency-sub-unit #x400000B6 '(:keypad . #\() #x400000B7 '(:keypad . #\)) #x400000B8 '(:keypad . #\{) #x400000B9 '(:keypad . #\}) #x400000BA '(:keypad . :tab) #x400000BB '(:keypad . :backspace) #x400000BC '(:keypad . #\a) #x400000BD '(:keypad . #\b) #x400000BE '(:keypad . #\c) #x400000BF '(:keypad . #\d) #x400000C0 '(:keypad . #\e) #x400000C1 '(:keypad . #\f) #x400000C2 '(:keypad . :xor) #x400000C3 '(:keypad . #\^) #x400000C4 '(:keypad . #\%) #x400000C5 '(:keypad . #\<) #x400000C6 '(:keypad . #\>) #x400000C7 '(:keypad . #\&) #x400000C8 '(:keypad . "&&") #x400000C9 '(:keypad . #\|) #x400000CA '(:keypad . "||") #x400000CB '(:keypad . #\:) #x400000CC '(:keypad . #\#) #x400000CD '(:keypad . :space) #x400000CE '(:keypad . #\@) #x400000CF '(:keypad . #\!) #x400000D0 '(:keypad . :mem-store) #x400000D1 '(:keypad . :mem-recall) #x400000D2 '(:keypad . :mem-clear) #x400000D3 '(:keypad . :mem+) #x400000D4 '(:keypad . :mem-) #x400000D5 '(:keypad . :mem*) #x400000D6 '(:keypad . :mem/) #x400000D7 '(:keypad . #\±) #x400000D8 '(:keypad . :clear) #x400000D9 '(:keypad . :clear-entry) #x400000DA '(:keypad . :binary) #x400000DB '(:keypad . :octal) #x400000DC '(:keypad . :decimal) #x400000DD '(:keypad . :hexadecimal) ;; modifiers #x400000E0 :left-control #x400000E1 :left-shift #x400000E2 :left-meta #x400000E3 :left-super #x400000E4 :right-control #x400000E5 :right-shift #x400000E6 :right-meta #x400000E7 :right-super ;; other keys #x40000101 :mode #x40000102 :media-next #x40000103 :media-previous #x40000104 :media-stop #x40000105 :media-play #x40000106 :audio-mute #x40000107 :media-select #x40000108 :web #x40000109 :mail #x4000010A :calculator #x4000010B :computer #x4000010C :application-search #x4000010D :application-home #x4000010E :application-back #x4000010F :application-forward #x40000110 :application-stop #x40000111 :application-refresh #x40000112 :application-bookmarks #x40000113 :brightness- #x40000114 :brightness+ #x40000115 :display-switch #x40000116 :backlight #x40000117 :backlight- #x40000118 :backlight+ #x40000119 :eject #x4000011A :sleep )) (defstruct keypress (key nil :type (or symbol character cons string null)) (controlp nil :type boolean) (metap nil :type boolean) (shiftp nil :type boolean)) (defmacro keyspec (keyspec expr) "Compare EXPR to an Emacs-style KEYSPEC." (declare (type simple-string keyspec)) (let* ((keypadp nil) (ks keyspec) (invertp nil) (var (gensym)) (tests (loop while (and (> (length ks) 2) (or (char= (schar ks 1) #\-) (char= (schar ks 0) #\^))) if (char= (schar ks 0) #\K) do (setf keypadp t) (setf ks (subseq ks 2)) else if (char= (schar ks 0) #\^) do (setf invertp t) (setf ks (subseq ks 1)) else if (if invertp (case (schar ks 0) (#\C `(not (keypress-controlp ,var))) (#\M `(not (keypress-metap ,var))) (#\S `(not (keypress-shiftp ,var)))) (case (schar ks 0) (#\C `(keypress-controlp ,var)) (#\M `(keypress-metap ,var)) (#\S `(keypress-shiftp ,var)))) collect it and do (setf ks (subseq ks 2)) (setf invertp nil) else do (loop-finish))) (key (cond ((= (length ks) 0) (error "Invalid keyspec ~S" keyspec)) ((= (length ks) 1) (if (upper-case-p (schar ks 0)) (progn (push `(keypress-shiftp ,var) tests) (char-downcase (schar ks 0))) (schar ks 0))) ((string= ks "SPC") :space) ((string= ks "RET") :return) ((string= ks "TAB") :tab) ((string= ks "ESC") :escape) ((string= ks "DEL") :delete) ((string= ks "BS") :backspace) (t (gethash (if keypadp (concatenate 'string "K-" ks) ks) *keyspec-parsing-table*))))) `(let ((,var ,expr)) (and ,@tests (equal (keypress-key ,var) ,(if keypadp `(cons :keypad ,key) key)))) )) (defun translate-sdl-key-sym (key-sym) "Translate an SDL key-sym to a wh-engine keypress value." (let ((sdl-mod (sdl2:mod-value key-sym))) (make-keypress :key (gethash (sdl2:sym-value key-sym) *keycode-translation-table*) :controlp (/= (logand sdl-mod #x00C0) 0) :metap (/= (logand sdl-mod #x0300) 0) :shiftp (/= (logand sdl-mod #x0003) 0)))) (defun on-key-down (key-sym) (let ((keypress (translate-sdl-key-sym key-sym))) (format t "keyDN: ~S~%" keypress) (when (keyspec "M-x" keypress) (format t "-- Meta-x Key Detected --~%")) )) (defun on-key-up (key-sym) (let ((keypress (translate-sdl-key-sym key-sym))) (format t "keyUP: ~S~%" keypress) )) (defun on-mouse-move (mouse-location mouse-delta mouse-state) ()) ;; FIXME slow as FUCK (defun on-mouse-down (mouse-location mouse-button) (let ((view (wh-engine:deref-pointer (first wh-engine/render::*world-views*)))) (loop for drawable-ptr in wh-engine/render::*world-drawables* for drawable = (wh-engine:deref-pointer drawable-ptr) when (and (o! drawable wh-engine:active-p) (o! drawable wh-engine:actor wh-engine:tree-active-p)) do (multiple-value-bind (box-min box-max) (wh-engine/render::transform-box (o! drawable wh-engine/render:culling-box) (o! drawable wh-engine:actor wh-engine:world-matrix) (o! view wh-engine/render:view-matrix)) (if (and (v>= box-max mouse-location) (v<= box-min mouse-location)) ;; click has occured. (format t "Click on: ~S with btn: ~S~%" (o! drawable wh-engine:actor) mouse-button)) )))) (defun on-mouse-up (mouse-location mouse-button) ()) (wh-engine:register-system :wh-engine/input 'input-system-init 'input-system-update '((:keydown . on-key-down) (:keyup . on-key-up) (:mousemotion . on-mouse-move) (:mousebuttondown . on-mouse-down) (:mousebuttonup . on-mouse-up)) :dependencies '(:wh-engine/render))