329 lines
16 KiB
Common Lisp
329 lines
16 KiB
Common Lisp
;;;; 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))
|