diff options
| -rw-r--r-- | Makefile.am | 2 | ||||
| -rw-r--r-- | chickadee/math/grid.scm | 404 | ||||
| -rw-r--r-- | examples/grid.scm | 87 |
3 files changed, 493 insertions, 0 deletions
diff --git a/Makefile.am b/Makefile.am index 4640581..1ae2d24 100644 --- a/Makefile.am +++ b/Makefile.am @@ -51,6 +51,7 @@ SOURCES = \ chickadee/math/matrix.scm \ chickadee/math/quaternion.scm \ chickadee/math/rect.scm \ + chickadee/math/grid.scm \ chickadee/math/easings.scm \ chickadee/render/color.scm \ chickadee/render/gl.scm \ @@ -83,6 +84,7 @@ EXTRA_DIST += \ examples/text.scm \ examples/nine-patch.scm \ examples/tiled.scm \ + examples/grid.scm \ examples/images/AUTHORS \ examples/images/chickadee.png \ examples/images/dialog-box.png \ diff --git a/chickadee/math/grid.scm b/chickadee/math/grid.scm new file mode 100644 index 0000000..0361333 --- /dev/null +++ b/chickadee/math/grid.scm @@ -0,0 +1,404 @@ +;;; Chickadee Game Toolkit +;;; Copyright © 2018 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/>. + +;;; Commentary: +;; +;; Axis-aligned bounding box collision grid. +;; +;; Lots of inspiration drawn from https://github.com/kikito/bump.lua +;; +;;; Code: + +(define-module (chickadee math grid) + #:use-module (chickadee array-list) + #:use-module (chickadee math rect) + #:use-module (chickadee math vector) + #:use-module (ice-9 match) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-11) + #:export (slide + cell? + cell-count + make-grid + grid? + grid-cell-size + grid-add + grid-remove + grid-move + grid-clear + grid-cell-count + grid-item-count + for-each-cell + for-each-item)) + + +;;; +;;; Collision resolvers +;;; + +(define (slide item item-rect other other-rect goal) + "Resolve the collision that occurs between ITEM and OTHER when +moving ITEM-RECT to GOAL by sliding ITEM-RECT the minimum amount +needed to make the rectangles no longer overlap." + (let* ((goal-x (vec2-x goal)) + (goal-y (vec2-y goal)) + (x1 (max goal-x (rect-left other-rect))) + (x2 (min (+ goal-x (rect-width item-rect)) (rect-right other-rect))) + (y1 (max goal-y (rect-bottom other-rect))) + (y2 (min (+ goal-y (rect-height item-rect)) (rect-top other-rect))) + (x-fix (- x2 x1)) + (y-fix (- y2 y1))) + (if (< x-fix y-fix) + (if (= goal-x x1) + (set-vec2-x! goal (+ (vec2-x goal) x-fix)) + (set-vec2-x! goal (+ (vec2-x goal) (- x-fix)))) + (if (= goal-y y1) + (set-vec2-y! goal (+ (vec2-y goal) y-fix)) + (set-vec2-y! goal (+ (vec2-y goal) (- y-fix))))))) + + +;;; +;;; Cells +;;; + +(define-record-type <cell> + (make-cell items count) + cell? + (items cell-items) + (count cell-count set-cell-count!)) + +(define (make-empty-cell) + (make-cell (make-hash-table) 0)) + +(define (cell-add cell item) + (hashq-set! (cell-items cell) item #t) + (set-cell-count! cell (+ (cell-count cell) 1))) + +(define (cell-remove cell item) + (hashq-remove! (cell-items cell) item) + (set-cell-count! cell (- (cell-count cell) 1))) + +(define (for-each-cell-item proc cell) + "Call PROC with each item in CELL." + (hash-for-each (lambda (item unused) + (proc item)) + (cell-items cell))) + + +;;; +;;; Grid +;;; + +(define-record-type <grid> + (%make-grid cell-size rects rows scratch-rect buffer visited) + grid? + (cell-size grid-cell-size) + (rects grid-rects) + (rows grid-rows) + ;; The below fields are scratch space data structures that are + ;; allocated once when the grid is created to cut down on + ;; allocations while modifying the grid and checking for collisions. + (scratch-rect grid-scratch-rect) + (buffer grid-buffer) + (visited grid-visited)) + +(define* (make-grid #:optional (cell-size 64)) + "Create new grid partitioned by CELL-SIZE." + (%make-grid cell-size + (make-hash-table) + (make-hash-table) + (make-rect 0.0 0.0 0.0 0.0) + (make-array-list) + (make-hash-table))) + +(define (item-in-grid? grid item) + "Return #t if ITEM is in GRID." + (hashq-ref (grid-rects grid) item)) + +(define (grid-row-ref grid y) + "Return the row at index Y in GRID." + (let ((rows (grid-rows grid))) + (or (hashq-ref rows y) + (let ((new-row (make-hash-table))) + (hashq-set! rows y new-row) + new-row)))) + +(define (row-column-ref row x) + "Return the cell at index X in ROW." + (or (hashq-ref row x) + (let ((new-cell (make-empty-cell))) + (hashq-set! row x new-cell) + new-cell))) + +(define (grid-cell-ref grid x y) + "Return the cell in GRID at (X, Y)." + (row-column-ref (grid-row-ref grid y) x)) + +(define (grid-rect-ref grid item) + "Return the rect for ITEM in GRID." + (hashq-ref (grid-rects grid) item)) + +(define (grid-cell-bounds grid rect) + "Return the range of cells that RECT occupies in GRID. The first +two return values are the min/max x coordinate, the last two are the +min/max y coordinate." + (define (to-cell n) + (inexact->exact (floor (/ n (grid-cell-size grid))))) + (values (to-cell (rect-left rect)) + (to-cell (rect-right rect)) + (to-cell (rect-bottom rect)) + (to-cell (rect-top rect)))) + +(define (for-each-coord proc minx maxx miny maxy) + "Call PROC with each (X, Y) coordinate pair formed by the inclusive +ranges [MINX, MAXX] and [MINY, MAXY]." + (let yloop ((y miny)) + (when (<= y maxy) + (let xloop ((x minx)) + (when (<= x maxx) + (proc x y) + (xloop (+ x 1)))) + (yloop (+ y 1))))) + +(define* (for-each-cell proc grid #:optional rect) + "Call PROC with each cell in GRID that intersects RECT, or every +cell if RECT is #f." + (if rect + (let-values (((minx maxx miny maxy) (grid-cell-bounds grid rect))) + (for-each-coord (lambda (x y) + (proc (grid-cell-ref grid x y) x y)) + minx maxx miny maxy)) + (hash-for-each (lambda (y row) + (hash-for-each (lambda (x cell) + (proc cell x y)) + row)) + (grid-rows grid)))) + +(define (for-each-item-in-area proc grid rect) + "Call PROC with each item in GRID that overlaps the area defined by +RECT." + (for-each-cell (lambda (cell x y) + (for-each-cell-item (lambda (item) + (proc item (grid-rect-ref grid item))) + cell)) + grid rect)) + +(define (for-each-item proc grid) + "Call PROC for each item in GRID." + (hash-for-each proc (grid-rects grid))) + +(define (grid-add grid item x y width height) + "Add ITEM to GRID represented by axis-aligned bounding box defined +by X, Y, WIDTH, HEIGHT." + (when (item-in-grid? grid item) + (error "item already in grid" item)) + (let ((rect (make-rect x y width height))) + (hashq-set! (grid-rects grid) item rect) + (for-each-cell (lambda (cell x y) + (cell-add cell item)) + grid rect))) + +(define (grid-remove grid item) + "Remove ITEM from GRID." + (let ((rect (grid-rect-ref grid item))) + (unless rect + (error "item not in grid" item)) + (hashq-remove! (grid-rects grid) item) + (for-each-cell (lambda (cell x y) + (cell-remove cell item)) + grid rect))) + +(define (grid-update grid item position) + "Move ITEM in GRID to POSITION." + (let* ((rect (grid-rect-ref grid item)) + (moved-rect (grid-scratch-rect grid))) + (set-rect-x! moved-rect (vec2-x position)) + (set-rect-y! moved-rect (vec2-y position)) + (set-rect-width! moved-rect (rect-width rect)) + (set-rect-height! moved-rect (rect-height rect)) + (let-values (((minx1 maxx1 miny1 maxy1) + (grid-cell-bounds grid rect)) + ((minx2 maxx2 miny2 maxy2) + (grid-cell-bounds grid moved-rect))) + (set-rect-x! rect (vec2-x position)) + (set-rect-y! rect (vec2-y position)) + (for-each-coord (lambda (x y) + (when (or (< x minx2) (> x maxx2) + (< y miny2) (> y maxy2)) + (cell-remove (grid-cell-ref grid x y) item))) + minx1 maxx1 miny1 maxy1) + (for-each-coord (lambda (x y) + (let ((cell (grid-cell-ref grid x y))) + (when (or (< x minx1) (> x maxx1) + (< y miny1) (> y maxy1)) + (cell-add cell item)))) + minx2 maxx2 miny2 maxy2)))) + +(define (grid-find-collision grid item goal filter) + "Return the object that ITEM in GRID collides with while trying to +move to GOAL. + +FILTER is a procedure that determines how such a +collision should be resolved between two objects. It is called +like (FILTER ITEM OTHER), where OTHER is an object in close promimity +to other. If ITEM and OTHER should not collide with each other, +FILTER must return #f. Otherwise, FILTER returns a collision +resolution procedure, such as 'slide'. + +Collision resolution procedures are called like (RESOLVE RECT1 RECT2 +GOAL). RECT1 is the rectangle that is attempting to move to GOAL, but +has collided with RECT2. It is the responsibility of the resolution +procedure to modify GOAL such that RECT1 and RECT2 are no longer +colliding." + (define (sort-by-area collisions) + ;; This is just an insertion sort, which will be slow if there are a + ;; large number of simultaneous collisions. I think that the number + ;; of simultaneous collisions is almost always a single digit + ;; number, so a more efficient sorting algorithm doesn't gain us + ;; anything. + (define (compare a b) + (match a + ((_ area-a _) + (match b + ((_ area-b _) + (< area-a area-b)))))) + (define (swap i j) + (let ((tmp (array-list-ref collisions i))) + (array-list-set! collisions i (array-list-ref collisions j)) + (array-list-set! collisions j tmp))) + (let ((size (array-list-size collisions))) + (let outer + ((i 0)) + (when (< i size) + (let inner ((j (+ i 1))) + (when (< j size) + (when (compare (array-list-ref collisions i) + (array-list-ref collisions j)) + (swap i j)) + (inner (+ j 1)))) + (outer (+ i 1)))))) + (define (collision? rect1 rect2 goal) + (let ((goal-x (vec2-x goal)) + (goal-y (vec2-y goal))) + (and (< goal-x (rect-right rect2)) + (> (+ goal-x (rect-width rect1)) (rect-left rect2)) + (< goal-y (rect-top rect2)) + (> (+ goal-y (rect-height rect1)) (rect-bottom rect2))))) + (define (overlap-area rect1 rect2 goal) + (let ((goal-x (vec2-x goal)) + (goal-y (vec2-y goal))) + (* (- (min (+ goal-x (rect-width rect1)) (rect-right rect2)) + (max goal-x (rect-left rect2))) + (- (min (+ goal-y (rect-height rect1)) (rect-top rect2)) + (max goal-y (rect-bottom rect2)))))) + (let ((rect (grid-rect-ref grid item)) + (search-rect (grid-scratch-rect grid)) + (collisions (grid-buffer grid)) + (visited (grid-visited grid))) + ;; The search area is the bounding box formed by union of the + ;; current rect and the rect formed by moving it to the desired + ;; position. + (set-rect-x! search-rect (min (vec2-x goal) (rect-x rect))) + (set-rect-y! search-rect (min (vec2-y goal) (rect-y rect))) + (set-rect-width! search-rect (+ (rect-width rect) + (min (- (vec2-x goal) + (rect-x rect)) + 0))) + (set-rect-height! search-rect (+ (rect-height rect) + (min (- (vec2-y goal) + (rect-y rect)) + 0))) + ;; Reset our scratch space. + (array-list-clear! collisions) + ;; Visit every cell in the search area. + (for-each-item-in-area + (lambda (other other-rect) + ;; Since items can occupy multiple cells, we must track which + ;; items have been processed already so that we don't have + ;; duplicate collision results which will almost certainly + ;; yield strange behavior. + (unless (hashq-ref visited other) + ;; The user-provided filter is expected to return a procedure + ;; that can resolve a collision between itself and other, + ;; should one occur. If the items should clip through each + ;; other without any collision, the filter returns #f and we + ;; do not waste any time testing for collision. + (let ((resolve (filter item other))) + (when resolve + (when (collision? rect other-rect goal) + (array-list-push! collisions + (list other + (overlap-area rect other-rect goal) + resolve))))))) + grid search-rect) + ;; Sort collisions by overlap area and return the biggest + ;; collision. There's definitely improvements that can be made in + ;; the heuristic department here, but it's enough for now. + (sort-by-area collisions) + ;; Return the biggest collision. + (if (array-list-empty? collisions) + #f + (array-list-ref collisions 0)))) + +(define (grid-resolve-collisions grid item goal filter) + "Check if moving ITEM in GRID to GOAL causes collisions, and if +so, resolve them using HANDLER." + (let ((visited (grid-visited grid))) + (define (collide) + (match (grid-find-collision grid item goal filter) + ((other _ resolve) + (hashq-set! visited other #t) + (resolve item + (grid-rect-ref grid item) + other + (grid-rect-ref grid other) + goal) + ;; Resolving the collision may have caused an another + ;; collision, so we must perform the collision test again. + ;; This loop continues until the item is no longer colliding + ;; with any other item. + (collide)) + (#f #f))) + ;; Reset shared scratch space. + (hash-clear! visited) + ;; Never check collision against ourselves. + (hashq-set! visited item #t) + (collide))) + +(define (grid-move grid item position filter) + "Attempt to move ITEM in GRID to POSITION (a 2D vector) and check +for collisions. For each collision, HANDLER will be called with two +arguments: ITEM and the item it collided with. If a collision occurs, +POSITION may be modified to resolve the colliding objects." + (grid-resolve-collisions grid item position filter) + (grid-update grid item position)) + +(define (grid-clear grid) + "Remove all items from GRID." + (hash-clear! (grid-rects grid)) + (hash-clear! (grid-rows grid))) + +(define (grid-cell-count grid) + "Return the number of cells in GRID." + (hash-fold (lambda (y row result) + (+ result (hash-count (const #t) row))) + 0 + (grid-rows grid))) + +(define (grid-item-count grid) + "Return the number of items in GRID." + (hash-count (const #t) (grid-rects grid))) diff --git a/examples/grid.scm b/examples/grid.scm new file mode 100644 index 0000000..39ad50e --- /dev/null +++ b/examples/grid.scm @@ -0,0 +1,87 @@ +(use-modules (chickadee) + (chickadee math grid) + (chickadee math vector) + (chickadee math rect) + (chickadee render) + (chickadee render color) + (chickadee render font) + (chickadee render shapes) + (chickadee render sprite) + (chickadee sdl) + (sdl2 input keyboard)) + +(define font #f) +(define grid (make-grid)) +(define item-color (make-color 0.7 0.0 0.0 0.5)) +(define cell-color (make-color 0.0 0.7 0.0 0.2)) +(define player-color (make-color 0.0 0.0 0.7 0.8)) +(define player-pos #v(32.0 32.0)) +(define player-speed 2) +(define player-velocity #v(0.0 0.0)) + +(define (load) + (set! font (load-font "fonts/good_neighbors_starling.xml")) + (grid-add grid 'wall-left 0 0 32 480) + (grid-add grid 'wall-top 32 448 576 32) + (grid-add grid 'wall-right 608 0 32 480) + (grid-add grid 'wall-bottom 32 0 576 32) + (grid-add grid 'box-1 100 100 100 50) + (grid-add grid 'box-2 300 300 50 100) + (grid-add grid 'box-3 350 150 200 75) + (grid-add grid 'box-4 150 140 130 75) + (grid-add grid 'player (vec2-x player-pos) (vec2-y player-pos) 32 32)) + +(define (update dt) + (set-vec2-x! player-velocity 0.0) + (set-vec2-y! player-velocity 0.0) + (when (key-pressed? 'up) + (set-vec2-y! player-velocity player-speed)) + (when (key-pressed? 'down) + (set-vec2-y! player-velocity (- player-speed))) + (when (key-pressed? 'right) + (set-vec2-x! player-velocity player-speed)) + (when (key-pressed? 'left) + (set-vec2-x! player-velocity (- player-speed))) + (vec2-add! player-pos player-velocity) + (grid-move grid 'player player-pos + (lambda (a b) + (if (eq? a 'player) + slide + #f)))) + +(define %cell-rect + (make-rect 0.0 0.0 (grid-cell-size grid) (grid-cell-size grid))) +(define %cell-count-pos + #v(0.0 0.0)) + +(define number->string* + (let ((cache (make-hash-table))) + (lambda (n) + (or (hashv-ref cache n) + (begin + (let ((s (number->string n))) + (hashv-set! cache n s) + s)))))) + +(define (draw alpha) + (with-blend-mode 'alpha + (let ((size (grid-cell-size grid))) + (for-each-cell (lambda (cell x y) + (set-rect-x! %cell-rect (* x size)) + (set-rect-y! %cell-rect (* y size)) + (draw-filled-rect %cell-rect cell-color)) + grid) + (with-batched-sprites + (for-each-cell (lambda (cell x y) + (set-vec2-x! %cell-count-pos (+ (* x size) (/ size 2))) + (set-vec2-y! %cell-count-pos (+ (* y size) (/ size 2))) + (draw-text font (number->string* (cell-count cell)) + %cell-count-pos)) + grid))) + (for-each-item (lambda (item rect) + (if (eq? item 'player) + (draw-filled-rect rect player-color) + (draw-filled-rect rect item-color))) + grid))) + +(run-game/sdl #:load load #:draw draw #:update update) |