From 602569cd13f8f018194f54f39f4645d36d5b3821 Mon Sep 17 00:00:00 2001 From: David Thompson Date: Fri, 1 Oct 2021 08:16:01 -0400 Subject: Move data structure modules into new (chickadee data ...) namespace. --- Makefile.am | 10 +- chickadee/array-list.scm | 150 --------------- chickadee/audio.scm | 2 +- chickadee/data/array-list.scm | 150 +++++++++++++++ chickadee/data/grid.scm | 408 ++++++++++++++++++++++++++++++++++++++++ chickadee/data/heap.scm | 132 +++++++++++++ chickadee/data/path-finding.scm | 77 ++++++++ chickadee/data/queue.scm | 74 ++++++++ chickadee/graphics/engine.scm | 2 +- chickadee/graphics/model.scm | 2 +- chickadee/graphics/path.scm | 2 +- chickadee/heap.scm | 132 ------------- chickadee/math/grid.scm | 408 ---------------------------------------- chickadee/math/path-finding.scm | 77 -------- chickadee/queue.scm | 74 -------- chickadee/scripting/agenda.scm | 2 +- chickadee/scripting/channel.scm | 4 +- doc/api.texi | 365 +++++++++++++++++------------------ examples/grid.scm | 2 +- 19 files changed, 1040 insertions(+), 1033 deletions(-) delete mode 100644 chickadee/array-list.scm create mode 100644 chickadee/data/array-list.scm create mode 100644 chickadee/data/grid.scm create mode 100644 chickadee/data/heap.scm create mode 100644 chickadee/data/path-finding.scm create mode 100644 chickadee/data/queue.scm delete mode 100644 chickadee/heap.scm delete mode 100644 chickadee/math/grid.scm delete mode 100644 chickadee/math/path-finding.scm delete mode 100644 chickadee/queue.scm diff --git a/Makefile.am b/Makefile.am index 3f7b7d0..9a108d5 100644 --- a/Makefile.am +++ b/Makefile.am @@ -44,21 +44,21 @@ SOURCES = \ chickadee/game-loop.scm \ chickadee/json.scm \ chickadee/base64.scm \ - chickadee/heap.scm \ - chickadee/array-list.scm \ - chickadee/queue.scm \ chickadee/freetype.scm \ chickadee/readline.scm \ chickadee/async-repl.scm \ + chickadee/data/heap.scm \ + chickadee/data/array-list.scm \ + chickadee/data/queue.scm \ + chickadee/data/grid.scm \ + chickadee/data/path-finding.scm \ chickadee/math.scm \ chickadee/math/vector.scm \ chickadee/math/bezier.scm \ chickadee/math/matrix.scm \ chickadee/math/quaternion.scm \ chickadee/math/rect.scm \ - chickadee/math/grid.scm \ chickadee/math/easings.scm \ - chickadee/math/path-finding.scm \ chickadee/audio/mpg123.scm \ chickadee/audio/openal.scm \ chickadee/audio/vorbis.scm \ diff --git a/chickadee/array-list.scm b/chickadee/array-list.scm deleted file mode 100644 index e18f9bf..0000000 --- a/chickadee/array-list.scm +++ /dev/null @@ -1,150 +0,0 @@ -;;; Chickadee Game Toolkit -;;; Copyright © 2017 David Thompson -;;; -;;; 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 -;;; . - -(define-module (chickadee array-list) - #:use-module (chickadee utils) - #:use-module (ice-9 format) - #:use-module (rnrs base) - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-9 gnu) - #:use-module (srfi srfi-43) - #:export (make-array-list - array-list - array-list? - array-list-empty? - array-list-size - array-list-ref - array-list-set! - array-list-push! - array-list-pop! - array-list-delete! - array-list-clear! - array-list-for-each - array-list-fold)) - -(define-record-type - (%make-array-list vector size) - array-list? - (vector array-list-vector set-array-list-vector!) - (size array-list-size set-array-list-size!)) - -(define (display-array-list array-list port) - (display "" port)) - -(set-record-type-printer! display-array-list) - -(define* (make-array-list #:optional (initial-capacity 32)) - (%make-array-list (make-vector initial-capacity) 0)) - -(define (array-list . items) - (let ((l (make-array-list))) - (for-each (lambda (item) - (array-list-push! l item)) - items) - l)) - -(define (array-list-capacity array-list) - (vector-length (array-list-vector array-list))) - -(define (array-list-full? array-list) - (= (array-list-size array-list) - (array-list-capacity array-list))) - -(define (array-list-empty? array-list) - (zero? (array-list-size array-list))) - -(define (expand-array-list! array-list) - (let* ((old-vec (array-list-vector array-list)) - (old-size (vector-length old-vec)) - (new-size (+ old-size (div old-size 2))) - (new-vec (make-vector new-size))) - (vector-copy! new-vec 0 old-vec) - (set-array-list-vector! array-list new-vec))) - -(define (array-list-ref array-list i) - (if (and (>= i 0) (< i (array-list-size array-list))) - (vector-ref (array-list-vector array-list) i) - (error "array list index out of bounds" i))) - -(define (array-list-set! array-list i x) - (vector-set! (array-list-vector array-list) i x)) - -(define (array-list-push! array-list item) - (when (array-list-full? array-list) - (expand-array-list! array-list)) - (let ((index (array-list-size array-list))) - (set-array-list-size! array-list (1+ index)) - (array-list-set! array-list index item))) - -(define (array-list-pop! array-list) - (let* ((index (1- (array-list-size array-list))) - (item (array-list-ref array-list index))) - ;; Remove element reference so it can be GC'd. - (array-list-set! array-list index #f) - (set-array-list-size! array-list index) - item)) - -(define* (array-list-delete! array-list item #:key (equal? equal?) fast?) - (let* ((v (array-list-vector array-list)) - (n (array-list-size array-list))) - (let loop ((i 0)) - (when (< i n) - (if (equal? item (vector-ref v i)) - (begin - (if fast? - ;; Fast: Swap the last element with the element to be - ;; deleted. Constant time but does not preserve - ;; order. - (let ((last (- n 1))) - (vector-set! v i (vector-ref v last)) - (vector-set! v last #f)) - ;; Slow: Shift all elements to the left. Linear time - ;; but preserves order. - (let shift ((j (+ i 1))) - (if (= j n) - (vector-set! v j #f) - (begin - (vector-set! v (- j 1) (vector-ref v j)) - (shift (+ j 1)))))) - (set-array-list-size! array-list (- n 1))) - (loop (+ i 1))))))) - -(define (array-list-clear! array-list) - (let ((vec (array-list-vector array-list))) - ;; Remove all element references so they can be GC'd. - (for-range ((i (array-list-size array-list))) - (vector-set! vec i #f))) - (set-array-list-size! array-list 0) - *unspecified*) - -(define (array-list-for-each proc array-list) - (let ((vec (array-list-vector array-list))) - (for-range ((i (array-list-size array-list))) - (proc i (vector-ref vec i))))) - -(define (array-list-fold proc init array-list) - (let ((vec (array-list-vector array-list))) - (let loop ((i 0) - (prev init)) - (if (< i (array-list-size array-list)) - (loop (1+ i) (proc i (vector-ref vec i) prev)) - prev)))) diff --git a/chickadee/audio.scm b/chickadee/audio.scm index 86b52b2..b340f06 100644 --- a/chickadee/audio.scm +++ b/chickadee/audio.scm @@ -22,11 +22,11 @@ ;;; Code: (define-module (chickadee audio) - #:use-module (chickadee array-list) #:use-module (chickadee audio mpg123) #:use-module ((chickadee audio openal) #:prefix openal:) #:use-module (chickadee audio vorbis) #:use-module (chickadee audio wav) + #:use-module (chickadee data array-list) #:use-module (chickadee math) #:use-module (chickadee math vector) #:use-module (chickadee utils) diff --git a/chickadee/data/array-list.scm b/chickadee/data/array-list.scm new file mode 100644 index 0000000..eb3e32a --- /dev/null +++ b/chickadee/data/array-list.scm @@ -0,0 +1,150 @@ +;;; Chickadee Game Toolkit +;;; Copyright © 2017 David Thompson +;;; +;;; 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 +;;; . + +(define-module (chickadee data array-list) + #:use-module (chickadee utils) + #:use-module (ice-9 format) + #:use-module (rnrs base) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-43) + #:export (make-array-list + array-list + array-list? + array-list-empty? + array-list-size + array-list-ref + array-list-set! + array-list-push! + array-list-pop! + array-list-delete! + array-list-clear! + array-list-for-each + array-list-fold)) + +(define-record-type + (%make-array-list vector size) + array-list? + (vector array-list-vector set-array-list-vector!) + (size array-list-size set-array-list-size!)) + +(define (display-array-list array-list port) + (display "" port)) + +(set-record-type-printer! display-array-list) + +(define* (make-array-list #:optional (initial-capacity 32)) + (%make-array-list (make-vector initial-capacity) 0)) + +(define (array-list . items) + (let ((l (make-array-list))) + (for-each (lambda (item) + (array-list-push! l item)) + items) + l)) + +(define (array-list-capacity array-list) + (vector-length (array-list-vector array-list))) + +(define (array-list-full? array-list) + (= (array-list-size array-list) + (array-list-capacity array-list))) + +(define (array-list-empty? array-list) + (zero? (array-list-size array-list))) + +(define (expand-array-list! array-list) + (let* ((old-vec (array-list-vector array-list)) + (old-size (vector-length old-vec)) + (new-size (+ old-size (div old-size 2))) + (new-vec (make-vector new-size))) + (vector-copy! new-vec 0 old-vec) + (set-array-list-vector! array-list new-vec))) + +(define (array-list-ref array-list i) + (if (and (>= i 0) (< i (array-list-size array-list))) + (vector-ref (array-list-vector array-list) i) + (error "array list index out of bounds" i))) + +(define (array-list-set! array-list i x) + (vector-set! (array-list-vector array-list) i x)) + +(define (array-list-push! array-list item) + (when (array-list-full? array-list) + (expand-array-list! array-list)) + (let ((index (array-list-size array-list))) + (set-array-list-size! array-list (1+ index)) + (array-list-set! array-list index item))) + +(define (array-list-pop! array-list) + (let* ((index (1- (array-list-size array-list))) + (item (array-list-ref array-list index))) + ;; Remove element reference so it can be GC'd. + (array-list-set! array-list index #f) + (set-array-list-size! array-list index) + item)) + +(define* (array-list-delete! array-list item #:key (equal? equal?) fast?) + (let* ((v (array-list-vector array-list)) + (n (array-list-size array-list))) + (let loop ((i 0)) + (when (< i n) + (if (equal? item (vector-ref v i)) + (begin + (if fast? + ;; Fast: Swap the last element with the element to be + ;; deleted. Constant time but does not preserve + ;; order. + (let ((last (- n 1))) + (vector-set! v i (vector-ref v last)) + (vector-set! v last #f)) + ;; Slow: Shift all elements to the left. Linear time + ;; but preserves order. + (let shift ((j (+ i 1))) + (if (= j n) + (vector-set! v j #f) + (begin + (vector-set! v (- j 1) (vector-ref v j)) + (shift (+ j 1)))))) + (set-array-list-size! array-list (- n 1))) + (loop (+ i 1))))))) + +(define (array-list-clear! array-list) + (let ((vec (array-list-vector array-list))) + ;; Remove all element references so they can be GC'd. + (for-range ((i (array-list-size array-list))) + (vector-set! vec i #f))) + (set-array-list-size! array-list 0) + *unspecified*) + +(define (array-list-for-each proc array-list) + (let ((vec (array-list-vector array-list))) + (for-range ((i (array-list-size array-list))) + (proc i (vector-ref vec i))))) + +(define (array-list-fold proc init array-list) + (let ((vec (array-list-vector array-list))) + (let loop ((i 0) + (prev init)) + (if (< i (array-list-size array-list)) + (loop (1+ i) (proc i (vector-ref vec i) prev)) + prev)))) diff --git a/chickadee/data/grid.scm b/chickadee/data/grid.scm new file mode 100644 index 0000000..085fbcb --- /dev/null +++ b/chickadee/data/grid.scm @@ -0,0 +1,408 @@ +;;; Chickadee Game Toolkit +;;; Copyright © 2018 David Thompson +;;; +;;; 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 +;;; . + +;;; Commentary: +;; +;; Axis-aligned bounding box collision grid. +;; +;; Lots of inspiration drawn from https://github.com/kikito/bump.lua +;; +;;; Code: + +(define-module (chickadee data grid) + #:use-module (chickadee data array-list) + #:use-module (chickadee math rect) + #:use-module (chickadee math vector) + #:use-module (ice-9 match) + #:use-module (rnrs bytevectors) + #: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 + grid-rect-ref + for-each-cell + grid-cell-fold + for-each-item + grid-item-fold)) + + +;;; +;;; 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 + (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))) + + +;;; +;;; Grid +;;; + +(define-record-type + (%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.0)) + "Create new grid partitioned by CELL-SIZE." + (%make-grid (f32vector cell-size) + (make-hash-table 1000) + (make-hash-table) + (make-rect 0.0 0.0 0.0 0.0) + (make-array-list) + (make-hash-table))) + +(define-inlinable (grid-cell-size grid) + (f32vector-ref (%grid-cell-size grid) 0)) + +(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." + (let ((cell-size (grid-cell-size grid)) + (x (rect-x rect)) + (y (rect-y rect)) + (w (rect-width rect)) + (h (rect-height rect))) + (define (to-cell n) + (inexact->exact (floor (/ n cell-size)))) + (values (to-cell x) + (to-cell (+ x w)) + (to-cell y) + (to-cell (+ y h))))) + +(define-inlinable (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 (grid-cell-fold proc init grid) + (hash-fold (lambda (y row memo) + (hash-fold (lambda (x cell memo) + (proc cell x y memo)) + memo + row)) + init + (grid-rows grid))) + +(define (for-each-item proc grid) + "Call PROC for each item in GRID." + (hash-for-each proc (grid-rects grid))) + +(define (grid-item-fold proc init grid) + (hash-fold proc init (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 inexact->exact* + (let ((cache '())) + (lambda (n) + (or (assv-ref cache n) + (let ((result (inexact->exact n))) + (set! cache (cons (cons n result) cache)) + result))))) + +(define (grid-move grid item goal filter) + "Attempt to move ITEM in GRID to POSITION (a 2D vector) and check +for collisions. For each collision, FILTER 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." + (let* ((rect (grid-rect-ref grid item)) + (x (rect-x rect)) + (y (rect-y rect)) + (w (rect-width rect)) + (h (rect-height rect)) + (cell-size (grid-cell-size grid)) + (collisions (grid-buffer grid)) + (visited (grid-visited grid))) + (define (to-cell n) + (inexact->exact* (floor (/ n cell-size)))) + (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)))))) + (define (check 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 (and resolve (collision? rect other-rect goal)) + (array-list-push! collisions + (list other + (overlap-area rect other-rect goal) + resolve)))))) + (define (sort-by-area) + ;; 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 (find-collisions) + ;; 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. + (let* ((goal-x (vec2-x goal)) + (goal-y (vec2-y goal)) + (search-x (min goal-x x)) + (search-y (min goal-y y)) + (search-w (+ w (min (- goal-x x) 0.0))) + (search-h (+ h (min (- goal-y y) 0.0))) + (minx (to-cell x)) + (maxx (to-cell (+ x w))) + (miny (to-cell y)) + (maxy (to-cell (+ y h)))) + ;; Reset our scratch space. + (array-list-clear! collisions) + ;; Visit every cell in the search area. + (let yloop ((cy miny)) + (when (<= cy maxy) + (let ((row (grid-row-ref grid cy))) + (let xloop ((cx minx)) + (when (<= cx maxx) + (let ((cell (row-column-ref row cx))) + (hash-for-each (lambda (other unused) + (check other (grid-rect-ref grid other))) + (cell-items cell))) + (xloop (+ cx 1))))) + (yloop (+ cy 1)))) + ;; 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) + ;; Return the biggest collision. + (if (array-list-empty? collisions) + #f + (array-list-ref collisions 0)))) + (define (collide) + (match (find-collisions) + ((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) + (let* ((new-x (vec2-x goal)) + (new-y (vec2-y goal)) + (minx1 (to-cell x)) + (miny1 (to-cell y)) + (maxx1 (to-cell (+ x w))) + (maxy1 (to-cell (+ y h))) + (minx2 (to-cell new-x)) + (miny2 (to-cell new-y)) + (maxx2 (to-cell (+ new-x w))) + (maxy2 (to-cell (+ new-y h)))) + (set-rect-x! rect new-x) + (set-rect-y! rect new-y) + (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) + (when (or (< x minx1) (> x maxx1) + (< y miny1) (> y maxy1)) + (cell-add (grid-cell-ref grid x y) item))) + minx2 maxx2 miny2 maxy2)))) + +(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/chickadee/data/heap.scm b/chickadee/data/heap.scm new file mode 100644 index 0000000..2dd4027 --- /dev/null +++ b/chickadee/data/heap.scm @@ -0,0 +1,132 @@ +;;; Chickadee Game Toolkit +;;; Copyright © 2017 David Thompson +;;; +;;; 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 +;;; . + +(define-module (chickadee data heap) + #:use-module (ice-9 format) + #:use-module (rnrs base) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-43) + #:export (make-heap + heap? + heap-empty? + heap-size + heap-min + heap-insert! + heap-remove! + heap-clear!)) + +;; A binary heap. +(define-record-type + (%make-heap vector size <) + heap? + (vector heap-vector set-heap-vector!) + (size heap-size set-heap-size!) + (< heap-<)) + +(define (display-heap heap port) + (format port "#" (heap-size heap))) + +(set-record-type-printer! display-heap) + +(define* (make-heap #:optional (< <)) + "Create a new heap that uses the < procedure to determine order." + (%make-heap (make-vector 32 #f) 0 <)) + +(define (heap-empty? heap) + "Return #t if HEAP is empty." + (zero? (heap-size heap))) + +(define (heap-capacity heap) + (1- (vector-length (heap-vector heap)))) + +(define (heap-full? heap) + (= (heap-size heap) (heap-capacity heap))) + +(define (double-heap-capacity! heap) + (let* ((old-vec (heap-vector heap)) + (new-vec (make-vector (* (vector-length old-vec) 2) #f))) + (vector-copy! new-vec 0 old-vec) + (set-heap-vector! heap new-vec))) + +(define (heap-min heap) + "Return the minimum element of HEAP." + (if (zero? (heap-size heap)) + (error "empty heap" heap) + (vector-ref (heap-vector heap) 1))) + +(define (heap-set! heap i item) + (vector-set! (heap-vector heap) i item)) + +(define (heap-ref heap i) + (vector-ref (heap-vector heap) i)) + +(define (heap-insert! heap item) + "Add ITEM to HEAP." + (when (heap-full? heap) + (double-heap-capacity! heap)) + (let ((hole (1+ (heap-size heap))) + (< (heap-< heap))) + (set-heap-size! heap hole) + (let loop ((hole hole)) + (let* ((parent-hole (div hole 2)) + (parent-item (heap-ref heap parent-hole))) + (if (and (> hole 1) (< item parent-item)) + (begin + (heap-set! heap hole parent-item) + (loop parent-hole)) + (heap-set! heap hole item)))))) + +(define (heap-remove! heap) + "Remove the minimum element of HEAP." + (let ((size (1- (heap-size heap))) + (< (heap-< heap))) + (define (finish hole) + (heap-set! heap (heap-size heap) #f) + (heap-set! heap 0 #f) + (set-heap-size! heap size) + *unspecified*) + + (define (leaf? hole) + (> (* hole 2) size)) + + (define (smallest-child hole) + (let ((left-child (* hole 2)) + (right-child (1+ (* hole 2)))) + (if (or (= left-child size) + (< (heap-ref heap left-child) (heap-ref heap right-child))) + left-child + right-child))) + + (heap-set! heap 1 (heap-ref heap (heap-size heap))) + + (let loop ((hole 1)) + (if (leaf? hole) + (finish hole) + (let ((child (smallest-child hole))) + (if (< (heap-ref heap hole) (heap-ref heap child)) + (finish hole) + (begin + (heap-set! heap 0 (heap-ref heap hole)) + (heap-set! heap hole (heap-ref heap child)) + (heap-set! heap child (heap-ref heap 0)) + (loop child)))))))) + +(define (heap-clear! heap) + "Remove all elements from HEAP." + (vector-fill! (heap-vector heap) #f) + (set-heap-size! heap 0)) diff --git a/chickadee/data/path-finding.scm b/chickadee/data/path-finding.scm new file mode 100644 index 0000000..c9cadf9 --- /dev/null +++ b/chickadee/data/path-finding.scm @@ -0,0 +1,77 @@ +;;; Copyright © 2017 David Thompson +;;; +;;; 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 +;;; . + +;;; Commentary: +;; +;; Generalized A* pathfinding algorithm. +;; +;;; Code + +(define-module (chickadee data path-finding) + #:use-module (chickadee data heap) + #:use-module (srfi srfi-9) + #:export (make-path-finder + path-finder? + a*)) + +(define-record-type + (%make-path-finder frontier came-from cost-so-far) + path-finder? + (frontier path-finder-frontier) + (came-from path-finder-came-from) + (cost-so-far path-finder-cost-so-far)) + +(define (make-path-finder) + "Create a new path finder object." + (%make-path-finder (make-heap (lambda (a b) (< (cdr a) (cdr b)))) + (make-hash-table) + (make-hash-table))) + +(define (a* path-finder start goal neighbors cost distance) + "Return a list of nodes forming a path from START to GOAL using +PATH-FINDER. NEIGHBORS is a procedure that accepts a node and returns +a list of nodes that neighbor it. COST is a procedure that accepts +two neighboring nodes and returns the cost of moving from the first to +the second as a number. DISTANCE is a procedure that accepts two +nodes and returns an approximate distance between them." + (let ((frontier (path-finder-frontier path-finder)) + (came-from (path-finder-came-from path-finder)) + (cost-so-far (path-finder-cost-so-far path-finder))) + (heap-insert! frontier (cons start 0)) + (hashq-set! came-from start #f) + (hashq-set! cost-so-far start 0) + (let loop () + (unless (heap-empty? frontier) + (let ((current (car (heap-min frontier)))) + (heap-remove! frontier) + (unless (eq? current goal) + (for-each (lambda (next) + (let ((new-cost (+ (hashq-ref cost-so-far current) + (cost current next)))) + (when (or (not (hashq-ref cost-so-far next)) + (< new-cost (hashq-ref cost-so-far next))) + (hashq-set! cost-so-far next new-cost) + (let ((priority (+ new-cost (distance goal next)))) + (heap-insert! frontier (cons next priority))) + (hashq-set! came-from next current)))) + (neighbors current)) + (loop))))) + ;; Walk backwards to build the path from start to goal as a list. + (let loop ((node goal) + (path '())) + (if (eq? node start) + (cons start path) + (loop (hashq-ref came-from node) (cons node path)))))) diff --git a/chickadee/data/queue.scm b/chickadee/data/queue.scm new file mode 100644 index 0000000..157001c --- /dev/null +++ b/chickadee/data/queue.scm @@ -0,0 +1,74 @@ +;;; Chickadee Game Toolkit +;;; Copyright © 2017, 2018 David Thompson +;;; +;;; 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 +;;; . + +(define-module (chickadee data queue) + #:use-module (ice-9 format) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) + #:use-module (chickadee data array-list) + #:export (make-queue + queue? + queue-length + queue-empty? + enqueue! + dequeue! + queue-clear!)) + +(define-record-type + (%make-queue input output) + queue? + (input queue-input) + (output queue-output)) + +(define (display-queue q port) + (format port "#" (queue-length q))) + +(set-record-type-printer! display-queue) + +(define (make-queue) + "Return a new, empty queue." + (%make-queue (make-array-list) (make-array-list))) + +(define (queue-length q) + "Return the number of elements in Q." + (+ (array-list-size (queue-input q)) + (array-list-size (queue-output q)))) + +(define (queue-empty? q) + "Return #t if Q is empty." + (zero? (queue-length q))) + +(define (enqueue! q item) + "Add ITEM to Q." + (array-list-push! (queue-input q) item)) + +(define (dequeue! q) + "Remove the first element of Q." + (and (not (queue-empty? q)) + (let ((input (queue-input q)) + (output (queue-output q))) + (when (array-list-empty? output) + (let loop () + (unless (array-list-empty? input) + (array-list-push! output (array-list-pop! input)) + (loop)))) + (array-list-pop! output)))) + +(define (queue-clear! q) + "Remove all items from Q." + (array-list-clear! (queue-input q)) + (array-list-clear! (queue-output q))) diff --git a/chickadee/graphics/engine.scm b/chickadee/graphics/engine.scm index 3b8e743..7fe6def 100644 --- a/chickadee/graphics/engine.scm +++ b/chickadee/graphics/engine.scm @@ -1,5 +1,5 @@ (define-module (chickadee graphics engine) - #:use-module (chickadee array-list) + #:use-module (chickadee data array-list) #:use-module (chickadee graphics gl) #:use-module (chickadee math matrix) #:use-module (gl) diff --git a/chickadee/graphics/model.scm b/chickadee/graphics/model.scm index 309b00f..9de562b 100644 --- a/chickadee/graphics/model.scm +++ b/chickadee/graphics/model.scm @@ -22,8 +22,8 @@ ;;; Code: (define-module (chickadee graphics model) - #:use-module (chickadee array-list) #:use-module (chickadee base64) + #:use-module (chickadee data array-list) #:use-module (chickadee json) #:use-module (chickadee math matrix) #:use-module (chickadee math quaternion) diff --git a/chickadee/graphics/path.scm b/chickadee/graphics/path.scm index ee501ce..27eb0b1 100644 --- a/chickadee/graphics/path.scm +++ b/chickadee/graphics/path.scm @@ -22,8 +22,8 @@ ;;; Code: (define-module (chickadee graphics path) - #:use-module (chickadee array-list) #:use-module (chickadee config) + #:use-module (chickadee data array-list) #:use-module (chickadee graphics blend) #:use-module (chickadee graphics buffer) #:use-module (chickadee graphics color) diff --git a/chickadee/heap.scm b/chickadee/heap.scm deleted file mode 100644 index 3a7d17e..0000000 --- a/chickadee/heap.scm +++ /dev/null @@ -1,132 +0,0 @@ -;;; Chickadee Game Toolkit -;;; Copyright © 2017 David Thompson -;;; -;;; 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 -;;; . - -(define-module (chickadee heap) - #:use-module (ice-9 format) - #:use-module (rnrs base) - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-9 gnu) - #:use-module (srfi srfi-43) - #:export (make-heap - heap? - heap-empty? - heap-size - heap-min - heap-insert! - heap-remove! - heap-clear!)) - -;; A binary heap. -(define-record-type - (%make-heap vector size <) - heap? - (vector heap-vector set-heap-vector!) - (size heap-size set-heap-size!) - (< heap-<)) - -(define (display-heap heap port) - (format port "#" (heap-size heap))) - -(set-record-type-printer! display-heap) - -(define* (make-heap #:optional (< <)) - "Create a new heap that uses the < procedure to determine order." - (%make-heap (make-vector 32 #f) 0 <)) - -(define (heap-empty? heap) - "Return #t if HEAP is empty." - (zero? (heap-size heap))) - -(define (heap-capacity heap) - (1- (vector-length (heap-vector heap)))) - -(define (heap-full? heap) - (= (heap-size heap) (heap-capacity heap))) - -(define (double-heap-capacity! heap) - (let* ((old-vec (heap-vector heap)) - (new-vec (make-vector (* (vector-length old-vec) 2) #f))) - (vector-copy! new-vec 0 old-vec) - (set-heap-vector! heap new-vec))) - -(define (heap-min heap) - "Return the minimum element of HEAP." - (if (zero? (heap-size heap)) - (error "empty heap" heap) - (vector-ref (heap-vector heap) 1))) - -(define (heap-set! heap i item) - (vector-set! (heap-vector heap) i item)) - -(define (heap-ref heap i) - (vector-ref (heap-vector heap) i)) - -(define (heap-insert! heap item) - "Add ITEM to HEAP." - (when (heap-full? heap) - (double-heap-capacity! heap)) - (let ((hole (1+ (heap-size heap))) - (< (heap-< heap))) - (set-heap-size! heap hole) - (let loop ((hole hole)) - (let* ((parent-hole (div hole 2)) - (parent-item (heap-ref heap parent-hole))) - (if (and (> hole 1) (< item parent-item)) - (begin - (heap-set! heap hole parent-item) - (loop parent-hole)) - (heap-set! heap hole item)))))) - -(define (heap-remove! heap) - "Remove the minimum element of HEAP." - (let ((size (1- (heap-size heap))) - (< (heap-< heap))) - (define (finish hole) - (heap-set! heap (heap-size heap) #f) - (heap-set! heap 0 #f) - (set-heap-size! heap size) - *unspecified*) - - (define (leaf? hole) - (> (* hole 2) size)) - - (define (smallest-child hole) - (let ((left-child (* hole 2)) - (right-child (1+ (* hole 2)))) - (if (or (= left-child size) - (< (heap-ref heap left-child) (heap-ref heap right-child))) - left-child - right-child))) - - (heap-set! heap 1 (heap-ref heap (heap-size heap))) - - (let loop ((hole 1)) - (if (leaf? hole) - (finish hole) - (let ((child (smallest-child hole))) - (if (< (heap-ref heap hole) (heap-ref heap child)) - (finish hole) - (begin - (heap-set! heap 0 (heap-ref heap hole)) - (heap-set! heap hole (heap-ref heap child)) - (heap-set! heap child (heap-ref heap 0)) - (loop child)))))))) - -(define (heap-clear! heap) - "Remove all elements from HEAP." - (vector-fill! (heap-vector heap) #f) - (set-heap-size! heap 0)) diff --git a/chickadee/math/grid.scm b/chickadee/math/grid.scm deleted file mode 100644 index 7b2b6d6..0000000 --- a/chickadee/math/grid.scm +++ /dev/null @@ -1,408 +0,0 @@ -;;; Chickadee Game Toolkit -;;; Copyright © 2018 David Thompson -;;; -;;; 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 -;;; . - -;;; 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 (rnrs bytevectors) - #: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 - grid-rect-ref - for-each-cell - grid-cell-fold - for-each-item - grid-item-fold)) - - -;;; -;;; 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 - (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))) - - -;;; -;;; Grid -;;; - -(define-record-type - (%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.0)) - "Create new grid partitioned by CELL-SIZE." - (%make-grid (f32vector cell-size) - (make-hash-table 1000) - (make-hash-table) - (make-rect 0.0 0.0 0.0 0.0) - (make-array-list) - (make-hash-table))) - -(define-inlinable (grid-cell-size grid) - (f32vector-ref (%grid-cell-size grid) 0)) - -(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." - (let ((cell-size (grid-cell-size grid)) - (x (rect-x rect)) - (y (rect-y rect)) - (w (rect-width rect)) - (h (rect-height rect))) - (define (to-cell n) - (inexact->exact (floor (/ n cell-size)))) - (values (to-cell x) - (to-cell (+ x w)) - (to-cell y) - (to-cell (+ y h))))) - -(define-inlinable (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 (grid-cell-fold proc init grid) - (hash-fold (lambda (y row memo) - (hash-fold (lambda (x cell memo) - (proc cell x y memo)) - memo - row)) - init - (grid-rows grid))) - -(define (for-each-item proc grid) - "Call PROC for each item in GRID." - (hash-for-each proc (grid-rects grid))) - -(define (grid-item-fold proc init grid) - (hash-fold proc init (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 inexact->exact* - (let ((cache '())) - (lambda (n) - (or (assv-ref cache n) - (let ((result (inexact->exact n))) - (set! cache (cons (cons n result) cache)) - result))))) - -(define (grid-move grid item goal filter) - "Attempt to move ITEM in GRID to POSITION (a 2D vector) and check -for collisions. For each collision, FILTER 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." - (let* ((rect (grid-rect-ref grid item)) - (x (rect-x rect)) - (y (rect-y rect)) - (w (rect-width rect)) - (h (rect-height rect)) - (cell-size (grid-cell-size grid)) - (collisions (grid-buffer grid)) - (visited (grid-visited grid))) - (define (to-cell n) - (inexact->exact* (floor (/ n cell-size)))) - (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)))))) - (define (check 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 (and resolve (collision? rect other-rect goal)) - (array-list-push! collisions - (list other - (overlap-area rect other-rect goal) - resolve)))))) - (define (sort-by-area) - ;; 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 (find-collisions) - ;; 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. - (let* ((goal-x (vec2-x goal)) - (goal-y (vec2-y goal)) - (search-x (min goal-x x)) - (search-y (min goal-y y)) - (search-w (+ w (min (- goal-x x) 0.0))) - (search-h (+ h (min (- goal-y y) 0.0))) - (minx (to-cell x)) - (maxx (to-cell (+ x w))) - (miny (to-cell y)) - (maxy (to-cell (+ y h)))) - ;; Reset our scratch space. - (array-list-clear! collisions) - ;; Visit every cell in the search area. - (let yloop ((cy miny)) - (when (<= cy maxy) - (let ((row (grid-row-ref grid cy))) - (let xloop ((cx minx)) - (when (<= cx maxx) - (let ((cell (row-column-ref row cx))) - (hash-for-each (lambda (other unused) - (check other (grid-rect-ref grid other))) - (cell-items cell))) - (xloop (+ cx 1))))) - (yloop (+ cy 1)))) - ;; 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) - ;; Return the biggest collision. - (if (array-list-empty? collisions) - #f - (array-list-ref collisions 0)))) - (define (collide) - (match (find-collisions) - ((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) - (let* ((new-x (vec2-x goal)) - (new-y (vec2-y goal)) - (minx1 (to-cell x)) - (miny1 (to-cell y)) - (maxx1 (to-cell (+ x w))) - (maxy1 (to-cell (+ y h))) - (minx2 (to-cell new-x)) - (miny2 (to-cell new-y)) - (maxx2 (to-cell (+ new-x w))) - (maxy2 (to-cell (+ new-y h)))) - (set-rect-x! rect new-x) - (set-rect-y! rect new-y) - (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) - (when (or (< x minx1) (> x maxx1) - (< y miny1) (> y maxy1)) - (cell-add (grid-cell-ref grid x y) item))) - minx2 maxx2 miny2 maxy2)))) - -(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/chickadee/math/path-finding.scm b/chickadee/math/path-finding.scm deleted file mode 100644 index d89c2fc..0000000 --- a/chickadee/math/path-finding.scm +++ /dev/null @@ -1,77 +0,0 @@ -;;; Copyright © 2017 David Thompson -;;; -;;; 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 -;;; . - -;;; Commentary: -;; -;; Generalized A* pathfinding algorithm. -;; -;;; Code - -(define-module (chickadee math path-finding) - #:use-module (chickadee heap) - #:use-module (srfi srfi-9) - #:export (make-path-finder - path-finder? - a*)) - -(define-record-type - (%make-path-finder frontier came-from cost-so-far) - path-finder? - (frontier path-finder-frontier) - (came-from path-finder-came-from) - (cost-so-far path-finder-cost-so-far)) - -(define (make-path-finder) - "Create a new path finder object." - (%make-path-finder (make-heap (lambda (a b) (< (cdr a) (cdr b)))) - (make-hash-table) - (make-hash-table))) - -(define (a* path-finder start goal neighbors cost distance) - "Return a list of nodes forming a path from START to GOAL using -PATH-FINDER. NEIGHBORS is a procedure that accepts a node and returns -a list of nodes that neighbor it. COST is a procedure that accepts -two neighboring nodes and returns the cost of moving from the first to -the second as a number. DISTANCE is a procedure that accepts two -nodes and returns an approximate distance between them." - (let ((frontier (path-finder-frontier path-finder)) - (came-from (path-finder-came-from path-finder)) - (cost-so-far (path-finder-cost-so-far path-finder))) - (heap-insert! frontier (cons start 0)) - (hashq-set! came-from start #f) - (hashq-set! cost-so-far start 0) - (let loop () - (unless (heap-empty? frontier) - (let ((current (car (heap-min frontier)))) - (heap-remove! frontier) - (unless (eq? current goal) - (for-each (lambda (next) - (let ((new-cost (+ (hashq-ref cost-so-far current) - (cost current next)))) - (when (or (not (hashq-ref cost-so-far next)) - (< new-cost (hashq-ref cost-so-far next))) - (hashq-set! cost-so-far next new-cost) - (let ((priority (+ new-cost (distance goal next)))) - (heap-insert! frontier (cons next priority))) - (hashq-set! came-from next current)))) - (neighbors current)) - (loop))))) - ;; Walk backwards to build the path from start to goal as a list. - (let loop ((node goal) - (path '())) - (if (eq? node start) - (cons start path) - (loop (hashq-ref came-from node) (cons node path)))))) diff --git a/chickadee/queue.scm b/chickadee/queue.scm deleted file mode 100644 index 39f6318..0000000 --- a/chickadee/queue.scm +++ /dev/null @@ -1,74 +0,0 @@ -;;; Chickadee Game Toolkit -;;; Copyright © 2017, 2018 David Thompson -;;; -;;; 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 -;;; . - -(define-module (chickadee queue) - #:use-module (ice-9 format) - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-9 gnu) - #:use-module (chickadee array-list) - #:export (make-queue - queue? - queue-length - queue-empty? - enqueue! - dequeue! - queue-clear!)) - -(define-record-type - (%make-queue input output) - queue? - (input queue-input) - (output queue-output)) - -(define (display-queue q port) - (format port "#" (queue-length q))) - -(set-record-type-printer! display-queue) - -(define (make-queue) - "Return a new, empty queue." - (%make-queue (make-array-list) (make-array-list))) - -(define (queue-length q) - "Return the number of elements in Q." - (+ (array-list-size (queue-input q)) - (array-list-size (queue-output q)))) - -(define (queue-empty? q) - "Return #t if Q is empty." - (zero? (queue-length q))) - -(define (enqueue! q item) - "Add ITEM to Q." - (array-list-push! (queue-input q) item)) - -(define (dequeue! q) - "Remove the first element of Q." - (and (not (queue-empty? q)) - (let ((input (queue-input q)) - (output (queue-output q))) - (when (array-list-empty? output) - (let loop () - (unless (array-list-empty? input) - (array-list-push! output (array-list-pop! input)) - (loop)))) - (array-list-pop! output)))) - -(define (queue-clear! q) - "Remove all items from Q." - (array-list-clear! (queue-input q)) - (array-list-clear! (queue-output q))) diff --git a/chickadee/scripting/agenda.scm b/chickadee/scripting/agenda.scm index a5097dc..eb1fa65 100644 --- a/chickadee/scripting/agenda.scm +++ b/chickadee/scripting/agenda.scm @@ -16,9 +16,9 @@ ;;; . (define-module (chickadee scripting agenda) + #:use-module (chickadee data heap) #:use-module (ice-9 match) #:use-module (srfi srfi-9) - #:use-module (chickadee heap) #:export (make-agenda agenda? current-agenda diff --git a/chickadee/scripting/channel.scm b/chickadee/scripting/channel.scm index b54d3e2..c12ab9e 100644 --- a/chickadee/scripting/channel.scm +++ b/chickadee/scripting/channel.scm @@ -16,11 +16,11 @@ ;;; . (define-module (chickadee scripting channel) + #:use-module (chickadee data queue) + #:use-module (chickadee scripting script) #:use-module (ice-9 match) #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) - #:use-module (chickadee queue) - #:use-module (chickadee scripting script) #:export (make-channel channel? channel-get! diff --git a/doc/api.texi b/doc/api.texi index 6a1361d..96803b8 100644 --- a/doc/api.texi +++ b/doc/api.texi @@ -4,6 +4,7 @@ * Graphics:: 2D and 3D rendering. * Audio:: Make some noise. * Scripting:: Bringing the game world to life. +* Data Structures:: Spatial partitioning and more. @end menu @node Kernel @@ -531,8 +532,6 @@ detection. * Quaternions:: Rotations about an arbitrary axis. * Easings:: Easing functions for interesting animations. * Bezier Curves:: Cubic Bezier curves and paths in 2D space. -* Path Finding:: Generic A* path finding. -* Grid:: Spatial partitioning for bounding boxes. @end menu @node Basics @@ -1377,183 +1376,6 @@ Modify the 2D vector @var{dest} in-place to contain the coordinates for @var{bezier} at @var{t}. @end deffn -@node Path Finding -@subsection Path Finding - -Most game worlds have maps. Often, these games have a need to move -non-player characters around in an unscripted fashion. For example, -in a real-time strategy game, the player may command one of their -units to attack something in the enemy base. To do so, the unit must -calculate the shortest route to get there. It wouldn't be a very fun -game if units didn't know how to transport themselves efficiently. -This is where path finding algorithms come in handy. The -@code{(chickadee math path-finding)} module provides a generic -implementation of the popular A* path finding algorithm. Just add a -map implementation! - -The example below defines a very simple town map and finds the -quickest way to get from the town common to the school. - -@example -(define world-map - '((town-common . (town-hall library)) - (town-hall . (town-common school)) - (library . (town-common cafe)) - (school . (town-hall cafe)) - (cafe . (library school)))) -(define (neighbors building) - (assq-ref town-map building)) -(define (cost a b) 1) -(define (distance a b) 1) -(define pf (make-path-finder)) -(a* pf 'town-common 'school neighbors cost distance) -@end example - -In this case, the @code{a*} procedure will return the list -@code{(town-common town-hall school)}, which is indeed the shortest -route. (The other possible route is @code{(town-common library cafe -school)}.) - -The @code{a*} procedure does not know anything about about any kind of -map and therefore must be told how to look up neighboring nodes, which -is what the @code{neighbors} procedure in the example does. To -simulate different types of terrain, a cost procedure is used. In -this example, it is just as easy to move between any two nodes because -@code{cost} always returns 1. In a real game, perhaps moving from -from a field to a rocky hill would cost a lot more than moving from -one field to another. Finally, a heuristic is used to calculate an -approximate distance between two nodes on the map. In this simple -association list based graph it is tough to calculate a distance -between nodes, so the @code{distance} procedure isn't helpful and -always returns 1. In a real game with a tile-based map, for example, -the heuristic could be a quick Manhattan distance calculation based on -the coordinates of the two map tiles. Choose an appropriate heuristic -for optimal path finding! - -@deffn {Procedure} make-path-finder -Return a new path finder object. -@end deffn - -@deffn {Procedure} path-finder? obj -Return @code{#t} if @var{obj} is a path finder. -@end deffn - -@deffn {Procedure} a* path-finder start goal neighbors cost distance - -Return a list of nodes forming a path from @var{start} to @var{goal} -using @var{path-finder} to hold state. @var{neighbors} is a procedure -that accepts a node and returns a list of nodes that neighbor it. -@var{cost} is a procedure that accepts two neighboring nodes and -returns the cost of moving from the first to the second as a real -number. @var{distance} is a procedure that accepts two nodes and -returns an approximate distance between them. -@end deffn - -@node Grid -@subsection Grid - -The @code{(chickadee math grid)} module provides a simple spatial -partitioning system for axis-aligned bounding boxes -(@pxref{Rectangles}) in 2D space. The grid divides the world into -tiles and keeps track of which rectangles occupy which tiles. When -there are lots of moving objects in the game world that need collision -detection, the grid greatly speeds up the process. Instead of -checking collisions of each object against every other object (an -O(n^2) operation), the grid quickly narrows down which objects could -possibly be colliding and only performs collision testing against a -small set of objects. - -In addition to checking for collisions, the grid also handles the -resolution of collisions. Exactly how each collision is resolved is -user-defined. A player bumping into a wall may slide against it. An -enemy colliding with a projectile shot by the player may get pushed -back in the opposite direction. Two players colliding may not need -resolution at all and will just pass through each other. The way this -works is that each time an object (A) is moved within the grid, the -grid looks for an object (B) that may possibly be colliding with A. A -user-defined procedure known as a ``filter'' is then called with both -A and B. If the filter returns @code{#f}, it means that even if A and -B are colliding, no collision resolution is needed. In this case the -grid won't waste time checking if they really do collide because it -doesn't matter. If A and B are collidable, then the filter returns a -procedure that implements the resolution technique. The grid will -then perform a collision test. If A and B are colliding, the resolver -procedure is called. It's the resolvers job to adjust the objects -such that they are no longer colliding. The grid module comes with a -very simple resolution procedure, @code{slide}, that adjusts object A -by the smallest amount so that it no longer overlaps with B. By using -this filtering technique, a game can resolve collisions between -different objects in different ways. - -@deffn {Procedure} make-grid [cell-size 64] -Return a new grid partitioned into @var{cell-size} tiles. -@end deffn - -@deffn {Procedure} grid? obj -Return @code{#t} if @var{obj} is a grid. -@end deffn - -@deffn {Procedure} cell? obj -Return @code{#t} if @var{obj} is a grid cell. -@end deffn - -@deffn {Procedure} cell-count cell -Return the number of items in @var{cell}. -@end deffn - -@deffn {Procedure} grid-cell-size grid -Return the cell size of @var{grid}. -@end deffn - -@deffn {Procedure} grid-cell-count grid -Return the number of cells currently in @var{grid}. -@end deffn - -@deffn {Procedure} grid-item-count grid -Return the number of items in @var{grid}. -@end deffn - -@deffn {Procedure} grid-add grid item x y @ - width height - -Add @var{item} to @var{grid} represented by the axis-aligned bounding -box whose lower-left corner is at (@var{x}, @var{y}) and is -@var{width} x @var{height} in size. -@end deffn - -@deffn {Procedure} grid-remove grid item -Return @var{item} from @var{grid}. -@end deffn - -@deffn {Procedure} grid-clear grid -Remove all items from @var{grid}. -@end deffn - -@deffn {Procedure} grid-move grid item position filter -Attempt to move @var{item} in @var{grid} to @var{position} (a 2D -vector) and check for collisions. For each collision, @var{filter} -will be called with two arguments: @var{item} and the item it collided -with. If a collision occurs, @var{position} may be modified to -resolve the colliding objects. -@end deffn - -@deffn {Procedure} for-each-cell proc grid [rect] -Call @var{proc} with each cell in @var{grid} that intersects -@var{rect}, or every cell if @var{rect} is @code{#f}. -@end deffn - -@deffn {Procedure} for-each-item proc grid -Call @var{proc} for each item in @var{grid}. -@end deffn - -@deffn {Procedure} slide item item-rect other other-rect goal - -Resolve the collision that occurs between @var{item} and @var{other} -when moving @var{item-rect} to @var{goal} by sliding @var{item-rect} -the minimum amount needed to make it no longer overlap -@var{other-rect}. -@end deffn - @node Graphics @section Graphics @@ -5383,3 +5205,188 @@ after it has been received. @deffn {Procedure} channel-clear! channel Clear all messages and scripts awaiting messages in @var{channel}. @end deffn + +@node Data Structures +@section Data Structures + +@menu +* Grids:: Spatial partitioning with a fixed grid. +* Path Finding:: Generic A* path finding. +@end menu + +@node Grids +@subsection Grids + +The @code{(chickadee data grid)} module provides a simple spatial +partitioning system for axis-aligned bounding boxes +(@pxref{Rectangles}) in 2D space. The grid divides the world into +tiles and keeps track of which rectangles occupy which tiles. When +there are lots of moving objects in the game world that need collision +detection, the grid greatly speeds up the process. Instead of +checking collisions of each object against every other object (an +O(n^2) operation), the grid quickly narrows down which objects could +possibly be colliding and only performs collision testing against a +small set of objects. + +In addition to checking for collisions, the grid also handles the +resolution of collisions. Exactly how each collision is resolved is +user-defined. A player bumping into a wall may slide against it. An +enemy colliding with a projectile shot by the player may get pushed +back in the opposite direction. Two players colliding may not need +resolution at all and will just pass through each other. The way this +works is that each time an object (A) is moved within the grid, the +grid looks for an object (B) that may possibly be colliding with A. A +user-defined procedure known as a ``filter'' is then called with both +A and B. If the filter returns @code{#f}, it means that even if A and +B are colliding, no collision resolution is needed. In this case the +grid won't waste time checking if they really do collide because it +doesn't matter. If A and B are collidable, then the filter returns a +procedure that implements the resolution technique. The grid will +then perform a collision test. If A and B are colliding, the resolver +procedure is called. It's the resolvers job to adjust the objects +such that they are no longer colliding. The grid module comes with a +very simple resolution procedure, @code{slide}, that adjusts object A +by the smallest amount so that it no longer overlaps with B. By using +this filtering technique, a game can resolve collisions between +different objects in different ways. + +@deffn {Procedure} make-grid [cell-size 64] +Return a new grid partitioned into @var{cell-size} tiles. +@end deffn + +@deffn {Procedure} grid? obj +Return @code{#t} if @var{obj} is a grid. +@end deffn + +@deffn {Procedure} cell? obj +Return @code{#t} if @var{obj} is a grid cell. +@end deffn + +@deffn {Procedure} cell-count cell +Return the number of items in @var{cell}. +@end deffn + +@deffn {Procedure} grid-cell-size grid +Return the cell size of @var{grid}. +@end deffn + +@deffn {Procedure} grid-cell-count grid +Return the number of cells currently in @var{grid}. +@end deffn + +@deffn {Procedure} grid-item-count grid +Return the number of items in @var{grid}. +@end deffn + +@deffn {Procedure} grid-add grid item x y @ + width height + +Add @var{item} to @var{grid} represented by the axis-aligned bounding +box whose lower-left corner is at (@var{x}, @var{y}) and is +@var{width} x @var{height} in size. +@end deffn + +@deffn {Procedure} grid-remove grid item +Return @var{item} from @var{grid}. +@end deffn + +@deffn {Procedure} grid-clear grid +Remove all items from @var{grid}. +@end deffn + +@deffn {Procedure} grid-move grid item position filter +Attempt to move @var{item} in @var{grid} to @var{position} (a 2D +vector) and check for collisions. For each collision, @var{filter} +will be called with two arguments: @var{item} and the item it collided +with. If a collision occurs, @var{position} may be modified to +resolve the colliding objects. +@end deffn + +@deffn {Procedure} for-each-cell proc grid [rect] +Call @var{proc} with each cell in @var{grid} that intersects +@var{rect}, or every cell if @var{rect} is @code{#f}. +@end deffn + +@deffn {Procedure} for-each-item proc grid +Call @var{proc} for each item in @var{grid}. +@end deffn + +@deffn {Procedure} slide item item-rect other other-rect goal + +Resolve the collision that occurs between @var{item} and @var{other} +when moving @var{item-rect} to @var{goal} by sliding @var{item-rect} +the minimum amount needed to make it no longer overlap +@var{other-rect}. +@end deffn + +@node Path Finding +@subsection Path Finding + +Most game worlds have maps. Often, these games have a need to move +non-player characters around in an unscripted fashion. For example, +in a real-time strategy game, the player may command one of their +units to attack something in the enemy base. To do so, the unit must +calculate the shortest route to get there. It wouldn't be a very fun +game if units didn't know how to transport themselves efficiently. +This is where path finding algorithms come in handy. The +@code{(chickadee data path-finding)} module provides a generic +implementation of the popular A* path finding algorithm. Just add a +map implementation! + +The example below defines a very simple town map and finds the +quickest way to get from the town common to the school. + +@example +(define world-map + '((town-common . (town-hall library)) + (town-hall . (town-common school)) + (library . (town-common cafe)) + (school . (town-hall cafe)) + (cafe . (library school)))) +(define (neighbors building) + (assq-ref town-map building)) +(define (cost a b) 1) +(define (distance a b) 1) +(define pf (make-path-finder)) +(a* pf 'town-common 'school neighbors cost distance) +@end example + +In this case, the @code{a*} procedure will return the list +@code{(town-common town-hall school)}, which is indeed the shortest +route. (The other possible route is @code{(town-common library cafe +school)}.) + +The @code{a*} procedure does not know anything about about any kind of +map and therefore must be told how to look up neighboring nodes, which +is what the @code{neighbors} procedure in the example does. To +simulate different types of terrain, a cost procedure is used. In +this example, it is just as easy to move between any two nodes because +@code{cost} always returns 1. In a real game, perhaps moving from +from a field to a rocky hill would cost a lot more than moving from +one field to another. Finally, a heuristic is used to calculate an +approximate distance between two nodes on the map. In this simple +association list based graph it is tough to calculate a distance +between nodes, so the @code{distance} procedure isn't helpful and +always returns 1. In a real game with a tile-based map, for example, +the heuristic could be a quick Manhattan distance calculation based on +the coordinates of the two map tiles. Choose an appropriate heuristic +for optimal path finding! + +@deffn {Procedure} make-path-finder +Return a new path finder object. +@end deffn + +@deffn {Procedure} path-finder? obj +Return @code{#t} if @var{obj} is a path finder. +@end deffn + +@deffn {Procedure} a* path-finder start goal neighbors cost distance + +Return a list of nodes forming a path from @var{start} to @var{goal} +using @var{path-finder} to hold state. @var{neighbors} is a procedure +that accepts a node and returns a list of nodes that neighbor it. +@var{cost} is a procedure that accepts two neighboring nodes and +returns the cost of moving from the first to the second as a real +number. @var{distance} is a procedure that accepts two nodes and +returns an approximate distance between them. +@end deffn diff --git a/examples/grid.scm b/examples/grid.scm index f552d1a..c83dac7 100644 --- a/examples/grid.scm +++ b/examples/grid.scm @@ -1,5 +1,5 @@ (use-modules (chickadee) - (chickadee math grid) + (chickadee data grid) (chickadee math vector) (chickadee math rect) (chickadee graphics color) -- cgit v1.2.3