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/interactive/bitmap.lisp | 72 +++++++++++++++++++++++++++++++ src/interactive/interactive.lisp | 56 +++++++++++++++++++++++++ src/interactive/text.lisp | 91 ++++++++++++++++++++++++++++++++++++++++ 3 files changed, 219 insertions(+) create mode 100644 src/interactive/bitmap.lisp create mode 100644 src/interactive/interactive.lisp create mode 100644 src/interactive/text.lisp (limited to 'src/interactive') 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