From 2340c1a09895502667c9ba75c3db73b555ef40aa Mon Sep 17 00:00:00 2001 From: Colin Okay Date: Mon, 27 Jun 2022 15:06:12 -0500 Subject: [modify] unit model-matrix [add] text model-matrix [add] scale funs --- wheelwork.lisp | 92 +++++++++++++++++++++++++++++++++++++++++++++++----------- 1 file changed, 75 insertions(+), 17 deletions(-) (limited to 'wheelwork.lisp') 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 -- cgit v1.2.3