[fix] bad slots in cache invalidation code.

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