;;;; 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 unit-contains-point-p (unit pt)
  (path-encloses-point-p (get-rect unit) pt))

(defun unit-under (app x y)
  "Finds the visible unit that contains the point x y."
  (let ((xy (vec:vec x y 0.0 1.0))) 
    (labels
        ((finder (thing)
           (when (unit-visiblep thing) 
             (etypecase thing
               (container
                (when (unit-contains-point-p thing xy)
                  (find-if #'finder (container-units thing) :from-end t)))
               (unit
                (when (unit-contains-point-p thing xy)
                  (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)))))