summaryrefslogtreecommitdiff
path: root/examples/quadtree.scm
diff options
context:
space:
mode:
authorDavid Thompson <dthompson2@worcester.edu>2021-10-01 08:19:52 -0400
committerDavid Thompson <dthompson2@worcester.edu>2021-10-01 08:41:27 -0400
commit1ef0c9b18263ee1354987e8f104aff562a953fe6 (patch)
tree2085b254b3871e08399d33ad6a43fab42d82a9e5 /examples/quadtree.scm
parent602569cd13f8f018194f54f39f4645d36d5b3821 (diff)
Add (chickadee data quadtree) module.
Diffstat (limited to 'examples/quadtree.scm')
-rw-r--r--examples/quadtree.scm178
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)