path: root/src/wheelwork.lisp

;;;; 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)
        (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."
  (?> (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 x) (y y) (w unit-width) (h unit-height) (r 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 animation (unit interactive)
  ((frames :with :doc "A 2d array of TEXTURE instances. Its dimensiosn are (set-index texture-index)")
   (framesets :with :i :r :type integer :std 1 :doc "The number of sets")
   (current-frameset current-frame :std 0 :a)
   (fps :with :std 1)
   (last-frame :with :std (get-universal-time) :a :doc "Time of last frame advance")))


(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)))))

(defun fps (&optional (app *application*))
  (application-fps app))

(defun (setf fps) (new-val &optional (app *application*))
  (setf (application-fps app) new-val))