Add (chickadee data quadtree) module.

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)