diff options
| -rw-r--r-- | src/application.lisp | 13 | ||||
| -rw-r--r-- | src/core/affine.lisp | 26 | ||||
| -rw-r--r-- | src/core/container.lisp | 52 | ||||
| -rw-r--r-- | src/core/unit.lisp | 9 | ||||
| -rw-r--r-- | src/interactive/button.lisp | 89 | ||||
| -rw-r--r-- | src/interactive/frameset.lisp | 3 | ||||
| -rw-r--r-- | src/interactive/sprite.lisp | 3 | ||||
| -rw-r--r-- | src/protocol.lisp | 4 | ||||
| -rw-r--r-- | src/utils.lisp | 48 | ||||
| -rw-r--r-- | src/wheelwork.lisp | 80 | ||||
| -rw-r--r-- | wheelwork.asd | 1 |
11 files changed, 178 insertions, 150 deletions
diff --git a/src/application.lisp b/src/application.lisp index d38cd8a..d2da8ef 100644 --- a/src/application.lisp +++ b/src/application.lisp @@ -3,7 +3,6 @@ (in-package #:wheelwork) - (defclass/std application (container interactive) ((title :with :std "Wheelwork App") (asset-root :ri :std #P"./" :doc "Directory under which assets are stored.") @@ -21,7 +20,6 @@ (fps :std 30 :doc "Frames Per Second") (frame-wait :r))) - (defun can-set-projection-p (app) (and (slot-boundp app 'width) (slot-boundp app 'height) @@ -35,7 +33,13 @@ (defmethod initialize-instance :after ((app application) &key) (set-projection app) - (setf (listener app) (make-instance 'listener))) + (with-slots (listener left right top bottom scale width height) app + (setf listener (make-instance 'listener) + left 0 + bottom 0 + top (/ height scale) + right (/ width scale) + ))) (defun fire-blur-event-on (thing) (when-let (blur-handlers (and thing (get-handlers-for thing 'blur))) @@ -96,7 +100,6 @@ those objects are currently part of the scene tree." (gl:clear :color-buffer-bit) (gl:enable :blend) (gl:blend-func :src-alpha :one-minus-src-alpha ) - (dolist (thing (container-units app)) - (render thing)) + (call-next-method) (sdl2:gl-swap-window (application-window app)) (sleep (frame-wait app))) diff --git a/src/core/affine.lisp b/src/core/affine.lisp index 7c87d16..7cfb805 100644 --- a/src/core/affine.lisp +++ b/src/core/affine.lisp @@ -3,7 +3,7 @@ (in-package #:wheelwork) (defclass/std affine (unit) - ((cached-model cached-projected-matrix cached-application :a) + ((cached-model cached-projected-matrix cached-application cached-rectangle :a) (base-width base-height :r :std 1.0 :doc "Determined by content.") (scale-x scale-y :std 1.0) (rotation x y :std 0.0))) @@ -13,9 +13,8 @@ (case (closer-mop:slot-definition-name slot) ((x y scale-x scale-y rotation) (setf (cached-model affine) nil - (cached-projected-matrix affine) nil)))) - - + (cached-projected-matrix affine) nil + (cached-rectangle affine) nil)))) (defun scale-by (affine amount) (with-accessors ((sx scale-x) (sy scale-y)) affine @@ -69,3 +68,22 @@ (setf (cached-projected-matrix affine) (mat:marr (mat:m* (application-projection (app-of-unit affine)) (model-matrix affine)))))) + +(defmethod get-rect ((affine-unit affine)) + (or (cached-rectangle affine-unit) + (setf (cached-rectangle affine-unit) + (with-accessors ((x x) (y y) (w width) (h height) (r rotation)) affine-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)))))))) + diff --git a/src/core/container.lisp b/src/core/container.lisp index af01ff1..1410310 100644 --- a/src/core/container.lisp +++ b/src/core/container.lisp @@ -4,11 +4,46 @@ (defclass/std container (unit) - ((units :with :a)) + ((units :with :a) + (cached-rect :with) + (left right top bottom :with :std 0 :doc "container's box coordinates.")) (:documentation "Just a list of units. Made into a class so that transformation affine transformations methods can be specialzied on whole groups of units")) +(defmethod (setf closer-mop:slot-value-using-class) + (newval class (container container) slot) + (case (closer-mop:slot-definition-name slot) + ((left right top bottom) + (setf (container-cached-rect container) nil)))) + +(defmethod get-rect ((container container)) + (with-slots (cached-rect left right top bottom) container + (or cached-rect + (setf cached-rect + (list* (vec:vec left bottom 0 1.0) + (vec:vec left top 0 1.0) + (vec:vec right top 0 1.0) + (vec:vec right bottom 0 1.0) + (vec:vec left bottom 0 1.0)))))) + + +(defun point-in-contanier-box-p (c x y) + "Returns T if the ponit X Y is inside the bounds of the container." + (and (<= (container-left c) x (container-right c)) + (<= (container-bottom c) y (container-top c)))) + +(defun visible-in-container-p (unit) + "Returns T if UNIT is VISIBLEP, if it is inside a CONTAINER, if any + of the corners of its bounding rectangle are inside that CONTAINER. + + UNIT must implement the affine protocol." + (when (unit-visiblep unit) + (when-let ((container + (unit-container unit))) + (loop for pt in (get-rect unit) + thereis (point-in-contanier-box-p container (vec:vx pt) (vec:vy pt)))))) + (defmethod drop-unit ((unit unit)) "Removes a unit from its container. Returns T if the unit actually was removed." (when-let (container (unit-container unit)) @@ -30,3 +65,18 @@ necessary." (defmethod cleanup ((container container)) (dolist (u (container-units container)) (cleanup u))) + +(defmethod render ((container container)) + (let ((current + (gl:get* :scissor-box)) + (scale + (application-scale + (app-of-unit container)) + )) + (with-slots (left right top bottom) container + (gl:scissor (* left scale) (* scale bottom) (* scale (- right left)) (* scale (- top bottom))) + (unwind-protect + (dolist (u (container-units container)) + (when (visible-in-container-p u) + (render u))) + (gl:scissor (aref current 0) (aref current 1) (aref current 2) (aref current 3)))))) diff --git a/src/core/unit.lisp b/src/core/unit.lisp index fb02f08..e93ba56 100644 --- a/src/core/unit.lisp +++ b/src/core/unit.lisp @@ -21,11 +21,10 @@ in this application." (or (cached-application unit) (setf (cached-application unit) (labels ((rec (u) - (when-let (c (unit-container u)) - (etypecase c - (application c) - (unit (rec c)) - (null nil))))) + (etypecase u + (application u) + (unit (rec (unit-container u))) + (nil nil)))) (rec unit))))) diff --git a/src/interactive/button.lisp b/src/interactive/button.lisp index e8fd4fa..87779f0 100644 --- a/src/interactive/button.lisp +++ b/src/interactive/button.lisp @@ -61,76 +61,25 @@ (render up) (render down)))) -(defmethod x ((button button)) - (x (button-up button))) - -(defmethod (setf x) (newval (button button)) - (with-slots (up down bg) button - (when bg - (setf (x bg) newval)) - (setf (x up) newval - (x down) newval))) - -(defmethod y ((button button)) - (y (button-up button))) - -(defmethod (setf y) (newval (button button)) - (with-slots (up down bg) button - (when bg - (setf (y bg) newval)) - (setf (y up) newval - (y down) newval))) - -(defmethod scale-x ((thing button)) - (scale-x (button-up thing))) - -(defmethod (setf scale-x) (newval (button button)) - (with-slots (up down bg) button - (when bg - (setf (scale-x bg) newval)) - (setf (scale-x up) newval - (scale-x down) newval))) - - -(defmethod scale-y ((thing button)) - (scale-y (button-up thing))) - -(defmethod (setf scale-y) (newval (button button)) - (with-slots (up down bg) button - (when bg - (setf (scale-y bg) newval)) - (setf (scale-y up) newval - (scale-y down) newval))) - -(defmethod rotation ((thing button)) - (rotation (button-up thing))) - -(defmethod (setf rotation) (newval (button button)) - (with-slots (up down bg) button - (when bg - (setf (rotation bg) newval)) - (setf (rotation up) newval - (rotation down) newval))) - -(defmethod width ((thing button)) - (width (button-up thing))) - -(defmethod (setf width) (newval (button button)) - (with-slots (up down bg) button - (when bg - (setf (width bg) newval)) - (setf (width up) newval - (width down) newval))) - -(defmethod height ((thing button)) - (height (button-up thing))) - -(defmethod (setf height) (newval (button button)) - (with-slots (up down bg) button - (when bg - (setf (height bg) newval)) - (setf (height up) newval - (height down) newval))) +(macrolet + ((def-accessors (&rest accessor-names) + (let ((defs + (loop for accessor-name in accessor-names + collect + `(defmethod ,accessor-name ((button button)) + (,accessor-name (button-up button))) + + collect + `(defmethod (setf ,accessor-name) (newval (button button)) + (setf (,accessor-name (button-up button)) newval + (,accessor-name (button-down button)) newval + (,accessor-name (button-bg button)) newval))))) + `(progn ,@defs)))) + + (def-accessors x y scale-x scale-y width height rotation)) + +(defmethod get-rect ((button button)) + (get-rect (button-up button))) (defun make-texture-button (up down &key pressed released) "UP and DOWN should be strings naming assets to use as the up and diff --git a/src/interactive/frameset.lisp b/src/interactive/frameset.lisp index 51c7ecd..a8ba079 100644 --- a/src/interactive/frameset.lisp +++ b/src/interactive/frameset.lisp @@ -67,6 +67,9 @@ (def-frameset-accessors x y scale-x scale-y width height rotation)) +(defmethod get-rect ((fs frameset)) + (get-rect (current-frame-unit fs))) + (defun make-frameset (sequenced-assets &key (fps 2) asset-args) (let* ((asset-names (remove-duplicates sequenced-assets :test #'equal)) diff --git a/src/interactive/sprite.lisp b/src/interactive/sprite.lisp index 81f5715..03bba8d 100644 --- a/src/interactive/sprite.lisp +++ b/src/interactive/sprite.lisp @@ -40,3 +40,6 @@ `(progn ,@defs)))) (def-sprite-accessors x y scale-x scale-y width height rotation)) + +(defmethod get-rect ((sprite sprite)) + (get-rect (current-frameset sprite))) diff --git a/src/protocol.lisp b/src/protocol.lisp index 58120cd..df3c170 100644 --- a/src/protocol.lisp +++ b/src/protocol.lisp @@ -56,3 +56,7 @@ (defgeneric (setf scale-x) (newvval thing)) (defgeneric scale-y (thing)) (defgeneric (setf scale-y) (newval thing)) +(defgeneric get-rect (affine) + (:documentation "Returns a list of vectors representing the path of + the smallest rectangle that encloses the affine-unit. The rectangle + is scaled and rotated.")) diff --git a/src/utils.lisp b/src/utils.lisp index 3598ec3..7024a8d 100644 --- a/src/utils.lisp +++ b/src/utils.lisp @@ -14,3 +14,51 @@ (slot-value object slot))) val default)) + +(defun counterclockwisep (a b c) + "A B and C are vectors created by 3d-vectors:vec, each representing +a 2d point. Returns T if the three are supplied in counterclockwise +order, nil if not." + (> (* (- (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) + "A B C and D are vectors of the sort created by 3d-vectors:vec, +each representing a 2d point. Returns T if the line segment between A +and B intersects the linesegment between C and D, NIL otherwise." + (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))))) + diff --git a/src/wheelwork.lisp b/src/wheelwork.lisp index ffcb242..cc70053 100644 --- a/src/wheelwork.lisp +++ b/src/wheelwork.lisp @@ -23,7 +23,8 @@ (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 :depth-test) + (gl:enable :scissor-test) (let ((*application* app)) (unwind-protect (progn @@ -64,64 +65,8 @@ TARGET is FOCUSABLEP" (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 width) (h 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 @@ -144,17 +89,22 @@ the path." (return (oddp intersection-count)))))) (defun unit-under (app x y) + "Finds the visible unit that contains the point 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)))))) + (when (unit-visiblep 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*)) + "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)))) diff --git a/wheelwork.asd b/wheelwork.asd index 095c949..5de81de 100644 --- a/wheelwork.asd +++ b/wheelwork.asd @@ -30,6 +30,7 @@ (:module "core" :components ((:file "unit") (:file "container") + (:file "clipped") (:file "affine"))) (:module "events" :components ((:file "event-handler") |