From 642c0c594a8abe05be1cb887110ed3e602cd0e48 Mon Sep 17 00:00:00 2001 From: Colin Okay Date: Thu, 30 Jun 2022 07:57:54 -0500 Subject: [structure] renamed some asd modules --- src/core-units/affine.lisp | 69 -------------------- src/core-units/container.lisp | 32 --------- src/core-units/unit.lisp | 30 --------- src/core/affine.lisp | 69 ++++++++++++++++++++ src/core/container.lisp | 32 +++++++++ src/core/unit.lisp | 30 +++++++++ src/events/listener-and-interactive.lisp | 108 ------------------------------- src/events/listener.lisp | 56 ++++++++++++++++ src/interactive-units/bitmap.lisp | 72 --------------------- src/interactive-units/text.lisp | 91 -------------------------- src/interactive/bitmap.lisp | 72 +++++++++++++++++++++ src/interactive/interactive.lisp | 56 ++++++++++++++++ src/interactive/text.lisp | 91 ++++++++++++++++++++++++++ 13 files changed, 406 insertions(+), 402 deletions(-) delete mode 100644 src/core-units/affine.lisp delete mode 100644 src/core-units/container.lisp delete mode 100644 src/core-units/unit.lisp create mode 100644 src/core/affine.lisp create mode 100644 src/core/container.lisp create mode 100644 src/core/unit.lisp delete mode 100644 src/events/listener-and-interactive.lisp create mode 100644 src/events/listener.lisp delete mode 100644 src/interactive-units/bitmap.lisp delete mode 100644 src/interactive-units/text.lisp create mode 100644 src/interactive/bitmap.lisp create mode 100644 src/interactive/interactive.lisp create mode 100644 src/interactive/text.lisp (limited to 'src') diff --git a/src/core-units/affine.lisp b/src/core-units/affine.lisp deleted file mode 100644 index cabe17c..0000000 --- a/src/core-units/affine.lisp +++ /dev/null @@ -1,69 +0,0 @@ -;;;; 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-units/container.lisp b/src/core-units/container.lisp deleted file mode 100644 index af01ff1..0000000 --- a/src/core-units/container.lisp +++ /dev/null @@ -1,32 +0,0 @@ -;;;; 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-units/unit.lisp b/src/core-units/unit.lisp deleted file mode 100644 index 20e05e2..0000000 --- a/src/core-units/unit.lisp +++ /dev/null @@ -1,30 +0,0 @@ -;;;; 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))))) - - 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))))) + + diff --git a/src/events/listener-and-interactive.lisp b/src/events/listener-and-interactive.lisp deleted file mode 100644 index e5bdce3..0000000 --- a/src/events/listener-and-interactive.lisp +++ /dev/null @@ -1,108 +0,0 @@ -;;;; listener.lisp - -(in-package #:wheelwork) - -(defclass/std listener () - ((keydown - keyup - mousedown - mouseup - mousemotion - mousewheel - focus - blur - perframe - after-added - before-added - before-dropped - :r :with :type (or null event-handler) :std nil) - (keydown-table - keyup-table - mousedown-table - mouseup-table - mousemotion-table - mousewheel-table - focus-table - blur-table - perframe-table - after-added-table - before-added-table - before-dropped-table - :static - :std (make-hash-table :synchronized t) - :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.")) - -(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)) - (mousemotion (mousemotion-table listener)) - (mousewheel (mousewheel-table listener)) - (focus (focus-table listener)) - (blur (blur-table listener)) - (perframe (perframe-table listener)) - (after-added (after-added-table listener)) - (before-added (before-added-table listener)) - (after-dropped (after-dropped-table listener)) - (before-dropped (before-dropped-table listener)))) - -(defun should-listen-for-p (event-type app) - (plusp (hash-table-count (listener-table-for (listener app) event-type)))) - -(defclass/std interactive () - ((listener :type (or null listener) :std nil :a) - (focusablep :std t :doc "Whether or not this object can receive application focus.")) - (:documentation "Supplies an object with a listener slot.")) - -(defun add-handler (interactive handler) - (when (null (listener interactive)) - (setf (listener interactive) (make-instance 'listener))) - (pushnew handler (slot-value (listener interactive) (event-type handler)) :test #'eq) - (setf - (gethash interactive (listener-table-for (listener interactive) (event-type handler))) - t)) - - -(defun remove-handler (interactive handler-or-event-type) - "Handler can be an instance of EVENT-HANDLER or can be a symbol - whose name is an event type. If is an event handler, only that - handler will be removed. If it is an event type, all events of that - type name are removed from the object." - (when (listener interactive) - (let ((event-type (etypecase handler-or-event-type - (keyword (intern (symbol-name handler-or-event-type) :wheelwork)) - (symbol (intern (symbol-name handler-or-event-type) :wheelwork)) - (event-handler (event-type handler-or-event-type))))) - (setf (slot-value (listener interactive) event-type) - (if (symbolp handler-or-event-type) - ;; remove everything if a symbol - nil - ;; delete just the handler - (delete handler-or-event-type - (slot-value (listener interactive) event-type) - :test #'eq))) - ;; remove from from the global table unless any listeners remain on this event - (unless (slot-value (listener interactive) event-type) - (remhash interactive (listener-table-for (listener interactive) event-type)))))) - - -(defmethod drop-unit :before ((unit interactive)) - (when (unit-container unit) - (when-let (handlers (get-handlers-for unit 'before-dropped)) - (dolist (handler handlers) - (funcall handler unit))))) - -(defmethod add-unit :before ((container container) (unit interactive)) - (when-let (handlers (get-handlers-for unit 'before-added)) - (dolist (handler handlers) - (funcall handler container unit)))) - -(defmethod add-unit :after ((container container) (unit interactive)) - (when-let (handlers (get-handlers-for unit 'after-added)) - (dolist (handler handlers) - (funcall handler container unit)))) diff --git a/src/events/listener.lisp b/src/events/listener.lisp new file mode 100644 index 0000000..3e195ff --- /dev/null +++ b/src/events/listener.lisp @@ -0,0 +1,56 @@ +;;;; listener.lisp + +(in-package #:wheelwork) + +(defclass/std listener () + ((keydown + keyup + mousedown + mouseup + mousemotion + mousewheel + focus + blur + perframe + after-added + before-added + before-dropped + :r :with :type (or null event-handler) :std nil) + (keydown-table + keyup-table + mousedown-table + mouseup-table + mousemotion-table + mousewheel-table + focus-table + blur-table + perframe-table + after-added-table + before-added-table + before-dropped-table + :static + :std (make-hash-table :synchronized t) + :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.")) + +(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)) + (mousemotion (mousemotion-table listener)) + (mousewheel (mousewheel-table listener)) + (focus (focus-table listener)) + (blur (blur-table listener)) + (perframe (perframe-table listener)) + (after-added (after-added-table listener)) + (before-added (before-added-table listener)) + (after-dropped (after-dropped-table listener)) + (before-dropped (before-dropped-table listener)))) + +(defun should-listen-for-p (event-type app) + (plusp (hash-table-count (listener-table-for (listener app) event-type)))) + diff --git a/src/interactive-units/bitmap.lisp b/src/interactive-units/bitmap.lisp deleted file mode 100644 index cc4b4f7..0000000 --- a/src/interactive-units/bitmap.lisp +++ /dev/null @@ -1,72 +0,0 @@ -;;;; bitmap.lisp - -(in-package #:wheelwork) - -(defclass/std bitmap (affine interactive) - ((texture :ri :std (error "A bitmap requires a texture.")) - (vao shader :with :r :static))) - -(defmethod initialize-instance :after ((bitmap bitmap) &key) - (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 - '(:vertex - ((vert :vec2)) - ((transform :mat4)) - ((values - (* transform (vari:vec4 vert 0.0 1.0)) - vert))) ;color - '(:fragment - ((tc :vec2)) - ((tex :sampler-2d)) - ((let ((frag (vari:texture tex tc))) - (if (< (aref frag 3) 0.01) - (vari:discard) - frag)))))) - (gl:program-uniformi - shader - (gl:get-uniform-location shader "TEX") - 0)) - (unless vao - (setf vao (gl:gen-vertex-array)) - (gl:bind-vertex-array vao) - (let ((vbo (gl:gen-buffer))) - (with-gl-array (verts :float - 0.0 1.0 - 1.0 0.0 - 0.0 0.0 - - 0.0 1.0 - 1.0 1.0 - 1.0 0.0 ) - (gl:bind-buffer :array-buffer vbo) - (gl:buffer-data :array-buffer :static-draw verts))) - (gl:enable-vertex-attrib-array 0) - (gl:vertex-attrib-pointer 0 2 :float 0 (* +float-size+ 2) 0) - (gl:bind-buffer :array-buffer 0) - (gl:bind-vertex-array 0)))) - -(defmethod cleanup ((bitmap bitmap)) - (with-slots (vao shader) bitmap - (when vao - (gl:delete-vertex-arrays (list vao))) - (when shader - (gl:delete-program shader)) - (setf vao nil - shader nil))) - -(defmethod render ((bitmap bitmap)) - (with-slots (texture vao shader) bitmap - (gl:active-texture 0) - (gl:bind-texture :texture-2d (texture-id texture)) - (gl:use-program shader) - (gl:program-uniform-matrix-4fv - shader - (gl:get-uniform-location shader "TRANSFORM") - (projected-matrix bitmap)) - (gl:bind-vertex-array vao) - (gl:draw-arrays :triangles 0 6) - (gl:bind-vertex-array 0))) diff --git a/src/interactive-units/text.lisp b/src/interactive-units/text.lisp deleted file mode 100644 index caba48e..0000000 --- a/src/interactive-units/text.lisp +++ /dev/null @@ -1,91 +0,0 @@ -;;;; units/text.lisp - -(in-package #:wheelwork) - -(defclass/std text (affine interactive) - ((font :with :ri :std (error "A font is required") :type font) - (content :with :ri :std "") - (color :with :std #(1.0 1.0 1.0 1.0)) - (vao elem-count newlines :r) - (shader :with :static :r))) - -(defmethod model-matrix ((text text)) - (let ((m (mat:meye 4))) - (with-slots (font newlines x y base-width base-height scale-x scale-y rotation) text - (let* ((text-height - (cl-fond:text-height (font-object font))) - (baseline-offset - (* newlines text-height)) - (rotation-baseline-offset - (* 2 newlines text-height ))) - (mat:nmtranslate m (vec:vec x - (+ y - (* - scale-y - baseline-offset)) - 0.0)) - - (mat:nmtranslate m (vec:v* 0.5 (vec:vec (* scale-x base-width) - (* scale-y (- base-height rotation-baseline-offset) ) - 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 rotation-baseline-offset)) - 0.0)))) - - (mat:nmscale m (vec:vec scale-x scale-y 1.0)) - m))) - -(defmethod initialize-instance :after ((text text) &key) - (with-slots (content newlines font vao elem-count shader base-width base-height scale-x scale-y) text - (unless shader - (setf shader - (create-shader - '(:vertex - ((vert :vec2) (col :vec2)) - ((transform :mat4)) - ((values - (* transform (vari:vec4 vert 0.0 1.0)) - col))) - '(:fragment - ((tc :vec2)) - ((tex :sampler-2d) - (color :vec4)) - ((* 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%)) - (setf newlines (count #\newline content)) - (hq:with-plist ((l :l) (r :r)) (cl-fond:compute-extent (font-object font) content) - (setf base-width (- r l) - base-height (* (cl-fond:text-height (font-object font)) - (1+ newlines)))))) - -(defmethod cleanup ((text text)) - (with-slots (vao shader) text - (gl:delete-vertex-arrays (list vao)) - (when shader - (gl:delete-program shader)) - (setf vao nil - shader nil))) - -(defmethod render ((text text)) - (with-slots (shader font vao elem-count color) text - (gl:use-program shader) - (gl:active-texture 0) - (gl:bind-texture :texture-2d (cl-fond:texture (font-object font))) - (gl:program-uniform-matrix-4fv - shader - (gl:get-uniform-location shader "TRANSFORM") - (projected-matrix text)) - (gl:program-uniformi - shader - (gl:get-uniform-location shader "TEX") - 0) - (gl:program-uniformfv - shader - (gl:get-uniform-location shader "COLOR") - color) - (gl:bind-vertex-array vao) - (%gl:draw-elements :triangles elem-count :unsigned-int 0) - (gl:bind-vertex-array 0))) diff --git a/src/interactive/bitmap.lisp b/src/interactive/bitmap.lisp new file mode 100644 index 0000000..cc4b4f7 --- /dev/null +++ b/src/interactive/bitmap.lisp @@ -0,0 +1,72 @@ +;;;; bitmap.lisp + +(in-package #:wheelwork) + +(defclass/std bitmap (affine interactive) + ((texture :ri :std (error "A bitmap requires a texture.")) + (vao shader :with :r :static))) + +(defmethod initialize-instance :after ((bitmap bitmap) &key) + (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 + '(:vertex + ((vert :vec2)) + ((transform :mat4)) + ((values + (* transform (vari:vec4 vert 0.0 1.0)) + vert))) ;color + '(:fragment + ((tc :vec2)) + ((tex :sampler-2d)) + ((let ((frag (vari:texture tex tc))) + (if (< (aref frag 3) 0.01) + (vari:discard) + frag)))))) + (gl:program-uniformi + shader + (gl:get-uniform-location shader "TEX") + 0)) + (unless vao + (setf vao (gl:gen-vertex-array)) + (gl:bind-vertex-array vao) + (let ((vbo (gl:gen-buffer))) + (with-gl-array (verts :float + 0.0 1.0 + 1.0 0.0 + 0.0 0.0 + + 0.0 1.0 + 1.0 1.0 + 1.0 0.0 ) + (gl:bind-buffer :array-buffer vbo) + (gl:buffer-data :array-buffer :static-draw verts))) + (gl:enable-vertex-attrib-array 0) + (gl:vertex-attrib-pointer 0 2 :float 0 (* +float-size+ 2) 0) + (gl:bind-buffer :array-buffer 0) + (gl:bind-vertex-array 0)))) + +(defmethod cleanup ((bitmap bitmap)) + (with-slots (vao shader) bitmap + (when vao + (gl:delete-vertex-arrays (list vao))) + (when shader + (gl:delete-program shader)) + (setf vao nil + shader nil))) + +(defmethod render ((bitmap bitmap)) + (with-slots (texture vao shader) bitmap + (gl:active-texture 0) + (gl:bind-texture :texture-2d (texture-id texture)) + (gl:use-program shader) + (gl:program-uniform-matrix-4fv + shader + (gl:get-uniform-location shader "TRANSFORM") + (projected-matrix bitmap)) + (gl:bind-vertex-array vao) + (gl:draw-arrays :triangles 0 6) + (gl:bind-vertex-array 0))) diff --git a/src/interactive/interactive.lisp b/src/interactive/interactive.lisp new file mode 100644 index 0000000..a8fa7fd --- /dev/null +++ b/src/interactive/interactive.lisp @@ -0,0 +1,56 @@ +;;;; interactive.lisp + +(in-package #:wheelwork) + +(defclass/std interactive () + ((listener :type (or null listener) :std nil :a) + (focusablep :std t :doc "Whether or not this object can receive application focus.")) + (:documentation "Supplies an object with a listener slot.")) + +(defun add-handler (interactive handler) + (when (null (listener interactive)) + (setf (listener interactive) (make-instance 'listener))) + (pushnew handler (slot-value (listener interactive) (event-type handler)) :test #'eq) + (setf + (gethash interactive (listener-table-for (listener interactive) (event-type handler))) + t)) + + +(defun remove-handler (interactive handler-or-event-type) + "Handler can be an instance of EVENT-HANDLER or can be a symbol + whose name is an event type. If is an event handler, only that + handler will be removed. If it is an event type, all events of that + type name are removed from the object." + (when (listener interactive) + (let ((event-type (etypecase handler-or-event-type + (keyword (intern (symbol-name handler-or-event-type) :wheelwork)) + (symbol (intern (symbol-name handler-or-event-type) :wheelwork)) + (event-handler (event-type handler-or-event-type))))) + (setf (slot-value (listener interactive) event-type) + (if (symbolp handler-or-event-type) + ;; remove everything if a symbol + nil + ;; delete just the handler + (delete handler-or-event-type + (slot-value (listener interactive) event-type) + :test #'eq))) + ;; remove from from the global table unless any listeners remain on this event + (unless (slot-value (listener interactive) event-type) + (remhash interactive (listener-table-for (listener interactive) event-type)))))) + + +(defmethod drop-unit :before ((unit interactive)) + (when (unit-container unit) + (when-let (handlers (get-handlers-for unit 'before-dropped)) + (dolist (handler handlers) + (funcall handler unit))))) + +(defmethod add-unit :before ((container container) (unit interactive)) + (when-let (handlers (get-handlers-for unit 'before-added)) + (dolist (handler handlers) + (funcall handler container unit)))) + +(defmethod add-unit :after ((container container) (unit interactive)) + (when-let (handlers (get-handlers-for unit 'after-added)) + (dolist (handler handlers) + (funcall handler container unit)))) diff --git a/src/interactive/text.lisp b/src/interactive/text.lisp new file mode 100644 index 0000000..caba48e --- /dev/null +++ b/src/interactive/text.lisp @@ -0,0 +1,91 @@ +;;;; units/text.lisp + +(in-package #:wheelwork) + +(defclass/std text (affine interactive) + ((font :with :ri :std (error "A font is required") :type font) + (content :with :ri :std "") + (color :with :std #(1.0 1.0 1.0 1.0)) + (vao elem-count newlines :r) + (shader :with :static :r))) + +(defmethod model-matrix ((text text)) + (let ((m (mat:meye 4))) + (with-slots (font newlines x y base-width base-height scale-x scale-y rotation) text + (let* ((text-height + (cl-fond:text-height (font-object font))) + (baseline-offset + (* newlines text-height)) + (rotation-baseline-offset + (* 2 newlines text-height ))) + (mat:nmtranslate m (vec:vec x + (+ y + (* + scale-y + baseline-offset)) + 0.0)) + + (mat:nmtranslate m (vec:v* 0.5 (vec:vec (* scale-x base-width) + (* scale-y (- base-height rotation-baseline-offset) ) + 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 rotation-baseline-offset)) + 0.0)))) + + (mat:nmscale m (vec:vec scale-x scale-y 1.0)) + m))) + +(defmethod initialize-instance :after ((text text) &key) + (with-slots (content newlines font vao elem-count shader base-width base-height scale-x scale-y) text + (unless shader + (setf shader + (create-shader + '(:vertex + ((vert :vec2) (col :vec2)) + ((transform :mat4)) + ((values + (* transform (vari:vec4 vert 0.0 1.0)) + col))) + '(:fragment + ((tc :vec2)) + ((tex :sampler-2d) + (color :vec4)) + ((* 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%)) + (setf newlines (count #\newline content)) + (hq:with-plist ((l :l) (r :r)) (cl-fond:compute-extent (font-object font) content) + (setf base-width (- r l) + base-height (* (cl-fond:text-height (font-object font)) + (1+ newlines)))))) + +(defmethod cleanup ((text text)) + (with-slots (vao shader) text + (gl:delete-vertex-arrays (list vao)) + (when shader + (gl:delete-program shader)) + (setf vao nil + shader nil))) + +(defmethod render ((text text)) + (with-slots (shader font vao elem-count color) text + (gl:use-program shader) + (gl:active-texture 0) + (gl:bind-texture :texture-2d (cl-fond:texture (font-object font))) + (gl:program-uniform-matrix-4fv + shader + (gl:get-uniform-location shader "TRANSFORM") + (projected-matrix text)) + (gl:program-uniformi + shader + (gl:get-uniform-location shader "TEX") + 0) + (gl:program-uniformfv + shader + (gl:get-uniform-location shader "COLOR") + color) + (gl:bind-vertex-array vao) + (%gl:draw-elements :triangles elem-count :unsigned-int 0) + (gl:bind-vertex-array 0))) -- cgit v1.2.3