diff options
| -rw-r--r-- | src/application.lisp | 108 | ||||
| -rw-r--r-- | src/assets/asset.lisp | 18 | ||||
| -rw-r--r-- | src/assets/font.lisp | 17 | ||||
| -rw-r--r-- | src/assets/png.lisp | 31 | ||||
| -rw-r--r-- | src/core-units/container.lisp | 32 | ||||
| -rw-r--r-- | src/core-units/unit.lisp | 71 | ||||
| -rw-r--r-- | src/events/event-handler.lisp | 260 | ||||
| -rw-r--r-- | src/events/listener-and-interactive.lisp | 108 | ||||
| -rw-r--r-- | src/events/listener.lisp | 4 | ||||
| -rw-r--r-- | src/gl/shader.lisp | 42 | ||||
| -rw-r--r-- | src/gl/texture.lisp | 12 | ||||
| -rw-r--r-- | src/gl/util.lisp | 19 | ||||
| -rw-r--r-- | src/interactive-units/bitmap.lisp | 71 | ||||
| -rw-r--r-- | src/interactive-units/text.lisp | 91 | ||||
| -rw-r--r-- | src/package.lisp (renamed from package.lisp) | 0 | ||||
| -rw-r--r-- | src/protocol.lisp | 45 | ||||
| -rw-r--r-- | src/utils.lisp | 9 | ||||
| -rw-r--r-- | src/wheelwork.lisp | 259 | ||||
| -rw-r--r-- | wheelwork.asd | 21 | ||||
| -rw-r--r-- | wheelwork.lisp | 1129 |
20 files changed, 1218 insertions, 1129 deletions
diff --git a/src/application.lisp b/src/application.lisp new file mode 100644 index 0000000..5d8135e --- /dev/null +++ b/src/application.lisp @@ -0,0 +1,108 @@ +;;;; application + +(in-package #:wheelwork) + +(defvar *application* nil + "current application") + +(defclass/std application (container interactive) + ((title :with :std "Wheelwork App") + (asset-root :ri :std #P"./" :doc "Directory under which assets are stored.") + (asset-classifiers + :std '(("png" png) ("ttf" font)) + :doc "ALIST of (EXT CLASS). EXT is a string, file estension. CLASS is a symbol, class name.") + (assets :with :a :std (make-hash-table :test 'equal) + :doc "maps asset names to asset instances.") + (scale :with :std 1.0) + (width height :with :std 800) + (projection :with :a :doc "The projection matrix for the scene. Orthographic by default.") + (window :with :a) + (refocus-on-mousedown-p :std t) + (focus last-motion-target :with :a) + (fps :with :std 30 :doc "Frames Per Second") + (frame-wait :r))) + +(defun fps (&optional (app *application*)) + (application-fps app)) + +(defun (setf fps) (new-val &optional (app *application*)) + (setf (application-fps app) new-val)) + +(defun can-set-projection-p (app) + (and (slot-boundp app 'width) + (slot-boundp app 'height) + (slot-boundp app 'scale))) + +(defun set-projection (app) + (when (can-set-projection-p app) + (with-slots (projection scale width height) app + ;; set projection matrix + (setf projection (mat:mortho 0.0 (/ width scale) 0 (/ height scale) -1.0 1.0))))) + +(defmethod initialize-instance :after ((app application) &key) + (set-projection app) + (setf (listener app) (make-instance 'listener))) + +(defun fire-blur-event-on (thing) + (when-let (blur-handlers (and thing (get-handlers-for thing 'blur))) + (dolist (handler blur-handlers) + (funcall handler thing)))) + +(defun fire-focus-event-on (thing) + (when-let (focus-handlers (and thing (get-handlers-for thing 'focus))) + (dolist (handler focus-handlers) + (funcall handler thing)))) + +(defmethod (setf closer-mop:slot-value-using-class ) :before + (new-value class (app application) slot) + (case (closer-mop:slot-definition-name slot) + (focus + (when (slot-boundp app 'focus) + (unless (eq new-value (slot-value app 'focus)) + (fire-blur-event-on (slot-value app 'focus)) + (fire-focus-event-on new-value)))))) + +(defmethod (setf closer-mop:slot-value-using-class) :after + (new-value class (app application) slot) + (case (closer-mop:slot-definition-name slot) + ((scale width height) + (set-projection app)) + (fps + (setf (slot-value app 'frame-wait) (/ 1.0 new-value))))) + +(defparameter +listener-table-slot-names+ + '(keydown-table keyup-table mousedown-table mouseup-table mousemotion-table + focus-table blur-table perframe-table after-added-table before-added-table + before-dropped-table)) + +(defmethod cleanup ((app application)) + (loop for asset being the hash-value of (application-assets app) + do (cleanup asset)) + ;; drop all current handlers + (let ((listener (listener app))) + (dolist (table +listener-table-slot-names+) + (setf (slot-value listener table) (make-hash-table :synchronized t)))) + (call-next-method)) + +(defun run-perframe (app) + "Runs all of the handlers objects listening for perframe events, if +those objects are currently part of the scene tree." + (let ((table (perframe-table (listener app))) + (time (get-universal-time))) + (loop for target being the hash-key of table + for handlers = (slot-value (listener target) 'perframe) + ;; only fire perframe when target is in scene + when (or (eq app target) (unit-container target)) + do (loop for handler in handlers do (funcall handler target time))))) + +(defmethod render ((app application)) + (run-perframe app) + (gl:clear-color 0.0 0.0 0.0 1.0) + ;(gl:clear :depth-buffer-bit :color-buffer-bit) + (gl:clear :color-buffer-bit) + (gl:enable :blend) + (gl:blend-func :src-alpha :one-minus-src-alpha ) + (dolist (thing (container-units app)) + (render thing)) + (sdl2:gl-swap-window (application-window app)) + (sleep (frame-wait app))) diff --git a/src/assets/asset.lisp b/src/assets/asset.lisp new file mode 100644 index 0000000..5f847da --- /dev/null +++ b/src/assets/asset.lisp @@ -0,0 +1,18 @@ +;;;; asset.lisp + +(in-package #:wheelwork) + +(defclass/std asset () + ((path :with :ri :std (error "An asset requires a path")) + (loadedp :with :a))) + +(defmethod cleanup :around ((asset asset)) + (when (asset-loadedp asset) + (call-next-method)) + (setf (asset-loadedp asset) nil)) + +(defmethod ensure-loaded :around ((thing asset)) + (unless (asset-loadedp thing) + (call-next-method) + (setf (asset-loadedp thing) t)) + thing) diff --git a/src/assets/font.lisp b/src/assets/font.lisp new file mode 100644 index 0000000..3ff29d5 --- /dev/null +++ b/src/assets/font.lisp @@ -0,0 +1,17 @@ +;;;; asset/font.lisp + +(in-package #:wheelwork) + +(define-symbol-macro +standard-font-chars+ + " +ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz01234567890\".,!?-'" ) + +(defclass/std font (asset) + ((characters :i :std +standard-font-chars+) + (oversample :i :doc "ovesampling factor to pass to cl-fond:make-font") + (object :with :r :doc "The font as returned from cl-fond:make-font"))) + +(defmethod ensure-loaded ((font font)) + (with-slots (path characters oversample object) font + (setf object (cl-fond:make-font path characters :oversample oversample)))) + diff --git a/src/assets/png.lisp b/src/assets/png.lisp new file mode 100644 index 0000000..aa259f0 --- /dev/null +++ b/src/assets/png.lisp @@ -0,0 +1,31 @@ +;;;; png.lisp + +(in-package #:wheelwork) + +(defclass/std png (asset texture) ()) + +(defmethod ensure-loaded ((png png)) + (with-slots + (width height id wrap-s wrap-t min-filter mag-filter internal-format image-format) + png + (pngload:with-png-in-static-vector (data (asset-path png) :flip-y t) + (setf width (pngload:width data) + height (pngload:height data) + id (gl:gen-texture)) + (gl:bind-texture :texture-2d id) + (gl:tex-parameter :texture-2d :texture-wrap-s wrap-s) + (gl:tex-parameter :texture-2d :texture-wrap-t wrap-t) + (gl:tex-parameter :texture-2d :texture-min-filter min-filter) + (gl:tex-parameter :texture-2d :texture-mag-filter mag-filter) + (gl:tex-image-2d :texture-2d + 0 + internal-format + width + height + 0 + image-format + :unsigned-byte + (pngload:data data)) + (gl:bind-texture :texture-2d 0) + (when (texture-mipmap png) + (gl:generate-mipmap :texture-2d))))) diff --git a/src/core-units/container.lisp b/src/core-units/container.lisp new file mode 100644 index 0000000..afa68b3 --- /dev/null +++ b/src/core-units/container.lisp @@ -0,0 +1,32 @@ +;;;; units/container.lisp + +(in-package #:wheelwork) + + +(defclass/std container () + ((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 new file mode 100644 index 0000000..939293b --- /dev/null +++ b/src/core-units/unit.lisp @@ -0,0 +1,71 @@ +;;;; units/unit.lisp + +(in-package #:wheelwork) + +(defclass/std unit () + ((cached-model cached-projected-matrix :a) + (container :with :a) + (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."))) + + +(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 scale-x scale-y rotation) + (setf (cached-model unit) nil + (cached-projected-matrix unit) nil)))) + +(defmethod model-matrix :around ((u unit)) + (or (cached-model u) + (setf (cached-model u) + (call-next-method)))) + +(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) + (setf (cached-projected-matrix thing) + (mat:marr (mat:m* (application-projection *application*) + (model-matrix thing)))))) diff --git a/src/events/event-handler.lisp b/src/events/event-handler.lisp new file mode 100644 index 0000000..bd40849 --- /dev/null +++ b/src/events/event-handler.lisp @@ -0,0 +1,260 @@ +;;;; event-handler.lisp + +(in-package #:wheelwork) + + +(defclass/std event-handler () + ((event-type handler-function :ri)) + (:metaclass closer-mop:funcallable-standard-class)) + +(defmethod initialize-instance :after ((eh event-handler) &key) + (with-slots (handler-function) eh + (closer-mop:set-funcallable-instance-function eh handler-function))) + + +(defmacro defhandler (name handler) + "Defines a handler - binds (FDEFINITION NAME) to HANDLER, which +should be an expression that evaluates to an instance of +EVENT-HANDLER, which is funcallable. It is define such that handlers +can be redefined using this form to support interactive development." + (let ((handler-var (gensym))) + `(let ((,handler-var ,handler)) + (if-let (extant (and (fboundp ',name) + (fdefinition ',name))) + (closer-mop:set-funcallable-instance-function extant (handler-function ,handler-var)) + (setf (fdefinition ',name) ,handler-var))))) + + +(defmacro on-perframe + ((&optional (target 'target) (time 'time)) &body body) + "Creates a handler for 'PERFRAME events" + `(make-instance + 'event-handler + :event-type 'wheelwork::perframe + :handler-function (lambda (,(intern (symbol-name target)) + ,(intern (symbol-name time))) + (declare (ignorable ,(intern (symbol-name target)) + ,(time (intern (symbol-name time))))) + ,@body))) + +(defmacro on-keydown + ((&optional (target 'target) (scancode 'scancode) (modifiers 'modifiers)) &body body) + "Creates a lambda suitable for the value of a keydown event + handler. The function accepts two positional arguments TARGET and + SCANCODE and one &REST argument MODIFIERS. + + SCANCODE will be a keyword of the form :SCANCODE-A, :SCANCODE-B ... + + The members of MODIFIERS look like :LSHIFT, :RCTRL, RALT, etc" + `(make-instance + 'event-handler + :event-type 'wheelwork::keydown + :handler-function (lambda (,(intern (symbol-name target)) + ,(intern (symbol-name scancode)) + &rest ,(intern (symbol-name modifiers))) + (declare (ignorable ,(intern (symbol-name target)) + ,(intern (symbol-name scancode)) + ,(intern (symbol-name modifiers)))) + ,@body))) + +(defmacro on-keyup + ((&optional (target 'target) (scancode 'scancode) (modifiers 'modifiers)) &body body) + "Creates a lambda suitable for the value of a keyup event + handler. The function accepts two positional arguments TARGET and + SCANCODE and one &REST argument MODIFIERS. + + SCANCODE will be a keyword of the form :SCANCODE-A, :SCANCODE-B ... + + The members of MODIFIERS look like :LSHIFT, :RCTRL, RALT, etc" + `(make-instance + 'event-handler + :event-type 'wheelwork::keyup + :handler-function (lambda (,(intern (symbol-name target)) + ,(intern (symbol-name scancode)) + &rest ,(intern (symbol-name modifiers))) + (declare (ignorable ,(intern (symbol-name target)) + ,(intern (symbol-name scancode)) + ,(intern (symbol-name modifiers)))) + ,@body))) + +(defmacro on-mousemotion + ((&optional + (target 'target) + (x 'x) (y 'y) + (xrel 'xrel) (yrel 'yrel) + (state 'state) + (win-x 'win-x) (win-y 'win-y) + (win-xrel 'win-xrel) (win-yrel 'win-yrel)) + &body body) + "Creates a handler for MOUSEMOTION events" + `(make-instance + 'event-handler + :event-type 'wheelwork::mousemotion + :handler-function (lambda (,(intern (symbol-name target)) + ,(intern (symbol-name x)) + ,(intern (symbol-name y)) + ,(intern (symbol-name xrel)) + ,(intern (symbol-name yrel)) + ,(intern (symbol-name state)) + ,(intern (symbol-name win-x)) + ,(intern (symbol-name win-y)) + ,(intern (symbol-name win-xrel)) + ,(intern (symbol-name win-yrel))) + (declare (ignorable ,(intern (symbol-name target)) + ,(intern (symbol-name x)) + ,(intern (symbol-name y)) + ,(intern (symbol-name xrel)) + ,(intern (symbol-name yrel)) + ,(intern (symbol-name state)) + ,(intern (symbol-name win-x)) + ,(intern (symbol-name win-y)) + ,(intern (symbol-name win-xrel)) + ,(intern (symbol-name win-yrel)))) + ,@body))) + +(defmacro on-mousedown + ((&optional (target 'target) + (x 'x) (y 'y) + (clicks 'clicks) (button 'button) + (win-x 'win-x) (win-y 'win-y)) + &body body) + "Creates a handler for MOUSEDOWN events" + `(make-instance + 'event-handler + :event-type 'wheelwork::mousedown + :handler-function (lambda + (,(intern (symbol-name target)) + ,(intern (symbol-name x)) + ,(intern (symbol-name y)) + ,(intern (symbol-name clicks)) + ,(intern (symbol-name button)) + ,(intern (symbol-name win-x)) + ,(intern (symbol-name win-y))) + (declare + (ignorable ,(intern (symbol-name target)) + ,(intern (symbol-name x)) + ,(intern (symbol-name y)) + ,(intern (symbol-name clicks)) + ,(intern (symbol-name button)) + ,(intern (symbol-name win-x)) + ,(intern (symbol-name win-y)))) + ,@body))) + +(defmacro on-mouseup + ((&optional (target 'target) + (x 'x) (y 'y) + (clicks 'clicks) (button 'button) + (win-x 'win-x) (win-y 'win-y)) + &body body) + "Creates a handler for MOUSEUP events" + `(make-instance + 'event-handler + :event-type 'wheelwork::mouseup + :handler-function (lambda + (,(intern (symbol-name target)) + ,(intern (symbol-name x)) + ,(intern (symbol-name y)) + ,(intern (symbol-name clicks)) + ,(intern (symbol-name button)) + ,(intern (symbol-name win-x)) + ,(intern (symbol-name win-y))) + (declare + (ignorable ,(intern (symbol-name target)) + ,(intern (symbol-name x)) + ,(intern (symbol-name y)) + ,(intern (symbol-name clicks)) + ,(intern (symbol-name button)) + ,(intern (symbol-name win-x)) + ,(intern (symbol-name win-y)))) + ,@body))) + +(defmacro on-mousewheel + ((&optional (target 'target) (horiz 'horiz) (vert 'vert) (dir 'dir)) &body body) + "Creates a handler for MOUSEWHEEL events" + `(make-instance + 'event-handler + :event-type 'wheelwork::mousewheel + :handler-function (lambda + (,(intern (symbol-name target)) + ,(intern (symbol-name horiz)) + ,(intern (symbol-name vert)) + ,(intern (symbol-name dir))) + (declare + (ignorable ,(intern (symbol-name target)) + ,(intern (symbol-name horiz)) + ,(intern (symbol-name vert)) + ,(intern (symbol-name dir)))) + ,@body))) + +(defmacro on-blur + ((&optional (target 'target)) &body body) + "Creates a handler for BLUR events. BLUR is a psuedo event that +fires whenever an object loses focus." + `(make-instance + 'event-handler + :event-type 'wheelwork::blur + :handler-function (lambda + (,(intern (symbol-name target))) + (declare + (ignorable ,(intern (symbol-name target)))) + ,@body))) + +(defmacro on-focus + ((&optional (target 'target)) &body body) + "Creates a handler for a FOCUS event. FOCUS is a pusedo event that +fires when the FOCUS slot of the current APPLICATION instance is changed. +" + `(make-instance + 'event-handler + :event-type 'wheelwork::focus + :handler-function (lambda + (,(intern (symbol-name target))) + (declare + (ignorable ,(intern (symbol-name target)))) + ,@body))) + +(defmacro on-before-dropped + ((&optional (target 'target)) &body body) + "Creates a handler for BEFORE-DROPPED events, which fire before a + unit is removed from its container." + `(make-instance + 'event-handler + :event-type 'wheelwork::before-dropped + :handler-function (lambda + (,(intern (symbol-name target))) + (declare + (ignorable ,(intern (symbol-name target)))) + ,@body))) + +(defmacro on-before-added + ((&optional (container 'container) (target 'target)) &body body) + "Creates a handler for BEFORE-ADDED events, which fire before a unit + is added to a container." + `(make-instance + 'event-handler + :event-type 'wheelwork::before-added + :handler-function (lambda + (,(intern (symbol-name container)) + ,(intern (symbol-name target))) + (declare + (ignorable + ,(intern (symbol-name container)) + ,(intern (symbol-name target)))) + ,@body))) + + +(defmacro on-after-added + ((&optional (container 'container) (target 'target)) &body body) + "Creates a handler for AFTER-ADDED events, which fire after a unit + is added to a container." + `(make-instance + 'event-handler + :event-type 'wheelwork::after-added + :handler-function (lambda + (,(intern (symbol-name container)) + ,(intern (symbol-name target))) + (declare + (ignorable + ,(intern (symbol-name container)) + ,(intern (symbol-name target)))) + ,@body))) diff --git a/src/events/listener-and-interactive.lisp b/src/events/listener-and-interactive.lisp new file mode 100644 index 0000000..fdfe7b3 --- /dev/null +++ b/src/events/listener-and-interactive.lisp @@ -0,0 +1,108 @@ +;;;; 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 &optional (app *application*)) + (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..2876c40 --- /dev/null +++ b/src/events/listener.lisp @@ -0,0 +1,4 @@ +;;;; listener.lisp + +(in-package #:wheelwork) + diff --git a/src/gl/shader.lisp b/src/gl/shader.lisp new file mode 100644 index 0000000..4bba7b8 --- /dev/null +++ b/src/gl/shader.lisp @@ -0,0 +1,42 @@ +;;;; shader.lisp + +(in-package #:wheelwork) + +(defun shader-by-type (type) + (case type + (:vertex :vertex-shader) + (:geometry :geometry-shader) + (:fragment :fragment-shader))) + +(defun gl-shader (type stage) + (let ((shader (gl:create-shader type))) + (gl:shader-source shader (varjo:glsl-code stage)) + (gl:compile-shader shader) + (unless (gl:get-shader shader :compile-status) + (error "failed to compile ~a shader:~%~a~%" + type (gl:get-shader-info-log shader))) + shader)) + +(defun create-shader (&rest sources) + (let* ((stages + (varjo:rolling-translate + (mapcar (lambda (source) + (destructuring-bind (type inputs uniforms code) source + (varjo:make-stage type inputs uniforms '(:330) code))) + sources))) + (shaders + (loop + :for stage :in stages + :for source :in sources + :collect (gl-shader (shader-by-type (car source)) + stage))) + (program (gl:create-program))) + (dolist (shader shaders) (gl:attach-shader program shader)) + (gl:link-program program) + (unless (gl:get-program program :link-status) + (error "failed to link program: ~%~a~%" + (gl:get-program-info-log program))) + (dolist (shader shaders) + (gl:detach-shader program shader) + (gl:delete-shader shader)) + program)) diff --git a/src/gl/texture.lisp b/src/gl/texture.lisp new file mode 100644 index 0000000..ad753a1 --- /dev/null +++ b/src/gl/texture.lisp @@ -0,0 +1,12 @@ +;;;; texture.lisp + +(in-package #:wheelwork) + +(defclass/std texture () + ((width height id mipmap :with :r) + (internal-format image-format :ri :with :std :rgba) + (wrap-s wrap-t :ri :with :std :repeat) + (min-filter mag-filter :ri :with :std :nearest))) + +(defmethod cleanup ((texture texture)) + (gl:delete-texture (texture-id texture))) diff --git a/src/gl/util.lisp b/src/gl/util.lisp new file mode 100644 index 0000000..bff2f88 --- /dev/null +++ b/src/gl/util.lisp @@ -0,0 +1,19 @@ +;;;; gl/util.lisp + +(in-package #:wheelwork) + +(define-symbol-macro +float-size+ + (cffi:foreign-type-size :float)) + +(defun gl-array (type &rest contents) + (let ((array (gl:alloc-gl-array type (length contents)))) + (dotimes (i (length contents) array) + (setf (gl:glaref array i) (elt contents i))))) + +(defmacro with-gl-array ((var type &rest contents) &body body) + `(let ((,var (gl-array ,type ,@contents))) + (unwind-protect (progn ,@body) + (gl:free-gl-array ,var)))) + + + diff --git a/src/interactive-units/bitmap.lisp b/src/interactive-units/bitmap.lisp new file mode 100644 index 0000000..95dfff5 --- /dev/null +++ b/src/interactive-units/bitmap.lisp @@ -0,0 +1,71 @@ +;;;; bitmap.lisp + +(in-package #:wheelwork) + +(defclass/std bitmap (unit 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 new file mode 100644 index 0000000..f439621 --- /dev/null +++ b/src/interactive-units/text.lisp @@ -0,0 +1,91 @@ +;;;; units/text.lisp + +(in-package #:wheelwork) + +(defclass/std text (unit 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 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/package.lisp b/src/package.lisp index 74c9477..74c9477 100644 --- a/package.lisp +++ b/src/package.lisp diff --git a/src/protocol.lisp b/src/protocol.lisp new file mode 100644 index 0000000..52d2525 --- /dev/null +++ b/src/protocol.lisp @@ -0,0 +1,45 @@ +;;;; protocol.lisp + +(in-package #:wheelwork) + +(defgeneric boot (app) + (:documentation "Specialized for each subclass of + APPLICATION. Responsble for setting the app up once the system + resoruces are avaialble.")) + +(defgeneric shutdown (app) + (:documentation "Specialzied for each subclass of + APPLICATION. Called just before cleanup.") + (:method ((any t)) nil)) + +(defgeneric cleanup (thing) + (:documentation "Clean up applications, textures, and other foreign + resources. Called after shutodown.") + (:method ((any t)) nil)) + +(defgeneric drop-unit (unit) + (:documentation "Removes a unit from a container.")) +(defgeneric add-unit (container unit) + (:documentation "Adds a unit to a container, removing it from its + current container first, if necessary.")) + +(defgeneric unit-width (unit)) +(defgeneric unit-height (unit)) +(defgeneric (setf unit-width) (newval unit)) +(defgeneric (setf unit-height) (newval unit)) + +(defgeneric render (thing) + (:documentation "Renders thing for visual display.")) + +(defgeneric model-matrix (thing) + (:documentation "Returns the model matrix for THING, representing + its position, scale, and orientation in the scene")) + +(defgeneric projected-matrix (thing) + (:documentation "Returns the raw array of the model matrix after it + has been prjected by the application's projecion matrix. Used to + pass to GLSL shader programs.")) + +(defgeneric ensure-loaded (asset) + (:documentation "Ensures that the asset is loaded into memory and + ready for use. Returns the asset.")) diff --git a/src/utils.lisp b/src/utils.lisp new file mode 100644 index 0000000..e0f6dcd --- /dev/null +++ b/src/utils.lisp @@ -0,0 +1,9 @@ +;;;; utils.lisp + +(in-package #:wheelwork) + +(define-symbol-macro +pi-over-180+ 0.017453292519943295d0) + +(defun radians (degrees) + "Converse DEGREES to radians" + (* degrees +pi-over-180+)) diff --git a/src/wheelwork.lisp b/src/wheelwork.lisp new file mode 100644 index 0000000..15975fc --- /dev/null +++ b/src/wheelwork.lisp @@ -0,0 +1,259 @@ +;;;; wheelwork.lisp + +(in-package #:wheelwork) + +(defun start (app &key (x :centered) (y :centered)) + (sdl2:with-init (:everything) + (sdl2:gl-set-attr :context-major-version 3) + (sdl2:gl-set-attr :context-minor-version 3) + (sdl2:gl-set-attr :context-profile-mask + sdl2-ffi:+sdl-gl-context-profile-core+) + (sdl2:gl-set-attr :doublebuffer 1) + + (sdl2:with-window (window + :flags '(:shown :opengl) + :title (application-title app) + :w (application-width app) + :h (application-height app) + :x x :y y) + (setf (application-window app) window) + (sdl2:with-gl-context (ctx window) + (sdl2:gl-make-current window ctx) + (gl:viewport 0 0 (application-width app) (application-height app)) + ;(gl:enable :depth-test) + (let ((*application* app)) + (unwind-protect + (progn + (boot app) + (eventloop app) + (shutdown app)) + (cleanup app))))))) + + +(defun refocus-on (target &optional (app *application*)) + "Sets focus of application to TARGET. This works whether or not +TARGET is FOCUSABLEP" + (setf (application-focus app) target)) + +(defun get-focus (&optional (app *application*)) + (or (application-focus app) app)) + +(defun get-handlers-for (unit event-type) + "EVENT-TYPE must be one of the slot value names for WHEELWORK::LISTENER." + (?> (unit) listener #$(slot-value $listener event-type))) + +(defun eventloop-keydown (app sdl-keysym) + (let ((target (get-focus app))) + (when-let (handlers (get-handlers-for target 'keydown)) + (dolist (handler handlers) + (apply handler + target + (sdl2:scancode sdl-keysym) + (sdl2:mod-keywords (sdl2:mod-value sdl-keysym))))))) + +(defun eventloop-keyup (app sdl-keysym) + (let ((target (get-focus app))) + (when-let (handlers (get-handlers-for target 'keyup)) + (dolist (handler handlers) + (apply handler + target + (sdl2:scancode sdl-keysym) + (sdl2:mod-keywords (sdl2:mod-value sdl-keysym))))))) + +(defun get-rect (unit) + "Returns a list of vectors representing the path of the smallest +rectangle that encloses the unit. The rectangle is scaled and rotated." + (with-accessors ((x unit-x) (y unit-y) (w unit-width) (h unit-height) (r unit-rotation)) unit + (let ((m + (mat:meye 4)) + (tr + (vec:vec (+ x (* 0.5 w)) (+ y (* 0.5 h)) 0.0))) + (mat:nmtranslate m tr) + (mat:nmrotate m vec:+vz+ r) + (mat:nmtranslate m (vec:v* -1.0 tr)) + + (list (mat:m* m (vec:vec x y 0.0 1.0)) + (mat:m* m (vec:vec x (+ y h) 0.0 1.0)) + (mat:m* m (vec:vec (+ x w) (+ y h) 0.0 1.0)) + (mat:m* m (vec:vec (+ x w) y 0.0 1.0)) + (mat:m* m (vec:vec x y 0.0 1.0)))))) + +(defun counterclockwisep (a b c) + (> (* (- (vec:vx b) (vec:vx a)) + (- (vec:vy c) (vec:vy a))) + (* (- (vec:vy b) (vec:vy a)) + (- (vec:vx c) (vec:vx a))))) + + +(defun intersectp (a b c d) + (or (vec:v= a c) (vec:v= a d) (vec:v= b c) (vec:v= b d) + (and (not (eq (counterclockwisep a c d) (counterclockwisep b c d))) + (not (eq (counterclockwisep a b c) (counterclockwisep a b d)))))) + +(defun path-bounds (path) + "Path is a list of vectors representing 2d points. Returns the +bounds and width and height as a plist of the form + +(:top N :left N :right N :bottom N :width N :height N) + +This is the smallest UNROTATED RECTANGLE that contains the points in +the path." + (loop + with max-x = nil + and max-y = nil + and min-x = nil + and min-y = nil + for vec in path + for x = (vec:vx vec) + for y = (vec:vy vec) + when (or (null max-x) (< max-x x)) + do (setf max-x x) + when (or (null min-x) (< x min-x)) + do (setf min-x x) + when (or (null max-y) (< max-y y)) + do (setf max-y y) + when (or (null min-y) (< y min-y)) + do (setf min-y y) + finally + (return (list :top max-y :left min-x :right max-x :bottom min-y + :width (- max-x min-x) + :height (- max-y min-y))))) + +(defun contains-point-p (unit px py) + (let* ((pt + (vec:vec px py 0.0 1.0)) + (poly + (get-rect unit)) + (bounds + (path-bounds poly)) + (corner + ;; creating a point guaranteed to be outside of poly + (vec:vec (- (getf bounds :left) (getf bounds :width)) + (- (getf bounds :bottom) (getf bounds :height)) + 0.0 1.0))) + (loop for (p1 p2 . more) on poly + while p2 + when (intersectp p1 p2 pt corner) + count 1 into intersection-count + finally + (progn + (return (oddp intersection-count)))))) + +(defun unit-under (app x y) + (labels + ((finder (thing) + (etypecase thing + (container + (find-if #'finder (container-units thing) :from-end t)) + (unit + (when (contains-point-p thing x y) + (return-from unit-under thing)))))) + (finder app))) + +(defun screen-to-world (x y &optional (app *application*)) + (with-slots (height scale) app + (list (/ x scale) (/ (- height y) scale)))) + +(defun eventloop-mousebuttondown (app wx wy clicks button) + "Searches for a handler to handle applies it if found. + +Additionally, if the APPLICATION's REFOCUS-ON-MOUSEDOWN-P is T, try to +give focus to whatever was clicked." + (destructuring-bind (x y) (screen-to-world wx wy) + (let ((target + (or (unit-under app x y) ; if no unit is under the mouse, + app))) ; then target the app itself + (when (and (refocus-on-mousedown-p app) (focusablep target)) + (refocus-on target)) + (when-let (handlers (get-handlers-for target 'mousedown)) + (dolist (handler handlers) + (funcall handler target x y clicks button wx wy)))))) + +(defun eventloop-mousebuttonup (app wx wy clicks button) + (when (should-listen-for-p 'mouseup app) + (destructuring-bind (x y) (screen-to-world wx wy) + (when-let* ((target (or (unit-under app x y) + app)) + (handlers (get-handlers-for target 'mouseup))) + (dolist (handler handlers) + (funcall handler target x y clicks button wx wy)))))) + +(defun eventloop-mousemotion (app wx wy wxrel wyrel state) + (when (should-listen-for-p 'mousemotion app) + (destructuring-bind (x y) (screen-to-world wx wy) + (destructuring-bind (xrel yrel) (screen-to-world wxrel wyrel) + (when-let* ((target (or (unit-under app x y) + app)) + (handlers (get-handlers-for target 'mousemotion))) + (dolist (handler handlers) + (funcall handler target x y xrel yrel state wx wy wxrel wyrel))))))) + +(defun eventloop-mousewheel (app wx wy dir) + (when (should-listen-for-p 'mousewheel app) + (when-let* ((focus (get-focus app)) + (handlers (get-handlers-for focus 'mousewheel))) + (dolist (handler handlers) + (funcall handler focus wx wy dir))))) + + +(defun eventloop (app) + (sdl2:with-event-loop (:method :poll) + (:mousebuttondown + (:x x :y y :clicks clicks :button button) + (eventloop-mousebuttondown app x y clicks button)) + (:mousemotion + (:x x :y y :xrel xrel :yrel yrel :state state) + (eventloop-mousemotion app x y xrel yrel state)) + (:mousebuttonup + (:x x :y y :clicks clicks :button button) + (eventloop-mousebuttonup app x y clicks button)) + (:keydown + (:keysym keysym) + (eventloop-keydown app keysym)) + (:keyup + (:keysym keysym) + (eventloop-keyup app keysym)) + (:mousewheel + (:x x :y y :direction dir) + (eventloop-mousewheel app x y dir)) + (:idle () (render app)) + (:quit () t))) + + +(defclass/std animation (unit interactive) + ((frames :with :doc "A 2d array of TEXTURE instances. Its dimensiosn are (set-index texture-index)") + (framesets :with :i :r :type integer :std 1 :doc "The number of sets") + (current-frameset current-frame :std 0 :a) + (fps :with :std 1) + (last-frame :with :std (get-universal-time) :a :doc "Time of last frame advance"))) + + +(defun asset-class-for (asset-id &optional (app *application*)) + "Given an asset-id (see GET-ASSET), retrieve the symbol name of a +the class that will be used to instantiate the asset object. That +class should be a subclass of ASSET. Additional clases can be added +to the application's ASSET-CLASSIFIERS association list." + (second (assoc (pathname-type asset-id) (asset-classifiers app) :test #'string-equal))) + +(defun get-asset (asset-id &key (app *application*) asset-args) + "ASSET-ID is a pathname namestring relative to the application's +ASSET-ROOT. GET-ASSET retrieves an already-available asset from the +application's ASSETS table, or, if not available, loads the asset from +disk. + +ASSET-ARGS is a plist to pass to make-instance for the given resource. +" + (or (gethash asset-id (application-assets app)) + (setf (gethash asset-id (application-assets app)) + (ensure-loaded + (apply 'make-instance + (asset-class-for asset-id) + :path (uiop:merge-pathnames* asset-id (asset-root app)) + asset-args))))) + + + + + + + diff --git a/wheelwork.asd b/wheelwork.asd index b1fd2d5..ef3a1a3 100644 --- a/wheelwork.asd +++ b/wheelwork.asd @@ -17,5 +17,26 @@ #:closer-mop #:lambda-riffs #:cl-fond) + :pathname "src/" :components ((:file "package") + (:file "protocol") + (:file "utils") + (:module "gl" + :components ((:file "util") + (:file "texture") + (:file "shader"))) + (:module "assets" + :components ((:file "asset") + (:file "png") + (:file "font"))) + (:module "core-units" + :components ((:file "unit") + (:file "container"))) + (:module "events" + :components ((:file "event-handler") + (:file "listener-and-interactive"))) + (:module "interactive-units" + :components ((:file "bitmap") + (:file "text"))) + (:file "application") (:file "wheelwork"))) diff --git a/wheelwork.lisp b/wheelwork.lisp deleted file mode 100644 index 25b4695..0000000 --- a/wheelwork.lisp +++ /dev/null @@ -1,1129 +0,0 @@ -;;;; wheelwork.lisp - -(in-package #:wheelwork) - -(defvar *application* nil - "current application") - -(defclass/std unit () - ((cached-model cached-projected-matrix :a) - (container :with :a) - (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 scale-x scale-y rotation) - (setf (cached-model unit) nil - (cached-projected-matrix unit) nil)))) - -(defclass/std container () - ((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")) - -(defgeneric drop-unit (unit)) -(defgeneric add-unit (container unit)) - -(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) - - -(defclass/std event-handler () - ((event-type handler-function :ri)) - (:metaclass closer-mop:funcallable-standard-class)) - -(defmethod initialize-instance :after ((eh event-handler) &key) - (with-slots (handler-function) eh - (closer-mop:set-funcallable-instance-function eh handler-function))) - -(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.")) - -(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.")) - -(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)))) - -(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 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)))))) - - - -(defun should-listen-for-p (event-type &optional (app *application*)) - (plusp (hash-table-count (listener-table-for (listener app) event-type)))) - - -(defclass/std application (container interactive) - ((title :with :std "Wheelwork App") - (asset-root :ri :std #P"./" :doc "Directory under which assets are stored.") - (asset-classifiers - :std '(("png" png) ("ttf" font)) - :doc "ALIST of (EXT CLASS). EXT is a string, file estension. CLASS is a symbol, class name.") - (assets :with :a :std (make-hash-table :test 'equal) - :doc "maps asset names to asset instances.") - (scale :with :std 1.0) - (width height :with :std 800) - (projection :with :a :doc "The projection matrix for the scene. Orthographic by default.") - (window :with :a) - (refocus-on-mousedown-p :std t) - (focus last-motion-target :with :a) - (fps :with :std 30 :doc "Frames Per Second") - (frame-wait :r))) - -(defun fps (&optional (app *application*)) - (application-fps app)) - -(defun (setf fps) (new-val &optional (app *application*)) - (setf (application-fps app) new-val)) - -(defun can-set-projection-p (app) - (and (slot-boundp app 'width) - (slot-boundp app 'height) - (slot-boundp app 'scale))) - -(defun set-projection (app) - (when (can-set-projection-p app) - (with-slots (projection scale width height) app - ;; set projection matrix - (setf projection (mat:mortho 0.0 (/ width scale) 0 (/ height scale) -1.0 1.0))))) - -(defmethod initialize-instance :after ((app application) &key) - (set-projection app) - (setf (listener app) (make-instance 'listener))) - -(defun fire-blur-event-on (thing) - (when-let (blur-handlers (and thing (get-handlers-for thing 'blur))) - (dolist (handler blur-handlers) - (funcall handler thing)))) - -(defun fire-focus-event-on (thing) - (when-let (focus-handlers (and thing (get-handlers-for thing 'focus))) - (dolist (handler focus-handlers) - (funcall handler thing)))) - -(defmethod (setf closer-mop:slot-value-using-class ) :before - (new-value class (app application) slot) - (case (closer-mop:slot-definition-name slot) - (focus - (when (slot-boundp app 'focus) - (unless (eq new-value (slot-value app 'focus)) - (fire-blur-event-on (slot-value app 'focus)) - (fire-focus-event-on new-value)))))) - -(defmethod (setf closer-mop:slot-value-using-class) :after - (new-value class (app application) slot) - (case (closer-mop:slot-definition-name slot) - ((scale width height) - (set-projection app)) - (fps - (setf (slot-value app 'frame-wait) (/ 1.0 new-value))))) - - -(defgeneric boot (app) - (:documentation "Specialized for each subclass of - APPLICATION. Responsble for setting the app up once the system - resoruces are avaialble.") - (:method ((app application)) nil)) - -(defgeneric shutdown (app) - (:documentation "Specialzied for each subclass of - APPLICATION. Called just before cleanup.") - (:method ((app application)) nil)) - - -(defgeneric cleanup (thing) - (:documentation "Clean up applications, textures, and so on.") - (:method ((any t)) nil)) - -(defparameter +listener-table-slot-names+ - '(keydown-table keyup-table mousedown-table mouseup-table mousemotion-table - focus-table blur-table perframe-table after-added-table before-added-table - before-dropped-table)) - -(defmethod cleanup ((app application)) - (loop for asset being the hash-value of (application-assets app) - do (cleanup asset)) - ;; drop all current handlers - (let ((listener (listener app))) - (dolist (table +listener-table-slot-names+) - (setf (slot-value listener table) (make-hash-table :synchronized t)))) - (call-next-method)) - -(defmethod cleanup ((container container)) - (dolist (u (container-units container)) - (cleanup u))) - -(defun start (app &key (x :centered) (y :centered)) - (sdl2:with-init (:everything) - (sdl2:gl-set-attr :context-major-version 3) - (sdl2:gl-set-attr :context-minor-version 3) - (sdl2:gl-set-attr :context-profile-mask - sdl2-ffi:+sdl-gl-context-profile-core+) - (sdl2:gl-set-attr :doublebuffer 1) - - (sdl2:with-window (window - :flags '(:shown :opengl) - :title (application-title app) - :w (application-width app) - :h (application-height app) - :x x :y y) - (setf (application-window app) window) - (sdl2:with-gl-context (ctx window) - (sdl2:gl-make-current window ctx) - (gl:viewport 0 0 (application-width app) (application-height app)) - ;(gl:enable :depth-test) - (let ((*application* app)) - (unwind-protect - (progn - (boot app) - (eventloop app) - (shutdown app)) - (cleanup app))))))) - -(defun run-perframe (app) - (let ((table (perframe-table (listener app))) - (time (get-universal-time))) - (loop for target being the hash-key of table - for handlers = (slot-value (listener target) 'perframe) - ;; only fire perframe when target is in scene - when (or (eq app target) (unit-container target)) - do (loop for handler in handlers do (funcall handler target time))))) - -(defgeneric render (thing)) -(defmethod render ((app application)) - (run-perframe app) - (gl:clear-color 0.0 0.0 0.0 1.0) - ;(gl:clear :depth-buffer-bit :color-buffer-bit) - (gl:clear :color-buffer-bit) - (gl:enable :blend) - (gl:blend-func :src-alpha :one-minus-src-alpha ) - (dolist (thing (container-units app)) - (render thing)) - (sdl2:gl-swap-window (application-window app)) - (sleep (frame-wait app))) - -(defgeneric model-matrix (thing) - (:documentation "Returns the model matrix")) - -(defgeneric projected-matrix (thing) - (:documentation "Returns the raw array of the model matrix after it - has been prjected by the application's projecion matrix")) - -(defmethod model-matrix :around ((u unit)) - (or (cached-model u) - (setf (cached-model u) - (call-next-method)))) - -(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) - (setf (cached-projected-matrix thing) - (mat:marr (mat:m* (application-projection *application*) - (model-matrix thing)))))) - -(defgeneric ensure-loaded (asset) - (:documentation "Ensures that the asset is loaded into memory and ready for use. Returns the asset.")) - -(defclass/std asset () - ((path :with :ri :std (error "An asset requires a path")) - (loadedp :with :a))) - -(defmethod cleanup :around ((asset asset)) - (when (asset-loadedp asset) - (call-next-method)) - (setf (asset-loadedp asset) nil)) - -(defmethod ensure-loaded :around ((thing asset)) - (unless (asset-loadedp thing) - (call-next-method) - (setf (asset-loadedp thing) t)) - thing) - -(defclass/std texture () - ((width height id mipmap :with :r) - (internal-format image-format :ri :with :std :rgba) - (wrap-s wrap-t :ri :with :std :repeat) - (min-filter mag-filter :ri :with :std :nearest))) - -(defmethod cleanup ((texture texture)) - (gl:delete-texture (texture-id texture))) - -(defclass/std png (asset texture) ()) - -(defmethod ensure-loaded ((png png)) - (with-slots - (width height id wrap-s wrap-t min-filter mag-filter internal-format image-format) - png - (pngload:with-png-in-static-vector (data (asset-path png) :flip-y t) - (setf width (pngload:width data) - height (pngload:height data) - id (gl:gen-texture)) - (gl:bind-texture :texture-2d id) - (gl:tex-parameter :texture-2d :texture-wrap-s wrap-s) - (gl:tex-parameter :texture-2d :texture-wrap-t wrap-t) - (gl:tex-parameter :texture-2d :texture-min-filter min-filter) - (gl:tex-parameter :texture-2d :texture-mag-filter mag-filter) - (gl:tex-image-2d :texture-2d - 0 - internal-format - width - height - 0 - image-format - :unsigned-byte - (pngload:data data)) - (gl:bind-texture :texture-2d 0) - (when (texture-mipmap png) - (gl:generate-mipmap :texture-2d))))) - - -(defun refocus-on (target &optional (app *application*)) - "Sets focus of application to TARGET. This works whether or not -TARGET is FOCUSABLEP" - (setf (application-focus app) target)) - -(defun get-focus (&optional (app *application*)) - (or (application-focus app) app)) - -(defun get-handlers-for (unit event-type) - "EVENT-TYPE must be one of the slot value names for WHEELWORK::LISTENER." - (?> (unit) listener #$(slot-value $listener event-type))) - -(defun eventloop-keydown (app sdl-keysym) - (let ((target (get-focus app))) - (when-let (handlers (get-handlers-for target 'keydown)) - (dolist (handler handlers) - (apply handler - target - (sdl2:scancode sdl-keysym) - (sdl2:mod-keywords (sdl2:mod-value sdl-keysym))))))) - -(defun eventloop-keyup (app sdl-keysym) - (let ((target (get-focus app))) - (when-let (handlers (get-handlers-for target 'keyup)) - (dolist (handler handlers) - (apply handler - target - (sdl2:scancode sdl-keysym) - (sdl2:mod-keywords (sdl2:mod-value sdl-keysym))))))) - -(defun get-rect (unit) - "Returns a list of vectors representing the path of the smallest -rectangle that encloses the unit. The rectangle is scaled and rotated." - (with-accessors ((x unit-x) (y unit-y) (w unit-width) (h unit-height) (r unit-rotation)) unit - (let ((m - (mat:meye 4)) - (tr - (vec:vec (+ x (* 0.5 w)) (+ y (* 0.5 h)) 0.0))) - (mat:nmtranslate m tr) - (mat:nmrotate m vec:+vz+ r) - (mat:nmtranslate m (vec:v* -1.0 tr)) - - (list (mat:m* m (vec:vec x y 0.0 1.0)) - (mat:m* m (vec:vec x (+ y h) 0.0 1.0)) - (mat:m* m (vec:vec (+ x w) (+ y h) 0.0 1.0)) - (mat:m* m (vec:vec (+ x w) y 0.0 1.0)) - (mat:m* m (vec:vec x y 0.0 1.0)))))) - -(defun counterclockwisep (a b c) - (> (* (- (vec:vx b) (vec:vx a)) - (- (vec:vy c) (vec:vy a))) - (* (- (vec:vy b) (vec:vy a)) - (- (vec:vx c) (vec:vx a))))) - - -(defun intersectp (a b c d) - (or (vec:v= a c) (vec:v= a d) (vec:v= b c) (vec:v= b d) - (and (not (eq (counterclockwisep a c d) (counterclockwisep b c d))) - (not (eq (counterclockwisep a b c) (counterclockwisep a b d)))))) - -(defun path-bounds (path) - "Path is a list of vectors representing 2d points. Returns the -bounds and width and height as a plist of the form - -(:top N :left N :right N :bottom N :width N :height N) - -This is the smallest UNROTATED RECTANGLE that contains the points in -the path." - (loop - with max-x = nil - and max-y = nil - and min-x = nil - and min-y = nil - for vec in path - for x = (vec:vx vec) - for y = (vec:vy vec) - when (or (null max-x) (< max-x x)) - do (setf max-x x) - when (or (null min-x) (< x min-x)) - do (setf min-x x) - when (or (null max-y) (< max-y y)) - do (setf max-y y) - when (or (null min-y) (< y min-y)) - do (setf min-y y) - finally - (return (list :top max-y :left min-x :right max-x :bottom min-y - :width (- max-x min-x) - :height (- max-y min-y))))) - -(defun contains-point-p (unit px py) - (let* ((pt - (vec:vec px py 0.0 1.0)) - (poly - (get-rect unit)) - (bounds - (path-bounds poly)) - (corner - ;; creating a point guaranteed to be outside of poly - (vec:vec (- (getf bounds :left) (getf bounds :width)) - (- (getf bounds :bottom) (getf bounds :height)) - 0.0 1.0))) - (loop for (p1 p2 . more) on poly - while p2 - when (intersectp p1 p2 pt corner) - count 1 into intersection-count - finally - (progn - (return (oddp intersection-count)))))) - -(defun unit-under (app x y) - (labels - ((finder (thing) - (etypecase thing - (container - (find-if #'finder (container-units thing) :from-end t)) - (unit - (when (contains-point-p thing x y) - (return-from unit-under thing)))))) - (finder app))) - -(defun screen-to-world (x y &optional (app *application*)) - (with-slots (height scale) app - (list (/ x scale) (/ (- height y) scale)))) - -(defun eventloop-mousebuttondown (app wx wy clicks button) - "Searches for a handler to handle applies it if found. - -Additionally, if the APPLICATION's REFOCUS-ON-MOUSEDOWN-P is T, try to -give focus to whatever was clicked." - (destructuring-bind (x y) (screen-to-world wx wy) - (let ((target - (or (unit-under app x y) ; if no unit is under the mouse, - app))) ; then target the app itself - (when (and (refocus-on-mousedown-p app) (focusablep target)) - (refocus-on target)) - (when-let (handlers (get-handlers-for target 'mousedown)) - (dolist (handler handlers) - (funcall handler target x y clicks button wx wy)))))) - -(defun eventloop-mousebuttonup (app wx wy clicks button) - (when (should-listen-for-p 'mouseup app) - (destructuring-bind (x y) (screen-to-world wx wy) - (when-let* ((target (or (unit-under app x y) - app)) - (handlers (get-handlers-for target 'mouseup))) - (dolist (handler handlers) - (funcall handler target x y clicks button wx wy)))))) - -(defun eventloop-mousemotion (app wx wy wxrel wyrel state) - (when (should-listen-for-p 'mousemotion app) - (destructuring-bind (x y) (screen-to-world wx wy) - (destructuring-bind (xrel yrel) (screen-to-world wxrel wyrel) - (when-let* ((target (or (unit-under app x y) - app)) - (handlers (get-handlers-for target 'mousemotion))) - (dolist (handler handlers) - (funcall handler target x y xrel yrel state wx wy wxrel wyrel))))))) - -(defun eventloop-mousewheel (app wx wy dir) - (when (should-listen-for-p 'mousewheel app) - (when-let* ((focus (get-focus app)) - (handlers (get-handlers-for focus 'mousewheel))) - (dolist (handler handlers) - (funcall handler focus wx wy dir))))) - - -(defun eventloop (app) - (sdl2:with-event-loop (:method :poll) - (:mousebuttondown - (:x x :y y :clicks clicks :button button) - (eventloop-mousebuttondown app x y clicks button)) - (:mousemotion - (:x x :y y :xrel xrel :yrel yrel :state state) - (eventloop-mousemotion app x y xrel yrel state)) - (:mousebuttonup - (:x x :y y :clicks clicks :button button) - (eventloop-mousebuttonup app x y clicks button)) - (:keydown - (:keysym keysym) - (eventloop-keydown app keysym)) - (:keyup - (:keysym keysym) - (eventloop-keyup app keysym)) - (:mousewheel - (:x x :y y :direction dir) - (eventloop-mousewheel app x y dir)) - (:idle () (render app)) - (:quit () t))) - -(defclass/std bitmap (unit interactive) - ((texture :ri :std (error "A bitmap requires a texture.")) - (vao shader :with :r :static))) - -(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))) - -(defun shader-by-type (type) - (case type - (:vertex :vertex-shader) - (:geometry :geometry-shader) - (:fragment :fragment-shader))) - -(defun gl-shader (type stage) - (let ((shader (gl:create-shader type))) - (gl:shader-source shader (varjo:glsl-code stage)) - (gl:compile-shader shader) - (unless (gl:get-shader shader :compile-status) - (error "failed to compile ~a shader:~%~a~%" - type (gl:get-shader-info-log shader))) - shader)) - -(defun create-shader (&rest sources) - (let* ((stages - (varjo:rolling-translate - (mapcar (lambda (source) - (destructuring-bind (type inputs uniforms code) source - (varjo:make-stage type inputs uniforms '(:330) code))) - sources))) - (shaders - (loop - :for stage :in stages - :for source :in sources - :collect (gl-shader (shader-by-type (car source)) - stage))) - (program (gl:create-program))) - (dolist (shader shaders) (gl:attach-shader program shader)) - (gl:link-program program) - (unless (gl:get-program program :link-status) - (error "failed to link program: ~%~a~%" - (gl:get-program-info-log program))) - (dolist (shader shaders) - (gl:detach-shader program shader) - (gl:delete-shader shader)) - program)) - - -(defun gl-array (type &rest contents) - (let ((array (gl:alloc-gl-array type (length contents)))) - (dotimes (i (length contents) array) - (setf (gl:glaref array i) (elt contents i))))) - -(defmacro with-gl-array ((var type &rest contents) &body body) - `(let ((,var (gl-array ,type ,@contents))) - (unwind-protect (progn ,@body) - (gl:free-gl-array ,var)))) - - -(define-symbol-macro +float-size+ - (cffi:foreign-type-size :float)) - -(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 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))) - - -(defun asset-class-for (asset-id &optional (app *application*)) - "Given an asset-id (see GET-ASSET), retrieve the symbol name of a -the class that will be used to instantiate the asset object. That -class should be a subclass of ASSET. Additional clases can be added -to the application's ASSET-CLASSIFIERS association list." - (second (assoc (pathname-type asset-id) (asset-classifiers app) :test #'string-equal))) - -(defun get-asset (asset-id &key (app *application*) asset-args) - "ASSET-ID is a pathname namestring relative to the application's -ASSET-ROOT. GET-ASSET retrieves an already-available asset from the -application's ASSETS table, or, if not available, loads the asset from -disk. - -ASSET-ARGS is a plist to pass to make-instance for the given resource. -" - (or (gethash asset-id (application-assets app)) - (setf (gethash asset-id (application-assets app)) - (ensure-loaded - (apply 'make-instance - (asset-class-for asset-id) - :path (uiop:merge-pathnames* asset-id (asset-root app)) - asset-args))))) - -(define-symbol-macro +standard-font-chars+ - " -ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz01234567890\".,!?-'" ) - -(defclass/std font (asset) - ((characters :i :std +standard-font-chars+) - (oversample :i :doc "ovesampling factor to pass to cl-fond:make-font") - (object :with :r :doc "The font as returned from cl-fond:make-font"))) - -(defmethod ensure-loaded ((font font)) - (with-slots (path characters oversample object) font - (setf object (cl-fond:make-font path characters :oversample oversample)))) - - -(defclass/std text (unit 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 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))) - - - - -(defmacro defhandler (name handler) - "Defines a handler - binds (FDEFINITION NAME) to HANDLER, which -should be an expression that evaluates to an instance of -EVENT-HANDLER, which is funcallable. It is define such that handlers -can be redefined using this form to support interactive development." - (let ((handler-var (gensym))) - `(let ((,handler-var ,handler)) - (if-let (extant (and (fboundp ',name) - (fdefinition ',name))) - (closer-mop:set-funcallable-instance-function extant (handler-function ,handler-var)) - (setf (fdefinition ',name) ,handler-var))))) - - -(defmacro on-perframe - ((&optional (target 'target) (time 'time)) &body body) - "Creates a handler for 'PERFRAME events" - `(make-instance - 'event-handler - :event-type 'wheelwork::perframe - :handler-function (lambda (,(intern (symbol-name target)) - ,(intern (symbol-name time))) - (declare (ignorable ,(intern (symbol-name target)) - ,(time (intern (symbol-name time))))) - ,@body))) - -(defmacro on-keydown - ((&optional (target 'target) (scancode 'scancode) (modifiers 'modifiers)) &body body) - "Creates a lambda suitable for the value of a keydown event - handler. The function accepts two positional arguments TARGET and - SCANCODE and one &REST argument MODIFIERS. - - SCANCODE will be a keyword of the form :SCANCODE-A, :SCANCODE-B ... - - The members of MODIFIERS look like :LSHIFT, :RCTRL, RALT, etc" - `(make-instance - 'event-handler - :event-type 'wheelwork::keydown - :handler-function (lambda (,(intern (symbol-name target)) - ,(intern (symbol-name scancode)) - &rest ,(intern (symbol-name modifiers))) - (declare (ignorable ,(intern (symbol-name target)) - ,(intern (symbol-name scancode)) - ,(intern (symbol-name modifiers)))) - ,@body))) - -(defmacro on-keyup - ((&optional (target 'target) (scancode 'scancode) (modifiers 'modifiers)) &body body) - "Creates a lambda suitable for the value of a keyup event - handler. The function accepts two positional arguments TARGET and - SCANCODE and one &REST argument MODIFIERS. - - SCANCODE will be a keyword of the form :SCANCODE-A, :SCANCODE-B ... - - The members of MODIFIERS look like :LSHIFT, :RCTRL, RALT, etc" - `(make-instance - 'event-handler - :event-type 'wheelwork::keyup - :handler-function (lambda (,(intern (symbol-name target)) - ,(intern (symbol-name scancode)) - &rest ,(intern (symbol-name modifiers))) - (declare (ignorable ,(intern (symbol-name target)) - ,(intern (symbol-name scancode)) - ,(intern (symbol-name modifiers)))) - ,@body))) - -(defmacro on-mousemotion - ((&optional - (target 'target) - (x 'x) (y 'y) - (xrel 'xrel) (yrel 'yrel) - (state 'state) - (win-x 'win-x) (win-y 'win-y) - (win-xrel 'win-xrel) (win-yrel 'win-yrel)) - &body body) - "Creates a handler for MOUSEMOTION events" - `(make-instance - 'event-handler - :event-type 'wheelwork::mousemotion - :handler-function (lambda (,(intern (symbol-name target)) - ,(intern (symbol-name x)) - ,(intern (symbol-name y)) - ,(intern (symbol-name xrel)) - ,(intern (symbol-name yrel)) - ,(intern (symbol-name state)) - ,(intern (symbol-name win-x)) - ,(intern (symbol-name win-y)) - ,(intern (symbol-name win-xrel)) - ,(intern (symbol-name win-yrel))) - (declare (ignorable ,(intern (symbol-name target)) - ,(intern (symbol-name x)) - ,(intern (symbol-name y)) - ,(intern (symbol-name xrel)) - ,(intern (symbol-name yrel)) - ,(intern (symbol-name state)) - ,(intern (symbol-name win-x)) - ,(intern (symbol-name win-y)) - ,(intern (symbol-name win-xrel)) - ,(intern (symbol-name win-yrel)))) - ,@body))) - -(defmacro on-mousedown - ((&optional (target 'target) - (x 'x) (y 'y) - (clicks 'clicks) (button 'button) - (win-x 'win-x) (win-y 'win-y)) - &body body) - "Creates a handler for MOUSEDOWN events" - `(make-instance - 'event-handler - :event-type 'wheelwork::mousedown - :handler-function (lambda - (,(intern (symbol-name target)) - ,(intern (symbol-name x)) - ,(intern (symbol-name y)) - ,(intern (symbol-name clicks)) - ,(intern (symbol-name button)) - ,(intern (symbol-name win-x)) - ,(intern (symbol-name win-y))) - (declare - (ignorable ,(intern (symbol-name target)) - ,(intern (symbol-name x)) - ,(intern (symbol-name y)) - ,(intern (symbol-name clicks)) - ,(intern (symbol-name button)) - ,(intern (symbol-name win-x)) - ,(intern (symbol-name win-y)))) - ,@body))) - -(defmacro on-mouseup - ((&optional (target 'target) - (x 'x) (y 'y) - (clicks 'clicks) (button 'button) - (win-x 'win-x) (win-y 'win-y)) - &body body) - "Creates a handler for MOUSEUP events" - `(make-instance - 'event-handler - :event-type 'wheelwork::mouseup - :handler-function (lambda - (,(intern (symbol-name target)) - ,(intern (symbol-name x)) - ,(intern (symbol-name y)) - ,(intern (symbol-name clicks)) - ,(intern (symbol-name button)) - ,(intern (symbol-name win-x)) - ,(intern (symbol-name win-y))) - (declare - (ignorable ,(intern (symbol-name target)) - ,(intern (symbol-name x)) - ,(intern (symbol-name y)) - ,(intern (symbol-name clicks)) - ,(intern (symbol-name button)) - ,(intern (symbol-name win-x)) - ,(intern (symbol-name win-y)))) - ,@body))) - -(defmacro on-mousewheel - ((&optional (target 'target) (horiz 'horiz) (vert 'vert) (dir 'dir)) &body body) - "Creates a handler for MOUSEWHEEL events" - `(make-instance - 'event-handler - :event-type 'wheelwork::mousewheel - :handler-function (lambda - (,(intern (symbol-name target)) - ,(intern (symbol-name horiz)) - ,(intern (symbol-name vert)) - ,(intern (symbol-name dir))) - (declare - (ignorable ,(intern (symbol-name target)) - ,(intern (symbol-name horiz)) - ,(intern (symbol-name vert)) - ,(intern (symbol-name dir)))) - ,@body))) - -(defmacro on-blur - ((&optional (target 'target)) &body body) - "Creates a handler for BLUR events. BLUR is a psuedo event that -fires whenever an object loses focus." - `(make-instance - 'event-handler - :event-type 'wheelwork::blur - :handler-function (lambda - (,(intern (symbol-name target))) - (declare - (ignorable ,(intern (symbol-name target)))) - ,@body))) - -(defmacro on-focus - ((&optional (target 'target)) &body body) - "Creates a handler for a FOCUS event. FOCUS is a pusedo event that -fires when the FOCUS slot of the current APPLICATION instance is changed. -" - `(make-instance - 'event-handler - :event-type 'wheelwork::focus - :handler-function (lambda - (,(intern (symbol-name target))) - (declare - (ignorable ,(intern (symbol-name target)))) - ,@body))) - -(defmacro on-before-dropped - ((&optional (target 'target)) &body body) - "Creates a handler for BEFORE-DROPPED events, which fire before a - unit is removed from its container." - `(make-instance - 'event-handler - :event-type 'wheelwork::before-dropped - :handler-function (lambda - (,(intern (symbol-name target))) - (declare - (ignorable ,(intern (symbol-name target)))) - ,@body))) - -(defmacro on-before-added - ((&optional (container 'container) (target 'target)) &body body) - "Creates a handler for BEFORE-ADDED events, which fire before a unit - is added to a container." - `(make-instance - 'event-handler - :event-type 'wheelwork::before-added - :handler-function (lambda - (,(intern (symbol-name container)) - ,(intern (symbol-name target))) - (declare - (ignorable - ,(intern (symbol-name container)) - ,(intern (symbol-name target)))) - ,@body))) - - -(defmacro on-after-added - ((&optional (container 'container) (target 'target)) &body body) - "Creates a handler for AFTER-ADDED events, which fire after a unit - is added to a container." - `(make-instance - 'event-handler - :event-type 'wheelwork::after-added - :handler-function (lambda - (,(intern (symbol-name container)) - ,(intern (symbol-name target))) - (declare - (ignorable - ,(intern (symbol-name container)) - ,(intern (symbol-name target)))) - ,@body))) - -;;; Utility - -(define-symbol-macro +pi-over-180+ 0.017453292519943295d0) - -(defun radians (degrees) - "Converse DEGREES to radians" - (* degrees +pi-over-180+)) - |