diff options
Diffstat (limited to 'src/core')
-rw-r--r-- | src/core/affine.lisp | 69 | ||||
-rw-r--r-- | src/core/container.lisp | 32 | ||||
-rw-r--r-- | src/core/unit.lisp | 30 |
3 files changed, 131 insertions, 0 deletions
diff --git a/src/core/affine.lisp b/src/core/affine.lisp new file mode 100644 index 0000000..cabe17c --- /dev/null +++ b/src/core/affine.lisp @@ -0,0 +1,69 @@ +;;;; affine.lisp + +(in-package #:wheelwork) + +(defclass/std affine (unit) + ((cached-model cached-projected-matrix cached-application :a) + (base-width base-height :r :std 1.0 :doc "Determined by content.") + (scale-x scale-y :std 1.0) + (rotation x y :std 0.0))) + +(defmethod (setf closer-mop:slot-value-using-class) :after + (newval class (affine affine) slot) + (case (closer-mop:slot-definition-name slot) + ((x y scale-x scale-y rotation) + (setf (cached-model affine) nil + (cached-projected-matrix affine) nil)))) + +(defun scale-by (affine amount) + (with-slots (scale-x scale-y) affine + (setf scale-x (* amount scale-x) + scale-y (* amount scale-y)))) + +(defun set-width-preserve-aspect (affine new-width) + (scale-by affine (/ new-width (width affine)))) + +(defun set-height-preserve-aspect (affine new-height) + (scale-by affine (/ new-height (height affine) ))) + +(defun width (affine) + (with-slots (scale-x base-width) affine + (* scale-x base-width))) + +(defun height (affine) + (with-slots (scale-y base-height) affine + (* scale-y base-height))) + +(defun (setf width) (newval affine) + (with-slots (scale-x base-width) affine + (setf scale-x (coerce (/ newval base-width) 'single-float)))) + +(defun (setf height) (newval affine) + (with-slots (scale-y base-height) affine + (setf scale-y (coerce (/ newval base-height) 'single-float)))) + +(defmethod model-matrix :around ((u affine)) + (or (cached-model u) + (setf (cached-model u) + (call-next-method)))) + +(defmethod model-matrix ((u affine)) + (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)) + + +(defun projected-matrix (affine) + (or (cached-projected-matrix affine) + (setf (cached-projected-matrix affine) + (mat:marr (mat:m* (application-projection (app-of-unit affine)) + (model-matrix affine)))))) diff --git a/src/core/container.lisp b/src/core/container.lisp new file mode 100644 index 0000000..af01ff1 --- /dev/null +++ b/src/core/container.lisp @@ -0,0 +1,32 @@ +;;;; units/container.lisp + +(in-package #:wheelwork) + + +(defclass/std container (unit) + ((units :with :a)) + (:documentation "Just a list of units. Made into a class so that + transformation affine transformations methods can be specialzied on + whole groups of units")) + +(defmethod drop-unit ((unit unit)) + "Removes a unit from its container. Returns T if the unit actually was removed." + (when-let (container (unit-container unit)) + (setf + (container-units container) (delete unit (container-units container)) + (unit-container unit) nil) + t)) + +(defmethod add-unit ((container container) (unit unit)) + "Adds a unit to the end of a container (thus affecting render +order). Makes sure to remove the unit from its current container if +necessary." + (when (unit-container unit) + (drop-unit unit)) + (push unit (container-units container)) + (setf (unit-container unit) container) + unit) + +(defmethod cleanup ((container container)) + (dolist (u (container-units container)) + (cleanup u))) diff --git a/src/core/unit.lisp b/src/core/unit.lisp new file mode 100644 index 0000000..20e05e2 --- /dev/null +++ b/src/core/unit.lisp @@ -0,0 +1,30 @@ +;;;; units/unit.lisp + +(in-package #:wheelwork) + +(defclass/std unit () + ((cached-application :a) + (container :with :a))) + +(defmethod (setf closer-mop:slot-value-using-class) :after + (newval class (unit unit) slot) + (case (closer-mop:slot-definition-name slot) + (container + (setf (cached-application unit) nil)))) + + +(defun app-of-unit (unit) + "Returns the APPLICATION instance, if any, of which this UNIT is a +part. NIL indicates that the unit has not been added to any container +in this application." + (or (cached-application unit) + (setf (cached-application unit) + (labels ((rec (u) + (when-let (c (unit-container u)) + (etypecase c + (application c) + (unit (rec c)) + (null nil))))) + (rec unit))))) + + |