summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Makefile.am4
-rw-r--r--chickadee/data/quadtree.scm338
-rw-r--r--doc/api.texi111
-rw-r--r--examples/quadtree.scm178
4 files changed, 630 insertions, 1 deletions
diff --git a/Makefile.am b/Makefile.am
index 9a108d5..6bcc25a 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -50,6 +50,7 @@ SOURCES = \
chickadee/data/heap.scm \
chickadee/data/array-list.scm \
chickadee/data/queue.scm \
+ chickadee/data/quadtree.scm \
chickadee/data/grid.scm \
chickadee/data/path-finding.scm \
chickadee/math.scm \
@@ -99,7 +100,8 @@ SOURCES = \
chickadee/cli/bundle.scm
TESTS = \
- tests/math/vector.scm
+ tests/math/vector.scm \
+ tests/data/quadtree.scm
TEST_EXTENSIONS = .scm
SCM_LOG_COMPILER = $(top_builddir)/test-env $(GUILE)
diff --git a/chickadee/data/quadtree.scm b/chickadee/data/quadtree.scm
new file mode 100644
index 0000000..731faf2
--- /dev/null
+++ b/chickadee/data/quadtree.scm
@@ -0,0 +1,338 @@
+;;; Chickadee Game Toolkit
+;;; Copyright © 2021 David Thompson <davet@gnu.org>
+;;;
+;;; Chickadee is free software: you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published
+;;; by the Free Software Foundation, either version 3 of the License,
+;;; or (at your option) any later version.
+;;;
+;;; Chickadee is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program. If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (chickadee data quadtree)
+ #:use-module (chickadee math rect)
+ #:use-module (ice-9 format)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-9 gnu)
+ #:export (make-quadtree
+ quadtree?
+ quadtree-leaf?
+ quadtree-bounds
+ quadtree-max-depth
+ quadtree-max-size
+ quadtree-depth
+ quadtree-size
+ quadtree-q1
+ quadtree-q2
+ quadtree-q3
+ quadtree-q4
+ quadtree-clear!
+ quadtree-insert!
+ quadtree-delete!
+ quadtree-find
+ quadtree-fold
+ quadtree-for-each))
+
+;; The quadrants:
+;;
+;; *------*------*
+;; | | |
+;; | Q2 | Q1 |
+;; | | |
+;; *------*------*
+;; | | |
+;; | Q3 | Q4 |
+;; | | |
+;; *------*------*
+(define-record-type <quadtree>
+ (%make-quadtree bounds max-depth max-size depth size objects leaf?)
+ quadtree?
+ (bounds quadtree-bounds)
+ (max-depth quadtree-max-depth)
+ (max-size quadtree-max-size)
+ (depth quadtree-depth)
+ (size quadtree-size set-quadtree-size!)
+ (objects quadtree-objects set-quadtree-objects!)
+ (leaf? quadtree-leaf? set-quadtree-leaf!)
+ (q1 quadtree-q1 set-quadtree-q1!)
+ (q2 quadtree-q2 set-quadtree-q2!)
+ (q3 quadtree-q3 set-quadtree-q3!)
+ (q4 quadtree-q4 set-quadtree-q4!))
+
+(define (display-quadtree quadtree port)
+ (format port "#<quadtree bounds: ~s depth: ~d size: ~d>"
+ (quadtree-bounds quadtree)
+ (quadtree-depth quadtree)
+ (quadtree-size quadtree)))
+
+(set-record-type-printer! <quadtree> display-quadtree)
+
+(define* (make-quadtree bounds #:key (max-size 5) (max-depth 4))
+ "Return a new quadtree that covers the area BOUNDS. Each node will
+try to hold at maximum MAX-SIZE objects and the tree depth will be
+restricted to MAX-DEPTH."
+ (%make-quadtree bounds max-depth max-size 0 0 (make-vector max-size #f) #t))
+
+(define (quadtree-empty? quadtree)
+ "Return #t if QUADTREE has no objects."
+ (= (quadtree-size quadtree) 0))
+
+(define (quadtree-empty-leaf? quadtree)
+ "Return #t if QUADTREE is an empty leaf node."
+ (and (quadtree-empty? quadtree) (quadtree-leaf? quadtree)))
+
+(define (quadtree-full? quadtree)
+ "Return #t if QUADTREE is at or over desired maximum capacity."
+ (>= (quadtree-size quadtree) (quadtree-max-size quadtree)))
+
+(define (quadtree-max-depth? quadtree)
+ "Return #t if QUADTREE is at the maximum allowed depth."
+ (= (quadtree-depth quadtree) (quadtree-max-depth quadtree)))
+
+(define (quadtree-clear! quadtree)
+ "Clear QUADTREE."
+ (vector-fill! (quadtree-objects quadtree) #f)
+ (set-quadtree-size! quadtree 0)
+ (unless (quadtree-leaf? quadtree)
+ (set-quadtree-leaf! quadtree #t)
+ (quadtree-clear! (quadtree-q1 quadtree))
+ (quadtree-clear! (quadtree-q2 quadtree))
+ (quadtree-clear! (quadtree-q3 quadtree))
+ (quadtree-clear! (quadtree-q4 quadtree))))
+
+(define (quadtree-split! quadtree)
+ "Split QUADTREE region into 4 smaller child nodes."
+ (let* ((max-depth (quadtree-max-depth quadtree))
+ (max-size (quadtree-max-size quadtree))
+ (depth (+ (quadtree-depth quadtree) 1))
+ (length (vector-length (quadtree-objects quadtree)))
+ (bounds (quadtree-bounds quadtree))
+ (x (rect-x bounds))
+ (y (rect-y bounds))
+ (hw (/ (rect-width bounds) 2.0))
+ (hh (/ (rect-height bounds) 2.0)))
+ (define (make-node x y)
+ (%make-quadtree (make-rect x y hw hh) max-depth max-size depth 0
+ (make-vector length #f) #t))
+ (set-quadtree-leaf! quadtree #f)
+ (unless (quadtree-q1 quadtree)
+ (set-quadtree-q1! quadtree (make-node (+ x hw) (+ y hh)))
+ (set-quadtree-q2! quadtree (make-node x (+ y hh)))
+ (set-quadtree-q3! quadtree (make-node x y))
+ (set-quadtree-q4! quadtree (make-node (+ x hw) y)))))
+
+(define (pick-node quadtree rect)
+ "Return the child node of QUADTREE that fully contains RECT, or
+QUADTREE if RECT overlaps multiple child nodes."
+ (let* ((bounds (quadtree-bounds quadtree))
+ (bx (rect-x bounds))
+ (by (rect-y bounds))
+ (bw (rect-width bounds))
+ (bh (rect-height bounds))
+ (mid-x (+ bx (/ bw 2.0)))
+ (mid-y (+ by (/ bh 2.0)))
+ (x (rect-x rect))
+ (y (rect-y rect))
+ (w (rect-width rect))
+ (h (rect-height rect)))
+ (cond
+ ;; Rect does not overlap this node.
+ ((or (>= x (+ bx bw))
+ (<= (+ x w) bx)
+ (>= y (+ by bh))
+ (<= (+ y h) by))
+ #f)
+ ((quadtree-leaf? quadtree)
+ quadtree)
+ ;; Rect is within the left two quadrants: Q2 and Q3.
+ ((and (< x mid-x) (< (+ x w) mid-x))
+ (cond
+ ;; Rect is within Q3.
+ ((and (< y mid-y) (< (+ y h) mid-y))
+ (quadtree-q3 quadtree))
+ ;; Rect is within Q2.
+ ((> y mid-y)
+ (quadtree-q2 quadtree))
+ ;; Rect spans both Q2 and Q3.
+ (else quadtree)))
+ ;; Rect is within the right two quadrants: Q1 and Q4.
+ ((and (> x mid-x))
+ (cond
+ ;; Rect is within Q4.
+ ((and (< y mid-y) (< (+ y h) mid-y))
+ (quadtree-q4 quadtree))
+ ;; Rect is within Q1.
+ ((> y mid-y)
+ (quadtree-q1 quadtree))
+ ;; Rect spans both Q1 and Q4.
+ (else quadtree)))
+ (else quadtree))))
+
+(define (quadtree-add! quadtree rect object)
+ "Add OBJECT to the list of objets in QUADTREE."
+ (let ((objects (quadtree-objects quadtree))
+ (size (quadtree-size quadtree)))
+ (when (= size (vector-length objects))
+ (let* ((new-size (* size 2))
+ (new-objects (make-vector new-size #f)))
+ (let loop ((i 0))
+ (when (< i size)
+ (vector-set! new-objects i (vector-ref objects i))
+ (loop (+ i 1))))
+ (set-quadtree-objects! quadtree new-objects)))
+ (vector-set! (quadtree-objects quadtree) size (cons rect object))
+ (set-quadtree-size! quadtree (+ size 1))))
+
+(define (quadtree-merge-maybe! quadtree)
+ "Remove child nodes if they are all empty leaf nodes."
+ (when (and (quadtree-empty-leaf? (quadtree-q1 quadtree))
+ (quadtree-empty-leaf? (quadtree-q2 quadtree))
+ (quadtree-empty-leaf? (quadtree-q3 quadtree))
+ (quadtree-empty-leaf? (quadtree-q4 quadtree)))
+ ;; We don't actually get rid of the child nodes. This means that
+ ;; the quadtree can take more memory than it has to, but it also
+ ;; means that the quadtree doesn't allocate needlessly when
+ ;; objects are constantly being added/removed.
+ (set-quadtree-leaf! quadtree #t)))
+
+(define (quadtree-insert! quadtree rect object)
+ "Insert OBJECT with bounding box RECT into QUADTREE."
+ (let ((node (pick-node quadtree rect)))
+ (cond
+ ;; The rect doesn't fit into the parent node.
+ ((not node)
+ #f)
+ ;; The rect fits completely within one of the child nodes, so
+ ;; descend into that node and repeat the process.
+ ((not (eq? quadtree node))
+ (quadtree-insert! node rect object))
+ ;; The node is a leaf node that is at or over the desired
+ ;; capacity, so we need to split it and redistribute the objects.
+ ;; Nodes that have reached the maximum allowed depth cannot be
+ ;; split.
+ ((and (quadtree-full? quadtree)
+ (quadtree-leaf? quadtree)
+ (not (quadtree-max-depth? quadtree)))
+ (let ((objects (quadtree-objects quadtree))
+ (size (quadtree-size quadtree)))
+ (quadtree-split! quadtree)
+ (let loop ((i 0))
+ (if (< i size)
+ (let ((obj (vector-ref objects i)))
+ (loop (+ i 1))
+ (quadtree-insert! quadtree (car obj) (cdr obj)))
+ (begin
+ (set-quadtree-size! quadtree 0)
+ (vector-fill! objects #f))))
+ (quadtree-insert! quadtree rect object)
+ (quadtree-merge-maybe! quadtree)))
+ ;; The node is either under the desired maximum objects threshold
+ ;; or has no choice but to accept another object because there is
+ ;; no child node that fully contains the rect or we have reached
+ ;; the maximum allowed tree depth.
+ (else
+ (quadtree-add! quadtree rect object)))))
+
+(define (quadtree-delete! quadtree rect object)
+ "Delete OBJECT, who occupies the space RECT, from QUADTREE."
+ (let ((node (pick-node quadtree rect)))
+ (cond
+ ((not node)
+ #f)
+ ((eq? quadtree node)
+ (let ((objects (quadtree-objects quadtree))
+ (size (quadtree-size quadtree)))
+ (let loop ((i 0))
+ (cond
+ ((= i size)
+ #f)
+ ((eq? (cdr (vector-ref objects i)) object)
+ (let ((new-size (- size 1)))
+ (vector-set! objects i (vector-ref objects new-size))
+ (vector-set! objects new-size #f)
+ (set-quadtree-size! quadtree new-size)
+ #t))
+ (else
+ (loop (+ i 1)))))))
+ (else
+ (and (quadtree-delete! node rect object)
+ (begin
+ (quadtree-merge-maybe! quadtree)
+ #t))))))
+
+(define (quadtree-find quadtree rect pred)
+ "Return the first object in QUADTREE in the vicinity of RECT that
+satisfies PRED."
+ (let ((objects (quadtree-objects quadtree))
+ (size (quadtree-size quadtree))
+ (next-node (pick-node quadtree rect)))
+ (if next-node
+ (let loop ((i 0))
+ (if (< i size)
+ (let ((object (cdr (vector-ref objects i))))
+ (if (pred object)
+ object
+ (loop (+ i 1))))
+ (cond
+ ((and (eq? next-node quadtree) (not (quadtree-leaf? quadtree)))
+ (or (quadtree-find (quadtree-q1 quadtree) rect pred)
+ (quadtree-find (quadtree-q2 quadtree) rect pred)
+ (quadtree-find (quadtree-q3 quadtree) rect pred)
+ (quadtree-find (quadtree-q4 quadtree) rect pred)))
+ ((eq? next-node quadtree)
+ #f)
+ (else
+ (quadtree-find next-node rect pred)))))
+ #f)))
+
+(define (quadtree-fold quadtree rect init proc)
+ "Apply PROC to all objects in the vicinity of RECT in QUADTREE to
+build a result and return that result. INIT is the initial result.
+If there are no objects in the vicinity of RECT, just INIT is
+returned."
+ (let ((objects (quadtree-objects quadtree))
+ (size (quadtree-size quadtree))
+ (next-node (pick-node quadtree rect)))
+ (if next-node
+ (let loop ((i 0)
+ (memo init))
+ (if (< i size)
+ (loop (+ i 1) (proc (cdr (vector-ref objects i)) memo))
+ (cond
+ ((and (eq? next-node quadtree) (not (quadtree-leaf? quadtree)))
+ (let* ((q1 (quadtree-fold (quadtree-q1 quadtree) rect memo proc))
+ (q2 (quadtree-fold (quadtree-q2 quadtree) rect q1 proc))
+ (q3 (quadtree-fold (quadtree-q3 quadtree) rect q2 proc)))
+ (quadtree-fold (quadtree-q4 quadtree) rect q3 proc)))
+ ((eq? next-node quadtree)
+ memo)
+ (else
+ (quadtree-fold next-node rect memo proc)))))
+ init)))
+
+(define (quadtree-for-each quadtree rect proc)
+ "Call PROC for all objects in the vicinity of RECT in QUADTREE."
+ (let ((objects (quadtree-objects quadtree))
+ (size (quadtree-size quadtree))
+ (next-node (pick-node quadtree rect)))
+ (when next-node
+ (let loop ((i 0))
+ (when (< i size)
+ (proc (cdr (vector-ref objects i)))
+ (loop (+ i 1))))
+ (cond
+ ((and (eq? next-node quadtree) (not (quadtree-leaf? quadtree)))
+ (quadtree-for-each (quadtree-q1 quadtree) rect proc)
+ (quadtree-for-each (quadtree-q2 quadtree) rect proc)
+ (quadtree-for-each (quadtree-q3 quadtree) rect proc)
+ (quadtree-for-each (quadtree-q4 quadtree) rect proc))
+ ((eq? next-node quadtree)
+ *unspecified*)
+ (else
+ (quadtree-for-each next-node rect proc))))))
diff --git a/doc/api.texi b/doc/api.texi
index 96803b8..f3b8013 100644
--- a/doc/api.texi
+++ b/doc/api.texi
@@ -5210,10 +5210,121 @@ Clear all messages and scripts awaiting messages in @var{channel}.
@section Data Structures
@menu
+* Quadtrees:: Spatial partitioning with recursive subdivision.
* Grids:: Spatial partitioning with a fixed grid.
* Path Finding:: Generic A* path finding.
@end menu
+@node Quadtrees
+@subsection Quadtrees
+
+The @code{(chickadee data quadtree)} module provides a 2D spatial
+partitioning implementation known as a ``quadtree''. A quadtree
+recursively subdivides the world into rectangular quadrants. This
+data structure is very useful for handling broad-phase collision
+detection because it can quickly determine the objects that may
+possibly be colliding with another, resulting in fewer narrow-phase
+collision tests that are typically much more expensive.
+
+@deffn {Procedure} make-quadtree bounds [#:max-size 5] [#:make-depth 4]
+Return a new quadtree that covers the area @var{bounds}. Each node
+will try to hold at maximum @var{max-size} objects and the tree depth
+will be restricted to @var{max-depth}.
+@end deffn
+
+@deffn {Procedure} quadtree? obj
+Return @code{#t} if @var{obj} is a quadtree.
+@end deffn
+
+@deffn {Procedure} quadtree-clear! quadtree
+Clear all objects from @var{quadtree}.
+@end deffn
+
+@deffn {Procedure} quadtree-insert! quadtree rect object
+Insert @var{object} with bounding box @var{rect} into @var{quadtree}.
+@end deffn
+
+@deffn {Procedure} quadtree-delete! quadtree rect object
+Delete @var{object}, who occupies the space @var{rect}, from
+@var{quadtree}.
+@end deffn
+
+@deffn {Procedure} quadtree-find rect pred
+Return the first object in @var{quadtree} in the vicinity of
+@var{rect} that satisfies @var{pred}.
+@end deffn
+
+@deffn {Procedure} quadtree-fold quadtree rect init proc
+Apply @var{proc} to all objects in the vicinity of @var{rect} in
+@var{quadtree} to build a result and return that result. @var{init}
+is the initial result. If there are no objects in the vicinity of
+@var{rect}, just @var{init} is returned.
+@end deffn
+
+@deffn {Procedure} quadtree-for-each quadtree rect proc
+Call @var{proc} for all objects in the vicinity of @var{rect} in
+@var{quadtree}.
+@end deffn
+
+@deffn {Procedure} quadtree-leaf? quadtree
+Return @code{#t} if @var{quadtree} is a leaf node.
+@end deffn
+
+@deffn {Procedure} quadtree-bounds quadtree
+Return the bounding rectangle of @var{quadtree}.
+@end deffn
+
+@deffn {Procedure} quadtree-max-depth quadtree
+Return the maximum depth of @var{quadtree}.
+@end deffn
+
+@deffn {Procedure} quadtree-max-size quadtree
+Return the desired per-node maximum object count of @var{quadtree}.
+@end deffn
+
+@deffn {Procedure} quadtree-depth quadtree
+Return the depth of the node @var{quadtree}.
+@end deffn
+
+@deffn {Procedure} quadtree-size quadtree
+Return the number of objects stored in the node @var{quadtree}.
+@end deffn
+
+Non-leaf nodes always have four child nodes, which correspond to the
+quadrants of a Cartesian coordinate system:
+
+@verbatim
+*------*------*
+| | |
+| Q2 | Q1 |
+| | |
+*------*------*
+| | |
+| Q3 | Q4 |
+| | |
+*------*------*
+@end verbatim
+
+@deffn {Procedure} quadtree-q1 quadtree
+Return the upper-right child node of @var{quadtree}, or @code{#f} if
+@var{quadtree} is a leaf node.
+@end deffn
+
+@deffn {Procedure} quadtree-q2 quadtree
+Return the upper-left child node of @var{quadtree}, or @code{#f} if
+@var{quadtree} is a leaf node.
+@end deffn
+
+@deffn {Procedure} quadtree-q3 quadtree
+Return the lower-left child node of @var{quadtree}, or @code{#f} if
+@var{quadtree} is a leaf node.
+@end deffn
+
+@deffn {Procedure} quadtree-q4 quadtree
+Return the lower-right child node of @var{quadtree}, or @code{#f} if
+@var{quadtree} is a leaf node.
+@end deffn
+
@node Grids
@subsection Grids
diff --git a/examples/quadtree.scm b/examples/quadtree.scm
new file mode 100644
index 0000000..31b8138
--- /dev/null
+++ b/examples/quadtree.scm
@@ -0,0 +1,178 @@
+(use-modules (chickadee)
+ (chickadee data quadtree)
+ (chickadee math)
+ (chickadee math matrix)
+ (chickadee math rect)
+ (chickadee math vector)
+ (chickadee graphics color)
+ (chickadee graphics font)
+ (chickadee graphics path)
+ (chickadee graphics sprite)
+ (chickadee graphics texture)
+ (chickadee scripting)
+ (ice-9 format)
+ (ice-9 match)
+ (srfi srfi-1)
+ (srfi srfi-9)
+ (statprof))
+
+(define-record-type <actor>
+ (make-actor position velocity bounding-box)
+ actor?
+ (position actor-position)
+ (velocity actor-velocity)
+ (bounding-box actor-bounding-box))
+
+(define texture #f)
+(define batch #f)
+(define start-time 0.0)
+(define avg-frame-time 16)
+(define actor-count 250)
+(define actors
+ (list-tabulate actor-count
+ (lambda (n)
+ (let ((x (* (random:uniform) 624.0))
+ (y (* (random:uniform) 464.0)))
+ (make-actor (vec2 x y)
+ (vec2 (* (- (random:uniform) 0.5) 3.0)
+ (* (- (random:uniform) 0.5) 3.0))
+ (rect x y 16.0 16.0))))))
+(define quadtree (make-quadtree (make-rect 0.0 0.0 640.0 480.0) #:max-size 4 #:max-depth 4))
+(define canvas (make-empty-canvas))
+(define paused? #f)
+(define matrix (make-identity-matrix4))
+(define stats-text-pos (vec2 4.0 464.0))
+(define stats-text #f)
+
+(for-each (lambda (actor)
+ (quadtree-insert! quadtree (actor-bounding-box actor) actor))
+ actors)
+
+(define (quadtree-nodes quadtree)
+ (if (quadtree-leaf? quadtree)
+ (list quadtree)
+ (cons quadtree
+ (append (quadtree-nodes (quadtree-q1 quadtree))
+ (quadtree-nodes (quadtree-q2 quadtree))
+ (quadtree-nodes (quadtree-q3 quadtree))
+ (quadtree-nodes (quadtree-q4 quadtree))))))
+
+(define (paint-canvas)
+ (let ((painter (with-style ((stroke-color tango-scarlet-red))
+ (apply superimpose
+ (map (lambda (node)
+ (let ((rect (quadtree-bounds node)))
+ (stroke
+ (rectangle (vec2 (rect-x rect)
+ (rect-y rect))
+ (rect-width rect)
+ (rect-height rect)))))
+ (quadtree-nodes quadtree))))))
+ (set-canvas-painter! canvas painter)))
+
+(define (stats-message)
+ (format #f " actors: ~d fps: ~1,2f"
+ actor-count (/ 1.0 avg-frame-time)))
+
+(define (load)
+ (set! *random-state* (random-state-from-platform))
+ (set! texture (load-image "images/shot.png"))
+ (set! batch (make-sprite-batch texture #:capacity actor-count))
+ (paint-canvas)
+ (script
+ (forever
+ (set! stats-text (stats-message))
+ (sleep 60))))
+
+(define (draw alpha)
+ (sprite-batch-clear! batch)
+ (for-each (lambda (actor)
+ (sprite-batch-add* batch (actor-bounding-box actor) matrix))
+ actors)
+ (draw-canvas canvas)
+ (draw-sprite-batch batch)
+ (draw-text stats-text stats-text-pos #:color black)
+ (let ((current-time (elapsed-time)))
+ (set! avg-frame-time
+ (+ (* (- current-time start-time) 0.1)
+ (* avg-frame-time 0.9)))
+ (set! start-time current-time)))
+
+(define (clamp-x x)
+ (clamp 0.0 624.0 x))
+
+(define (clamp-y y)
+ (clamp 0.0 464.0 y))
+
+(define (update dt)
+ (update-agenda 1)
+ (unless paused?
+ ;; Move
+ (for-each (lambda (actor)
+ (let ((p (actor-position actor))
+ (v (actor-velocity actor))
+ (r (actor-bounding-box actor)))
+ (quadtree-delete! quadtree r actor)
+ ;; Move by velocity, clamping to the edge of the
+ ;; window.
+ (set-vec2-x! p (clamp-x (+ (vec2-x p) (vec2-x v))))
+ (set-vec2-y! p (clamp-y (+ (vec2-y p) (vec2-y v))))
+ (set-rect-x! r (vec2-x p))
+ (set-rect-y! r (vec2-y p))
+ ;; Check for and resolve collision.
+ (quadtree-find
+ quadtree r
+ (lambda (other)
+ ;; Calculate overlap.
+ (let* ((ro (actor-bounding-box other))
+ (xo (max (- (min (rect-right r) (rect-right ro))
+ (max (rect-left r) (rect-left ro)))
+ 0.0))
+ (yo (max (- (min (rect-top r) (rect-top ro))
+ (max (rect-bottom r) (rect-bottom ro)))
+ 0.0)))
+ (if (or (= xo 0.0) (= yo 0.0))
+ #f ; no collision
+ (let ((vo (actor-velocity other)))
+ ;; Resolve the collsion with the least
+ ;; possible movement. Bounce the
+ ;; colliding actors off of each other by
+ ;; reversing the x or y component of the
+ ;; velocity vectors.
+ (if (< xo yo)
+ (let* ((xdiff (- (rect-x r) (rect-x ro)))
+ (xsign (/ xdiff (abs xdiff))))
+ (set-vec2-x! p (clamp-x (+ (vec2-x p) (* xo xsign))))
+ (set-vec2-x! v (* (vec2-x v) -1.0))
+ (set-vec2-x! vo (* (vec2-x vo) -1.0)))
+ (let* ((ydiff (- (rect-y r) (rect-y ro)))
+ (ysign (/ ydiff (abs ydiff))))
+ (set-vec2-y! p (clamp-y (+ (vec2-y p) (* yo ysign))))
+ (set-vec2-y! v (* (vec2-y v) -1.0))
+ (set-vec2-y! vo (* (vec2-y vo) -1.0))))
+ (set-rect-x! r (vec2-x p))
+ (set-rect-y! r (vec2-y p))
+ #t)))))
+ ;; Bounce off the window edges.
+ (when (or (= (vec2-x p) 0.0)
+ (= (vec2-x p) 624.0))
+ (set-vec2-x! v (* (vec2-x v) -1.0)))
+ (when (or (= (vec2-y p) 0.0)
+ (= (vec2-y p) 464.0))
+ (set-vec2-y! v (* (vec2-y v) -1.0)))
+ (quadtree-insert! quadtree r actor)))
+ actors)
+ (paint-canvas)))
+
+(define (key-press key modifiers repeat?)
+ (case key
+ ((q)
+ (abort-game))
+ ((space)
+ (set! paused? (not paused?)))))
+
+(run-game #:window-title "quadtree"
+ #:load load
+ #:draw draw
+ #:update update
+ #:key-press key-press)