From 82f71b0d13788b1cff9a24c5b652effd11631523 Mon Sep 17 00:00:00 2001 From: Colin Okay Date: Wed, 29 Jun 2022 11:54:24 -0500 Subject: [refactor] [structure] modularized project file structure --- wheelwork.lisp | 1129 -------------------------------------------------------- 1 file changed, 1129 deletions(-) delete mode 100644 wheelwork.lisp (limited to 'wheelwork.lisp') 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+)) - -- cgit v1.2.3