[modify] unit model-matrix [add] text model-matrix [add] scale funs

2 files changed, 95 insertions, 29 deletions

diff --git a/examples/03-font-render.lisp b/examples/03-font-render.lisp
index a854843..3a3d659 100644
--- a/examples/03-font-render.lisp
+++ b/examples/03-font-render.lisp
@@ -15,37 +15,45 @@
     (ww::on-keydown ()
       "Press any key to change the color of the text"
       (format t "Pressed a key, changing the color~%")
-      (setf (ww::text-color target) (random-text-color))))
+      (setf (ww::text-color target) (random-text-color))
+
+      (with-accessors ((x ww::unit-x) (y ww::unit-y) (w ww::unit-width) (h ww::unit-height)) target 
+        (format t "x:~a,y:~a,width:~a,height:~a~%" x y w h))))
 
 (ww::defhandler marquee
     (ww::on-perframe ()
       (when (< 900 (ww::unit-x target))
         (setf (ww::unit-x target)
               -800))
-      (incf (ww::unit-x target) 5)))
+      ;(incf (ww::unit-x target) 5)
+      ))
 
 (defmethod ww::boot ((app font-display))
   (let ((hello
           (make-instance
            'ww::text
+           ;:content "Yom"
            :content "Hell! Oh World..."
            :font (ww::get-asset "Ticketing.ttf" :asset-args '(:oversample 2)))))
 
-    (setf (ww::unit-width hello)
-          (* 5 (ww::unit-width hello))
-
-          (ww::unit-height hello)
-          (* 5 (ww::unit-height hello))
-
-          (ww::unit-x hello) 100
-
-          (ww::unit-y hello) 400)
+    
+    (ww::set-height-preserve-aspect hello 100)
 
+    (setf
+     (ww::unit-x hello) 100
+     
+     (ww::unit-y hello) 400)
+    
     (ww::add-handler hello #'marquee)
     (ww::add-handler hello #'change-text-color)
+    (ww::add-handler hello (ww::on-mousedown () (format t "I Was Clicked at ~a,~a!~%"
+                                                        x y)))
     (ww::refocus-on hello)
 
-    (ww::add-unit app hello)))
+    (describe hello)
+
+    (ww::add-unit app hello)
+    ))
 
 
 (defun start ()
diff --git a/wheelwork.lisp b/wheelwork.lisp
index 16eccad..5807f30 100644
--- a/wheelwork.lisp
+++ b/wheelwork.lisp
@@ -8,14 +8,47 @@
 (defclass/std unit ()
   ((cached-model cached-projected-matrix :a)
    (container :with :a)
-   (width height :with :std 1.0)
+   (base-width base-height :r :std 1.0 :doc "Determined by content.")
+   (scale-x scale-y :with :std 1.0)
    (rotation x y :with :std 0.0)
    (opacity :std 1.0 :doc "0.0 indicates it will not be rendred.")))
 
+(defgeneric unit-width (unit))
+(defgeneric unit-height (unit)) 
+(defgeneric (setf unit-width) (newval unit))
+(defgeneric (setf unit-height) (newval unit))
+
+(defun scale-by (unit amount)
+  (with-slots (scale-x scale-y) unit
+    (setf scale-x (* amount scale-x)
+          scale-y (* amount scale-y))))
+
+(defun set-width-preserve-aspect (unit new-width)
+  (scale-by unit (/ new-width (unit-width unit))))
+
+(defun set-height-preserve-aspect (unit new-height)
+  (scale-by unit (/ new-height (unit-height unit) )))
+
+(defmethod unit-width ((unit unit))
+  (with-slots (scale-x base-width) unit
+    (* scale-x base-width)))
+
+(defmethod unit-height ((unit unit))
+  (with-slots (scale-y base-height) unit
+    (* scale-y base-height)))
+
+(defmethod (setf unit-width) (newval (unit unit))
+  (with-slots (scale-x base-width) unit
+    (setf scale-x (coerce (/ newval base-width) 'single-float))))
+
+(defmethod (setf unit-height) (newval (unit unit))
+  (with-slots (scale-y base-height) unit
+    (setf scale-y (coerce (/ newval base-height) 'single-float))))
+
 (defmethod (setf closer-mop:slot-value-using-class) :after
     (newval class (unit unit) slot)
   (case (closer-mop:slot-definition-name slot)
-    ((x y width height rotation )
+    ((x y scale-x scale-y rotation)
      (setf (cached-model unit) nil
            (cached-projected-matrix unit) nil))))
 
@@ -296,18 +329,24 @@ necessary."
   (:documentation "Returns the raw array of the model matrix after it
   has been prjected by the application's projecion matrix"))
 
-(defmethod model-matrix ((u unit))
+(defmethod model-matrix :around ((u unit))
   (or (cached-model u)
       (setf (cached-model u)
-            (let ((m (mat:meye 4)))
-              (mat:nmtranslate m (vec:vec (unit-x u) (unit-y u) 0.0))
+            (call-next-method))))
 
-              (mat:nmtranslate m (vec:v* 0.5 (vec:vec (unit-width u) (unit-height u) 0.0)))
-              (mat:nmrotate  m vec:+vz+ (unit-rotation u))
-              (mat:nmtranslate m (vec:v* -0.5 (vec:vec (unit-width u) (unit-height u) 0.0)))
-              
-              (mat:nmscale m (vec:vec (unit-width u) (unit-height u) 1.0))
-              m))))
+(defmethod model-matrix ((u unit))
+  (let ((m (mat:meye 4)))
+    (with-slots (x y base-width scale-x base-height scale-y rotation) u 
+      (let ((uw (* base-width scale-x))
+            (uh (* base-height scale-y)))
+        (mat:nmtranslate m (vec:vec x y 0.0))
+
+        (mat:nmtranslate m (vec:v* 0.5 (vec:vec uw uh 0.0)))
+        (mat:nmrotate  m vec:+vz+ rotation)
+        (mat:nmtranslate m (vec:v* -0.5 (vec:vec uw uh 0.0)))
+        
+        (mat:nmscale m (vec:vec uw uh 1.0))))
+    m))
 
 (defmethod projected-matrix ((thing unit))
   (or (cached-projected-matrix thing)
@@ -400,7 +439,7 @@ TARGET is FOCUSABLEP"
              (sdl2:mod-keywords (sdl2:mod-value sdl-keysym))))))
 
 (defun contains-point-p (unit px py)
-  (with-slots (x y width height) unit
+  (with-accessors ((x unit-x) (y unit-y) (width unit-width) (height unit-height)) unit
     (and (<= x px (+ x width))
          (<= y py (+ y height)))))
 
@@ -548,9 +587,9 @@ give focus to whatever was clicked."
     (cffi:foreign-type-size :float))
 
 (defmethod initialize-instance :after ((bitmap bitmap) &key)
-  (with-slots (vao shader width height texture) bitmap
-    (setf height (texture-height texture)
-          width (texture-width texture))
+  (with-slots (vao shader base-width base-height texture) bitmap
+    (setf base-height (texture-height texture)
+          base-width (texture-width texture))
     (unless shader
       (setf shader
             (create-shader
@@ -647,8 +686,24 @@ ASSET-ARGS is a plist to pass to make-instance for the given resource.
    (vao elem-count :r)
    (shader :with :static :r)))
 
+(defmethod model-matrix ((text text))
+  (let ((m (mat:meye 4)))
+    (with-slots (x y base-width base-height scale-x scale-y rotation) text 
+      (mat:nmtranslate m (vec:vec x y 0.0))
+
+      (mat:nmtranslate m (vec:v* 0.5 (vec:vec (* scale-x base-width)
+                                              (* scale-y base-height)
+                                              0.0)))
+      (mat:nmrotate  m vec:+vz+ rotation)
+      (mat:nmtranslate m (vec:v* -0.5 (vec:vec (* scale-x base-width)
+                                               (* scale-y base-height)
+                                               0.0)))
+      
+      (mat:nmscale m (vec:vec scale-x scale-y 1.0)))
+    m))
+
 (defmethod initialize-instance :after ((text text) &key)
-  (with-slots (content font vao elem-count shader) text
+  (with-slots (content font vao elem-count shader base-width base-height scale-x scale-y) text
     (unless shader
       (setf shader
             (create-shader
@@ -665,7 +720,10 @@ ASSET-ARGS is a plist to pass to make-instance for the given resource.
                ((* color (aref (vari:texture tex tc) 0)))))))
     (multiple-value-bind (vao% count%) (cl-fond:compute-text (font-object font) content)
       (setf vao vao%
-            elem-count count%))))
+            elem-count count%))
+    (hq:with-plist (l r (top t) b) (cl-fond:compute-extent (font-object font) content)
+      (setf base-width ((- r l))
+            base-height (+ top b)))))
 
 (defmethod cleanup ((text text))
   (with-slots (vao shader) text