;;;; wheelwork.lisp (in-package #:wheelwork) (defvar *application* nil "current application") (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) (gl:enable :scissor-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." (when-let (listener (listener unit)) (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 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) "Finds the visible unit that contains the point x y." (labels ((finder (thing) (when (unit-visiblep 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*)) "Scales the screen point - the literal pixel position relative to the top corner of the application window - to reflect the application's scaling factor." (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))) (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)))))