[structure] renamed some asd modules

3 files changed, 219 insertions, 0 deletions

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)))