From fda1d9d08349dfe103b7af3ef8f305c1701933f6 Mon Sep 17 00:00:00 2001
From: Colin Okay <colin@cicadas.surf>
Date: Wed, 6 Jul 2022 09:33:14 -0500
Subject: [refactor] containers have render bounds
---
src/application.lisp | 13 ++++---
src/core/affine.lisp | 26 +++++++++++--
src/core/container.lisp | 52 ++++++++++++++++++++++++-
src/core/unit.lisp | 9 ++---
src/interactive/button.lisp | 89 +++++++++----------------------------------
src/interactive/frameset.lisp | 3 ++
src/interactive/sprite.lisp | 3 ++
src/protocol.lisp | 4 ++
src/utils.lisp | 48 +++++++++++++++++++++++
src/wheelwork.lisp | 80 ++++++++------------------------------
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")
--
cgit v1.2.3