1 files changed, 259 insertions, 0 deletions
diff --git a/src/wheelwork.lisp b/src/wheelwork.lisp
new file mode 100644
index 0000000..15975fc
--- /dev/null
+++ b/src/wheelwork.lisp
@@ -0,0 +1,259 @@
+;;;; wheelwork.lisp
+
+(in-package #:wheelwork)
+
+(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 unit-x) (y unit-y) (w unit-width) (h unit-height) (r unit-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)))))
+
+
+
+
+
+
+