Add (chickadee data quadtree) module.

1 files changed, 178 insertions, 0 deletions

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)