diff options
Diffstat (limited to 'examples')
| -rw-r--r-- | examples/quadtree.scm | 178 |
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) |