1 files changed, 75 insertions, 17 deletions

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