some input system stuff
This commit is contained in:
parent
234987a4fa
commit
04c4a13c5b
GPG Key ID:
5BEBEEAB2C73D520
5
run.lisp
5
run.lisp
|
|
@ -5,3 +5,8 @@
|
|||
(asdf:load-system 'wh-engine)
|
||||
|
||||
(format t "**** wh-engine READY! ****~%")
|
||||
|
||||
(defun run-test ()
|
||||
(wh-engine:install-systems :wh-engine/input)
|
||||
(wh-engine:register-test-scene)
|
||||
(eval '(wh-engine:run)))
|
||||
|
|
|
|||
|
|
@ -20,5 +20,6 @@
|
|||
(:file "render/render-system")
|
||||
(:file "render/drawable")
|
||||
(:file "render/view")
|
||||
(:file "input/input-system")
|
||||
(:file "main"))
|
||||
)))
|
||||
|
|
|
|||
|
|
@ -0,0 +1,282 @@
|
|||
;;;; 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))
|
||||
|
||||
(in-package wh-engine/input)
|
||||
|
||||
(defun input-system-init ()
|
||||
"Initialize the input system."
|
||||
())
|
||||
|
||||
(defun input-system-update ()
|
||||
())
|
||||
#|
|
||||
(defmacro setup-keycode-translation-table (&rest rest)
|
||||
(let ((table (gensym)))
|
||||
`(let ((,table (make-hash-table)))
|
||||
(setf ,@(loop for x from #x21 to #x40
|
||||
nconc `((gethash ,x ,table) ,(code-char x)))
|
||||
,@(loop for x from #x5b to #x7a
|
||||
nconc `((gethash ,x ,table) ,(code-char x)))
|
||||
,@(loop for (k v) on rest by #'cddr
|
||||
nconc `((gethash ,k ,table) ,v)))
|
||||
,table)))
|
||||
|#
|
||||
(defvar *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 :size (+ (truncate (length rest) 2) 64))))
|
||||
(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)
|
||||
unless (gethash v reverse)
|
||||
do (setf (gethash v reverse) k))
|
||||
(setf *keycode-translation-reverse-table* reverse)
|
||||
table))
|
||||
(defvar *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
|
||||
))
|
||||
|
||||
(defun parse-keyspec (keyspec)
|
||||
"Parse an Emacs-style key specification."
|
||||
(declare (type simple-string keyspec))
|
||||
;; 'C-': control, 'M-': meta, 'S-': shift, 'X-': super, 'K-': keypad
|
||||
(let* ((keypad-p nil)
|
||||
(ks keyspec)
|
||||
(modifiers (loop while (and (> (length ks) 2) (char= (schar ks 1) #\-))
|
||||
if (char= (schar ks 0) #\K)
|
||||
do (setf keypad-p t)
|
||||
(setf ks (subseq ks 2))
|
||||
else
|
||||
if (case (schar ks 0)
|
||||
(#\C :control)
|
||||
(#\M :meta)
|
||||
(#\S :shift)
|
||||
(#\X :super))
|
||||
collect it
|
||||
and do (setf ks (subseq ks 2))
|
||||
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 (setf modifiers (cons :shift modifiers))
|
||||
(char-downcase (schar ks 0)))
|
||||
(schar ks 0)))
|
||||
((string= ks "SPC") :space)
|
||||
((string= ks "RET") :return)
|
||||
((string= ks "ESC") :escape)
|
||||
((string= ks "DEL") :delete)
|
||||
((string= ks "BS") :backspace)
|
||||
(t (read-from-string ks)))
|
||||
))
|
||||
(values (if keypad-p `(:keypad ,key) key) modifiers)))
|
||||
|
||||
(defun on-key-down (key-sym)
|
||||
(format t "key-down: ~S (mod ~S)~%"
|
||||
(gethash (sdl2:sym-value key-sym) *keycode-translation-table*)
|
||||
(sdl2:mod-keywords (sdl2:mod-value key-sym))))
|
||||
|
||||
(defun on-key-up (key-sym)
|
||||
())
|
||||
|
||||
(defun on-mouse-move (mouse-location mouse-delta mouse-state)
|
||||
())
|
||||
|
||||
(defun on-mouse-down (mouse-location 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))
|
||||
|
|
@ -71,21 +71,106 @@
|
|||
|
||||
(sdl2:with-event-loop (:method :poll)
|
||||
(:quit () t)
|
||||
(:idle ()
|
||||
(setf prev-profiling-tick (sdl2:get-performance-counter))
|
||||
;; calculate delta-time
|
||||
(setf this-tick (sdl2:get-ticks))
|
||||
(setf *delta-time* (* (- this-tick prev-tick) 0.001))
|
||||
(setf prev-tick this-tick)
|
||||
(format t "~%Δt = ~S (~S FPS)~%" *delta-time* (/ 1.0 *delta-time*))
|
||||
;; update
|
||||
(loop for scene in *world*
|
||||
do (o! scene (update)))
|
||||
(format t "game=~S " (/ (- (sdl2:get-performance-counter) prev-profiling-tick) profiling-scale))
|
||||
,@(loop for system in *world-systems*
|
||||
append `((,(third system))
|
||||
(format t ,(format nil "~S~A" (first system) "=~S ")
|
||||
(/ (- (sdl2:get-performance-counter) prev-profiling-tick) profiling-scale))
|
||||
))
|
||||
(sdl2:gl-swap-window win)))
|
||||
(:idle
|
||||
()
|
||||
|
||||
(setf prev-profiling-tick (sdl2:get-performance-counter))
|
||||
;; calculate delta-time
|
||||
(setf this-tick (sdl2:get-ticks))
|
||||
(setf *delta-time* (* (- this-tick prev-tick) 0.001))
|
||||
(setf prev-tick this-tick)
|
||||
;(format t "~%Δt = ~S (~S FPS)~%" *delta-time* (/ 1.0 *delta-time*))
|
||||
;; update
|
||||
(loop for scene in *world*
|
||||
do (o! scene (update)))
|
||||
;(format t "game=~S " (/ (- (sdl2:get-performance-counter) prev-profiling-tick) profiling-scale))
|
||||
,@(loop for system in *world-systems*
|
||||
append `((,(third system))
|
||||
#|
|
||||
(format t ,(format nil "~S~A" (first system) "=~S ")
|
||||
(/ (- (sdl2:get-performance-counter) prev-profiling-tick) profiling-scale))
|
||||
|#
|
||||
))
|
||||
(sdl2:gl-swap-window win))
|
||||
(:keydown
|
||||
(:keysym keysym)
|
||||
|
||||
,@(loop for system in *world-systems*
|
||||
for handler = (assoc :keydown (fourth system))
|
||||
when handler
|
||||
collect `(,(cdr handler) keysym)))
|
||||
(:keyup
|
||||
(:keysym keysym)
|
||||
|
||||
,@(loop for system in *world-systems*
|
||||
for handler = (assoc :keyup (fourth system))
|
||||
when handler
|
||||
collect `(,(cdr handler) keysym)))
|
||||
(:mousemotion
|
||||
(:x mouse-x :y mouse-y :xrel delta-x :yrel delta-y :state state)
|
||||
|
||||
,@(loop for system in *world-systems*
|
||||
for handler = (assoc :mousemotion (fourth system))
|
||||
when handler
|
||||
collect `(,(cdr handler)
|
||||
(vec2 (truncate mouse-x whe/render:*pixel-scale*)
|
||||
(truncate mouse-y whe/render:*pixel-scale*))
|
||||
(vec2 (truncate delta-x whe/render:*pixel-scale*)
|
||||
(truncate delta-y whe/render:*pixel-scale*))
|
||||
state)))
|
||||
(:mousebuttondown
|
||||
(:x mouse-x :y mouse-y :button button)
|
||||
|
||||
,@(loop for system in *world-systems*
|
||||
for handler = (assoc :mousebuttondown (fourth system))
|
||||
when handler
|
||||
collect `(,(cdr handler)
|
||||
(vec2 (truncate mouse-x whe/render:*pixel-scale*)
|
||||
(truncate mouse-y whe/render:*pixel-scale*))
|
||||
button)))
|
||||
(:mousebuttonup
|
||||
(:x mouse-x :y mouse-y :button button)
|
||||
|
||||
,@(loop for system in *world-systems*
|
||||
for handler = (assoc :mousebuttonup (fourth system))
|
||||
when handler
|
||||
collect `(,(cdr handler)
|
||||
(vec2 (truncate mouse-x whe/render:*pixel-scale*)
|
||||
(truncate mouse-y whe/render:*pixel-scale*))
|
||||
button)))
|
||||
(:joyaxismotion
|
||||
(:which joy-id :axis axis :value value)
|
||||
|
||||
,@(loop for system in *world-systems*
|
||||
for handler = (assoc :joyaxismotion (fourth system))
|
||||
when handler
|
||||
collect `(,(cdr handler) joy-id axis value)))
|
||||
(:joyballmotion
|
||||
(:which joy-id :ball ball :xrel delta-x :yrel delta-y)
|
||||
|
||||
,@(loop for system in *world-systems*
|
||||
for handler = (assoc :joyballmotion (fourth system))
|
||||
when handler
|
||||
collect `(,(cdr handler) joy-id ball (vec2 delta-x delta-y))))
|
||||
(:joyhatmotion
|
||||
(:which joy-id :hat hat :value value)
|
||||
|
||||
,@(loop for system in *world-systems*
|
||||
for handler = (assoc :joyhatmotion (fourth system))
|
||||
when handler
|
||||
collect `(,(cdr handler) joy-id hat value)))
|
||||
(:joybuttondown
|
||||
(:which joy-id :button button)
|
||||
|
||||
,@(loop for system in *world-systems*
|
||||
for handler = (assoc :joybuttondown (fourth system))
|
||||
when handler
|
||||
collect `(,(cdr handler) joy-id button)))
|
||||
(:joybuttonup
|
||||
(:which joy-id :button button)
|
||||
|
||||
,@(loop for system in *world-systems*
|
||||
for handler = (assoc :joybuttonup (fourth system))
|
||||
when handler
|
||||
collect `(,(cdr handler) joy-id button))))
|
||||
)))))
|
||||
|
|
|
|||
|
|
@ -6,12 +6,18 @@
|
|||
"Alist of defined systems.")
|
||||
|
||||
(defvar *world-systems* ()
|
||||
"List of enabled systems.")
|
||||
"List of installed systems.")
|
||||
|
||||
(defun register-system (name init-fun-symbol update-fun-symbol sdl-event-rules)
|
||||
(push `(,name ,init-fun-symbol ,update-fun-symbol ,sdl-event-rules) *system-registry*))
|
||||
(defun register-system (name init-fun-symbol update-fun-symbol sdl-event-rules
|
||||
&key dependencies)
|
||||
(push `(,name ,init-fun-symbol ,update-fun-symbol
|
||||
,sdl-event-rules
|
||||
,dependencies)
|
||||
*system-registry*))
|
||||
|
||||
(defun install-systems (&rest systems)
|
||||
(loop for system-name in systems
|
||||
for system = (assoc system-name *system-registry*)
|
||||
do (push system *world-systems*)))
|
||||
do (pushnew system *world-systems*)
|
||||
;; install dependencies
|
||||
(apply #'install-systems (fifth system))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue