;;;; 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
              (when (contains-point-p thing x y)
               (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)))))