path: root/src/wheelwork.lisp

;;;; wheelwork.lisp

(in-package #:wheelwork)

(defvar *application* nil
  "current application")

(defgeneric add-unit (unit))

(defmethod add-unit ((unit unit))
  "Adds a unit to the display."
  (vector-push-extend unit (application-scene *application*) (1+ (length (application-scene *application*))))
  (setf (unit-in-scene-p unit) t))

(defgeneric drop-unit (unit))
(defmethod drop-unit ((unit unit))
  "A removes a unit from the display."
  (setf (unit-in-scene-p unit) nil)
  (setf (application-scene *application*)
        (delete unit (application-scene *application*))))

(defun drop-unit-if (predicate)
  "Removes all units from scene that satisfy the predicate."
  (setf (application-scene *application*)
        (delete-if predicate (application-scene *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 stop ()
  (sdl2:push-event :quit))

(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 region-contains-point-p (region x y)
  (with-slots (left right bottom top) region
    (and (<= left x right)
         (<= bottom y top))))

(defun unit-contains-point-p (unit x y)
  (path-encloses-point-p (get-rect unit) x y))

(defun mouse-event-targets (app x y &optional bubblep)
  "Returns a list of one or more objects found under the x y
position.  The list always contains the app itself as the last element."
  (nconc (if bubblep
             (all-units-under app x y)
             (unit-under app x y))
         (list app)))


(defun unit-visibly-contains-p (unit x y)
  (and (unit-visiblep unit)
       (region-contains-point-p (unit-region unit) x y) 
       (unit-contains-point-p unit x y)))

(defun unit-under (app x y)
  "Finds the visible unit that contains the point x y, returns it as a
single elemtn list, or nil if none found"
  (with-slots (scene) app 
    (loop
      for idx from (1- (length scene)) downto 0 
      for u = (elt scene idx)
      when (unit-visibly-contains-p u x y)
        return (list u))))

(defun all-units-under (app x y)
  "Finds all units under the point x y"
  (with-slots (scene) app 
    (loop
      for idx from (1- (length scene)) downto 0 
      for u = (elt scene idx)
      when (unit-visibly-contains-p u x y)
        collect u)))

(defvar *event-still-bubbling-p* nil
  "Controls whether an event is bubbling")

(defun stop-bubbling ()
  (setf *event-still-bubbling-p* nil))


(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"
  (declare (optimize (speed 3) (saftey 0)))
  (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 ((candidate-targets
            (mouse-event-targets app x y (mouse-button-events-bubble-p app))))  
      ;; refocus always occurs on the "top" focasable thing
      (when (and (refocus-on-mousedown-p app)
                 (focusablep (first candidate-targets)))
        (refocus-on (first candidate-targets)))              
      (let ((*event-still-bubbling-p*
              (mouse-button-events-bubble-p app))) 
        (loop for target in candidate-targets
              do
                 (dolist (handler (get-handlers-for target 'mousedown)) 
                   (funcall handler target x y clicks button wx wy))
              while *event-still-bubbling-p*)))))

(defun eventloop-mousebuttonup (app wx wy clicks button)
  (when (should-listen-for-p 'mouseup app)
    (destructuring-bind (x y) (screen-to-world wx wy)
      (let ((*event-still-bubbling-p*
              (mouse-button-events-bubble-p app))) 
        (loop for target in (mouse-event-targets app x y (mouse-button-events-bubble-p app))
              do 
                (dolist (handler (get-handlers-for target 'mouseup)) 
                  (funcall handler target x y clicks button wx wy))
              while *event-still-bubbling-p*)))))

(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)
      (let* ((scale (application-scale app))
             (xrel (/ wxrel scale))
             (yrel (* -1 (/ wyrel scale))))
        (let ((*event-still-bubbling-p*
                (mouse-motion-events-bubble-p app))) 
          (loop for target in (mouse-event-targets app x y (mouse-motion-events-bubble-p app))
                do 
                  (dolist (handler (get-handlers-for target 'mousemotion)) 
                    (funcall handler target x y xrel yrel state wx wy wxrel wyrel))
                while *event-still-bubbling-p*))))))

(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)
  (declare (optimize (speed 3) (safety 0)))
  (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)))))