diff options
| -rw-r--r-- | examples/02-moving-bitmp.lisp | 33 | ||||
| -rw-r--r-- | package.lisp | 1 | ||||
| -rw-r--r-- | wheelwork.lisp | 256 |
3 files changed, 236 insertions, 54 deletions
diff --git a/examples/02-moving-bitmp.lisp b/examples/02-moving-bitmp.lisp new file mode 100644 index 0000000..e7faeac --- /dev/null +++ b/examples/02-moving-bitmp.lisp @@ -0,0 +1,33 @@ +;;; 01-bitmap-display.lisp + +(defpackage #:ww.examples/2 + (:use #:cl) + (:export #:start)) + +(in-package :ww.examples/2) + +(defclass bitmap-display (ww::application ) ()) + +(ww::defhandler move-thing + (ww::on-keydown (target code mods) + (case code + (:scancode-left (decf (ww::unit-x target) (ww::unit-width target))) + (:scancode-right (incf (ww::unit-x target) (ww::unit-width target))) + (:scancode-down (decf (ww::unit-y target) (ww::unit-height target))) + (:scancode-up (incf (ww::unit-y target) (ww::unit-height target))) + (:scancode-equals + (print mods))))) + +(defmethod ww::boot ((app bitmap-display)) + (let ((bm + (make-instance 'ww::bitmap + :texture (ww::get-asset "Fezghoul.png")))) + (ww::refocus-on bm) + (ww::set-handler bm *move-thing*) + (ww::add-unit app bm))) + + +(defun start () + (ww::start (make-instance 'bitmap-display + :scale 3.0 + :asset-root #P"~/projects/wheelwork/examples/"))) diff --git a/package.lisp b/package.lisp index 5a59057..85dce2a 100644 --- a/package.lisp +++ b/package.lisp @@ -5,6 +5,7 @@ (:nicknames #:ww) (:local-nicknames (#:mat #:3d-matrices) (#:vec #:3d-vectors)) + (:import-from #:hyperquirks #:defvarf) (:import-from #:defclass-std #:defclass/std) (:import-from #:alexandria #:when-let #:when-let* #:if-let)) diff --git a/wheelwork.lisp b/wheelwork.lisp index a66d6a6..ffa0005 100644 --- a/wheelwork.lisp +++ b/wheelwork.lisp @@ -15,7 +15,7 @@ (defmethod (setf closer-mop:slot-value-using-class) :after (newval class (unit unit) slot) (when (member (closer-mop:slot-definition-name slot) - '(scale-y scale-x rotation tx ty)) + '(x y width height rotation )) (setf (cached-model unit) nil))) (defclass/std container () @@ -48,7 +48,7 @@ order). Makes sure to remove the unit from its current container if necessary." :doc "ALIST of (EXT CLASS). EXT is a string, file estension. CLASS is a symbol, class name.") (assets :with :a :std (make-hash-table :test 'equal) :doc "maps asset names to asset instances.") - (scale :with :a :std 1.0) + (scale :with :std 1.0) (width height :with :std 800) (projection :with :a :doc "The projection matrix for the scene. Orthographic by default.") (window :with :a) @@ -97,6 +97,12 @@ order). Makes sure to remove the unit from its current container if necessary." (defun start (app &key (x :centered) (y :centered)) (sdl2:with-init (:everything) + (sdl2:gl-set-attr :context-major-version 3) + (sdl2:gl-set-attr :context-minor-version 3) + (sdl2:gl-set-attr :context-profile-mask + sdl2-ffi:+sdl-gl-context-profile-core+) + (sdl2:gl-set-attr :doublebuffer 1) + (sdl2:with-window (window :flags '(:shown :opengl) :title (application-title app) @@ -107,6 +113,7 @@ order). Makes sure to remove the unit from its current container if necessary." (sdl2:with-gl-context (ctx window) (sdl2:gl-make-current window ctx) (gl:viewport 0 0 (application-width app) (application-height app)) + (gl:enable :depth-test) (let ((*application* app)) (unwind-protect (progn @@ -125,17 +132,7 @@ order). Makes sure to remove the unit from its current container if necessary." (render thing)) (sdl2:gl-swap-window (application-window app))) -(defun eventloop (app) - (let ((next-frame-time - (get-universal-time)) - (*frame-time* - (get-universal-time))) - (sdl2:with-event-loop (:method :poll) - (:idle () - (when (<= next-frame-time (setf *frame-time* (get-universal-time))) - (setf next-frame-time (+ *frame-time* (frame-wait app))) - (render app))) - (:quit () t)))) + (defgeneric translate-by (thing dx dy)) (defgeneric rotate-by (thing radians)) @@ -214,9 +211,104 @@ order). Makes sure to remove the unit from its current container if necessary." 0 image-format :unsigned-byte - (pngload:data png))))) + (pngload:data png)) + (gl:bind-texture :texture-2d 0)))) + + +(defclass/std event-handler () + ((event-type handler-function :ri))) + +(defclass/std listener () + ((keydown keyup mousedown mouseup mousemove mousewheel focus blur perframe + :r :with :type event-handler) + (keydown-table + keyup-table + mousedown-table + mouseup-table + mousemove-table + mousewheel-table + focus-table + blur-table + perframe-table + :static + :std (make-hash-table) + :doc "Keyed by DISPLAY-UNIT instance, holds an EVENT-HANDLER if handler is defined for unit.")) + (:documentation "Event handlers per object. The static hash tables + are keyed by UNIT and hold Event-Handler instances.")) + +(defclass/std interactive-unit (unit) + ((listener :type (or null listener) :std nil :a))) + +(defun set-handler (unit handler) + (when (null (listener unit)) + (setf (listener unit) (make-instance 'listener))) + (setf + (slot-value (listener unit) (event-type handler)) handler + (gethash unit (listener-table-for (listener unit) (event-type handler))) t)) + +(defun unset-handler (unit handler-or-event-type) + "Handler can be an instance of EVENT-HANDLER or can be a symbol + whose name is an event type." + (when (listener unit) + (let ((event-type (etypecase handler-or-event-type + (keyword (intern (symbol-name handler-or-event-type))) + (symbol (intern (symbol-name handler-or-event-type))) + (event-handler (event-type handler-or-event-type))))) + (setf (slot-value (listener unit) event-type) nil) + (remhash unit (listener-table-for (listener unit) event-type))))) + +(defun listener-table-for (listener event-type) + (ecase event-type + (keydown (keydown-table listener)) + (keyup (keyup-table listener)) + (mousedown (mousewheel-table listener)) + (mouseup (mouseup-table listener)) + (mousemove (mousemove-table listener)) + (mousewheel (mousewheel-table listener)) + (focus (focus-table listener)) + (blur (blur-table listener)) + (perframe (perframe-table listener)))) + +(defun should-listen-for-p (listener event-type) + (plusp (hash-table-count (listener-table-for listener event-type)))) + +(defun refocus-on (target &optional (app *application*)) + "Handles changing application focus, calling appropriate blur and focus handlers." + (when-let (blur-handler (and (application-focus app) + (get-handler-for (application-focus app) 'blur))) + (funcall (handler-function blur-handler) (application-focus app))) + (setf (application-focus app) target) + (when-let (focus-handler (get-handler-for target 'focus)) + (funcall (handler-function focus-handler) target))) + +(defun get-focus (&optional (app *application*)) + (or (application-focus app) app)) + +(defun get-handler-for (unit event-type) + "EVENT-TYPE must be one of the slot value names for WHEELWORK::LISTENER." + (when (listener unit) + (slot-value (listener unit) event-type))) + +(defun eventloop-keydown (app sdl-keysym) + (let ((target (get-focus app))) + (format t "Calling eventloop-keydown~%") + (when-let (handler (get-handler-for target 'keydown)) + (format t "Handling the event.~%") + + (apply (handler-function handler) + target + (sdl2:scancode sdl-keysym) + (sdl2:mod-keywords (sdl2:mod-value sdl-keysym)))))) -(defclass/std bitmap (unit) +(defun eventloop (app) + (sdl2:with-event-loop (:method :poll) + (:keydown + (:keysym keysym) + (eventloop-keydown app keysym)) + (:idle () (render app)) + (:quit () t))) + +(defclass/std bitmap (interactive-unit) ((texture :ri :std (error "A bitmap requires a texture.")) (vao shader :with :r :static))) @@ -284,6 +376,8 @@ order). Makes sure to remove the unit from its current container if necessary." (define-symbol-macro +float-size+ (cffi:foreign-type-size :float)) + + (defmethod initialize-instance :after ((bitmap bitmap) &key) (with-slots (vao shader width height texture) bitmap (setf texture (ensure-loaded texture) @@ -360,42 +454,96 @@ disk." (make-instance (asset-class-for asset-id) :path (uiop:merge-pathnames* asset-id (asset-root app))))))) -;; (defun get-focus (&optional (app *application*)) -;; (or (application-focus app) -;; (display-root app))) - -;; (defun get-projection (&optional (app *application*)) -;; (application-projection app)) - -;; (defun application-width (&optional (app *application*)) -;; (multiple-value-bind (w h) (sdl2:get-window-size (application-window app)) -;; (declare (ignore h)) -;; w)) - -;; (defun application-height (&optional (app *application*)) -;; (multiple-value-bind (w h) (sdl2:get-window-size (application-window app)) -;; (declare (ignore w)) -;; h)) - - -;; (defclass/std event-handler () -;; ((event-type handler-function :ri))) - -;; (defclass/std listener () -;; ((keydown keyup mousedown mouseup mousemove mousewheel focus blur perframe -;; :r :with :type event-handler) -;; (keydown-table -;; keyup-table -;; mousedown-table -;; mouseup-table -;; mousemove-table -;; mousewheel-table -;; focus-table -;; blur-table -;; perframe-table -;; :static -;; :std (make-hash-table) -;; :doc "Keyed by DISPLAY-UNIT instance, holds an EVENT-HANDLER if handler is defined for unit.")) -;; (:documentation "Event handlers per object. The static hash tables -;; are keyed by UNIT and hold Event-Handler instances.")) - +(defmacro on-perframe + ((target time) &body body) + `(make-instance + 'event-handler + :event-type 'wheelwork::perframe + :handler-function (lambda (,target ,time) + (declare (ignorable ,target ,time)) + ,@body))) + +(defmacro on-keydown + ((target scancode modifiers) &body body) + "Creates a lambda suitable for the value of a keydown event + handler. The function accepts two positional arguments TARGET and + SCANCODE and one &REST argument MODIFIERS. + + SCANCODE will be a keyword of the form :SCANCODE-A, :SCANCODE-B ... + + The members of MODIFIERS look like :LSHIFT, :RCTRL, RALT, etc" + `(make-instance + 'event-handler + :event-type 'wheelwork::keydown + :handler-function (lambda (,target ,scancode &rest ,modifiers) + (declare (ignorable ,target ,scancode ,modifiers)) + ,@body))) + +(defmacro on-keyup ((target scancode modifiers) &body body) + "Creates a lambda suitable for the value of a keyup event + handler. The function accepts two positional arguments TARGET and + SCANCODE and one &REST argument MODIFIERS. + + SCANCODE will be a keyword of the form :SCANCODE-A, :SCANCODE-B ... + + The members of MODIFIERS look like :LSHIFT, :RCTRL, RALT, etc" + `(make-instance + 'event-handler + :event-type 'wheelwork::keyup + :handler-function (lambda (,target ,scancode &rest ,modifiers) + (declare (ignorable ,target ,scancode ,modifiers)) + ,@body))) + +(defmacro on-mousemove + ((target x y xrel yrel state) &body body) + `(make-instance + 'event-handler + :event-type 'wheelwork::mousemove + :handler-function (lambda (,target ,x ,y ,xrel ,yrel ,state) + (declare (ignorable ,target ,x ,y ,xrel ,yrel ,state)) + ,@body))) + +(defmacro on-mousedown + ((target x y clicks button) &body body) + `(make-instance + 'event-handler + :event-type 'wheelwork::mousedown + :handler-function (lambda (,target ,x ,y ,clicks ,button) + (declare (ignorable ,target ,x ,y ,clicks ,button)) + ,@body))) + +(defmacro on-mouseup + ((target x y clicks button) &body body) + `(make-instance + 'event-handler + :event-type 'wheelwork::mouseup + :handler-function (lambda (,target ,x ,y ,clicks ,button) + (declare (ignorable ,target ,x ,y ,clicks ,button)) + ,@body))) + +(defmacro on-mousewheel + ((target x y dir) &body body) + `(make-instance + 'event-handler + :event-type 'wheelwork::mousewheel + :handler-function (lambda (,target ,x ,y ,dir) + (declare (ignorable ,target ,x ,y ,dir)) + ,@body))) + +(defmacro on-blur + ((target) &body body) + `(make-instance + 'event-handler + :event-type 'wheelwork::blur + :handler-function (lambda (,target) + (declare (ignorable ,target)) + ,@body))) + +(defmacro on-focus + ((target) &body body) + `(make-instance + 'event-handler + :event-type 'wheelwork::focus + :handler-function (lambda (,target) + (declare (ignorable ,target)) + ,@body))) |