aboutsummaryrefslogtreecommitdiffhomepage
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/application.lisp108
-rw-r--r--src/assets/asset.lisp18
-rw-r--r--src/assets/font.lisp17
-rw-r--r--src/assets/png.lisp31
-rw-r--r--src/core-units/container.lisp32
-rw-r--r--src/core-units/unit.lisp71
-rw-r--r--src/events/event-handler.lisp260
-rw-r--r--src/events/listener-and-interactive.lisp108
-rw-r--r--src/events/listener.lisp4
-rw-r--r--src/gl/shader.lisp42
-rw-r--r--src/gl/texture.lisp12
-rw-r--r--src/gl/util.lisp19
-rw-r--r--src/interactive-units/bitmap.lisp71
-rw-r--r--src/interactive-units/text.lisp91
-rw-r--r--src/package.lisp11
-rw-r--r--src/protocol.lisp45
-rw-r--r--src/utils.lisp9
-rw-r--r--src/wheelwork.lisp259
18 files changed, 1208 insertions, 0 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/src/package.lisp b/src/package.lisp
new file mode 100644
index 0000000..74c9477
--- /dev/null
+++ b/src/package.lisp
@@ -0,0 +1,11 @@
+;;;; package.lisp
+
+(defpackage #:wheelwork
+ (:use #:cl)
+ (:nicknames #:ww)
+ (:local-nicknames (#:mat #:3d-matrices)
+ (#:vec #:3d-vectors))
+ (:import-from #:hyperquirks #:?>)
+ (:import-from #:defclass-std #:defclass/std)
+ (:import-from #:alexandria
+ #:when-let #:when-let* #:if-let))
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)))))
+
+
+
+
+
+
+
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-23 13:56:51 +0000