keith/wh-engine
1
0
Fork 0
Code Issues 6 Pull requests Projects Releases Wiki Activity

some input system stuff

Browse source
This commit is contained in:
~keith 2022-02-26 20:19:04 +00:00
parent 234987a4fa
commit 04c4a13c5b
Signed by: keith
GPG key ID: 5BEBEEAB2C73D520
5 changed files with 400 additions and 21 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
run.lisp
View file

@ -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)))

1
wh-engine.asd
View file

@ -20,5 +20,6 @@
(:file "render/render-system")
(:file "render/drawable")
(:file "render/view")
(:file "input/input-system")
(:file "main"))
)))

282
wh-engine/input/input-system.lisp Normal file
View file

@ -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))

119
wh-engine/main.lisp
View file

@ -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))))
)))))

14
wh-engine/systems.lisp
View file

@ -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))))