|
| 1 | +;;; Maze generation |
| 2 | +;;; |
| 3 | +;;; This is a slightly bigger example which implements a maze generation framework and |
| 4 | +;;; two sample algorithms which generate random mazes. |
| 5 | +;;; |
| 6 | +;;; The code is organized in two parts: the framework for representing and generating |
| 7 | +;;; mazes is implemented in terms of a library `(lispkit example maze)`. It defines a |
| 8 | +;;; new datatype `maze` which implements a maze of given dimensions as a vector of fixnum |
| 9 | +;;; values. Conceptually, a maze is a board of cells. Each cell has up to four walls in |
| 10 | +;;; the directions towards `north`, `south`, `east`, and `west`. In addition, each cell |
| 11 | +;;; provides a 60-bit fixnum value for representing custom flags. |
| 12 | +;;; |
| 13 | +;;; The second part of the code imports the library and implements two algorithms for |
| 14 | +;;; generating random mazes: one is based on a randomized backtracking approach doing |
| 15 | +;;; a depth first search, the second one implements a very simple approach by generating |
| 16 | +;;; a random binary tree. |
| 17 | +;;; |
| 18 | +;;; Mazes can be either printed onto a terminal via function `display-maze` or there is |
| 19 | +;;; a simple function `save-maze` which draws a maze into a LispKit drawing which is then |
| 20 | +;;; saved into a PDF file. |
| 21 | +;;; |
| 22 | +;;; Example usage: |
| 23 | +;;; (display-maze (make-maze/randomized-dfs 15 15)) |
| 24 | +;;; (save-maze "Maze-DFS.pdf" (make-maze/randomized-dfs 40 40) 10 10) |
| 25 | +;;; (save-maze "Maze-BinTree.pdf" (make-maze/bintree 50 50) 8 8) |
| 26 | +;;; |
| 27 | +;;; Author: Matthias Zenger |
| 28 | +;;; Copyright © 2019 Matthias Zenger. All rights reserved. |
| 29 | +;;; |
| 30 | +;;; Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file |
| 31 | +;;; except in compliance with the License. You may obtain a copy of the License at |
| 32 | +;;; |
| 33 | +;;; http://www.apache.org/licenses/LICENSE-2.0 |
| 34 | +;;; |
| 35 | +;;; Unless required by applicable law or agreed to in writing, software distributed under the |
| 36 | +;;; License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, |
| 37 | +;;; either express or implied. See the License for the specific language governing permissions |
| 38 | +;;; and limitations under the License. |
| 39 | + |
| 40 | +;; Library providing functionality for creating, representing and manipulating data structures |
| 41 | +;; for mazes, maze cells, and directions. |
| 42 | + |
| 43 | +(define-library (lispkit example maze) |
| 44 | + |
| 45 | + (export west |
| 46 | + east |
| 47 | + north |
| 48 | + south |
| 49 | + all-directions |
| 50 | + direction-west? |
| 51 | + direction-east? |
| 52 | + direction-north? |
| 53 | + direction-south? |
| 54 | + invert-direction |
| 55 | + mirror-direction) |
| 56 | + |
| 57 | + (export cell |
| 58 | + cell-x |
| 59 | + cell-y) |
| 60 | + |
| 61 | + (export make-maze |
| 62 | + maze-width |
| 63 | + maze-height |
| 64 | + maze-bounds |
| 65 | + maze-cell-in-bounds? |
| 66 | + maze-cell-id |
| 67 | + maze-cell-id->cell |
| 68 | + maze-cell-walls |
| 69 | + maze-has-wall? |
| 70 | + maze-has-no-wall? |
| 71 | + set-maze-cell-walls! |
| 72 | + maze-add-wall! |
| 73 | + maze-remove-wall! |
| 74 | + maze-add-border-walls! |
| 75 | + maze-cell-flags |
| 76 | + set-maze-cell-flags! |
| 77 | + maze-cell-unvisited? |
| 78 | + maze-for-each-neighbor-cell |
| 79 | + display-maze |
| 80 | + maze->shape) |
| 81 | + |
| 82 | + (import (lispkit base) |
| 83 | + (lispkit draw)) |
| 84 | + |
| 85 | + (begin |
| 86 | + (define west 1) |
| 87 | + (define east 2) |
| 88 | + (define north 4) |
| 89 | + (define south 8) |
| 90 | + (define all-directions 15) |
| 91 | + |
| 92 | + (define (direction-west? dir) |
| 93 | + (not (fxzero? (fxand dir west)))) |
| 94 | + |
| 95 | + (define (direction-east? dir) |
| 96 | + (not (fxzero? (fxand dir east)))) |
| 97 | + |
| 98 | + (define (direction-north? dir) |
| 99 | + (not (fxzero? (fxand dir north)))) |
| 100 | + |
| 101 | + (define (direction-south? dir) |
| 102 | + (not (fxzero? (fxand dir south)))) |
| 103 | + |
| 104 | + (define (invert-direction dir) |
| 105 | + (fxxor dir all-directions)) |
| 106 | + |
| 107 | + (define (mirror-direction dir) |
| 108 | + (fxior |
| 109 | + (fxior (if (direction-west? dir) east 0) |
| 110 | + (if (direction-east? dir) west 0)) |
| 111 | + (fxior (if (direction-north? dir) south 0) |
| 112 | + (if (direction-south? dir) north 0)))) |
| 113 | + ) |
| 114 | + |
| 115 | + (begin |
| 116 | + (define cell cons) |
| 117 | + (define cell-x car) |
| 118 | + (define cell-y cdr) |
| 119 | + ) |
| 120 | + |
| 121 | + (begin |
| 122 | + (define-values (new-maze maze? maze-ref make-maze-subtype) (make-type 'maze)) |
| 123 | + |
| 124 | + (define (make-maze width height . args) |
| 125 | + (let-optionals args ((walls 0)) |
| 126 | + (new-maze (cons (cons width height) (make-vector (fx* width height) walls))))) |
| 127 | + |
| 128 | + (define (maze-width maze) |
| 129 | + (caar (maze-ref maze))) |
| 130 | + |
| 131 | + (define (maze-height maze) |
| 132 | + (cdar (maze-ref maze))) |
| 133 | + |
| 134 | + (define (maze-bounds maze) |
| 135 | + (let ((m (maze-ref maze))) |
| 136 | + (values (caar m) (cdar m)))) |
| 137 | + |
| 138 | + (define (maze-cell-in-bounds? maze cll) |
| 139 | + (let ((m (maze-ref maze))) |
| 140 | + (and (fx>= (cell-x cll) 0) |
| 141 | + (fx>= (cell-y cll) 0) |
| 142 | + (fx< (cell-x cll) (caar m)) |
| 143 | + (fx< (cell-y cll) (cdar m))))) |
| 144 | + |
| 145 | + (define (maze-cell-id maze cll) |
| 146 | + (let ((m (maze-ref maze))) |
| 147 | + (fx+ (fx* (caar m) (cell-y cll)) (cell-x cll)))) |
| 148 | + |
| 149 | + (define (maze-cell-id->cell maze id) |
| 150 | + (let ((m (maze-ref maze))) |
| 151 | + (cell (fxremainder id (caar m)) (fx/ id (caar m))))) |
| 152 | + |
| 153 | + (define (maze-cell-walls maze cll) |
| 154 | + (let ((m (maze-ref maze))) |
| 155 | + (fxand (vector-ref (cdr m) (fx+ (fx* (caar m) (cell-y cll)) (cell-x cll))) 15))) |
| 156 | + |
| 157 | + (define (maze-has-wall? maze cll dir) |
| 158 | + (not (fxzero? (fxand (maze-cell-walls maze cll) dir)))) |
| 159 | + |
| 160 | + (define (maze-has-no-wall? maze cll dir) |
| 161 | + (fxzero? (fxand (maze-cell-walls maze cll) dir))) |
| 162 | + |
| 163 | + (define (set-maze-cell-walls! maze cll walls) |
| 164 | + (let* ((m (maze-ref maze)) |
| 165 | + (i (fx+ (fx* (caar m) (cell-y cll)) (cell-x cll))) |
| 166 | + (v (vector-ref (cdr m) i))) |
| 167 | + (vector-set! (cdr m) i (fxior (fxand v -16) walls)))) |
| 168 | + |
| 169 | + (define (maze-add-wall! maze cll dir) |
| 170 | + (set-maze-cell-walls! maze cll (fxior (maze-cell-walls maze cll) dir)) |
| 171 | + (maze-for-each-neighbor-cell maze cll dir |
| 172 | + (lambda (ncll ndir rdir) |
| 173 | + (set-maze-cell-walls! maze ncll (fxior (maze-cell-walls maze ncll) rdir))))) |
| 174 | + |
| 175 | + (define (maze-remove-wall! maze cll dir) |
| 176 | + (let ((walls (maze-cell-walls maze cll))) |
| 177 | + (set-maze-cell-walls! maze cll (fxxor walls (fxand walls dir)))) |
| 178 | + (maze-for-each-neighbor-cell maze cll dir |
| 179 | + (lambda (ncll ndir rdir) |
| 180 | + (let ((nwalls (maze-cell-walls maze ncll))) |
| 181 | + (set-maze-cell-walls! maze ncll (fxxor nwalls (fxand nwalls rdir))))))) |
| 182 | + |
| 183 | + (define (maze-add-border-walls! maze) |
| 184 | + (let-values (((width height) (maze-bounds maze))) |
| 185 | + (do ((x 0 (fx+ x 1))) |
| 186 | + ((fx>= x width)) |
| 187 | + (maze-add-wall! maze (cell x 0) north) |
| 188 | + (maze-add-wall! maze (cell x (fx1- height)) south)) |
| 189 | + (do ((y 0 (fx+ y 1))) |
| 190 | + ((fx>= y height)) |
| 191 | + (maze-add-wall! maze (cell 0 y) west) |
| 192 | + (maze-add-wall! maze (cell (fx1- width) y) east)))) |
| 193 | + |
| 194 | + (define (maze-cell-flags maze cll) |
| 195 | + (let ((m (maze-ref maze))) |
| 196 | + (fxrshift (vector-ref (cdr m) (fx+ (fx* (caar m) (cell-y cll)) (cell-x cll))) 4))) |
| 197 | + |
| 198 | + (define (set-maze-cell-flags! maze cll flags) |
| 199 | + (let* ((m (maze-ref maze)) |
| 200 | + (i (fx+ (fx* (caar m) (cell-y cll)) (cell-x cll))) |
| 201 | + (v (vector-ref (cdr m) i))) |
| 202 | + (vector-set! (cdr m) i (fxior (fxlshift flags 4) (fxand v 15))))) |
| 203 | + |
| 204 | + (define (maze-cell-unvisited? maze cll) |
| 205 | + (fx= (maze-cell-walls maze cll) all-directions)) |
| 206 | + |
| 207 | + (define (maze-for-each-neighbor-cell maze cll dir f) |
| 208 | + (let-values (((width height) (maze-bounds maze))) |
| 209 | + (if (and (direction-west? dir) (fx> (cell-x cll) 0)) |
| 210 | + (f (cell (fx1- (cell-x cll)) (cell-y cll)) west east)) |
| 211 | + (if (and (direction-east? dir) (fx< (cell-x cll) (fx1- width))) |
| 212 | + (f (cell (fx1+ (cell-x cll)) (cell-y cll)) east west)) |
| 213 | + (if (and (direction-north? dir) (fx> (cell-y cll) 0)) |
| 214 | + (f (cell (cell-x cll) (fx1- (cell-y cll))) north south)) |
| 215 | + (if (and (direction-south? dir) (fx< (cell-y cll) (fx1- height))) |
| 216 | + (f (cell (cell-x cll) (fx1+ (cell-y cll))) south north)))) |
| 217 | + |
| 218 | + (define (display-maze maze . args) |
| 219 | + (let-optionals args ((port (current-output-port))) |
| 220 | + (let-values (((width height) (maze-bounds maze))) |
| 221 | + (display |
| 222 | + (do ((line (string #\+)) |
| 223 | + (x 0 (fx+ x 1))) |
| 224 | + ((fx>= x width) line) |
| 225 | + (string-append! line (if (maze-has-wall? maze (cell x 0) north) "---+" " +"))) |
| 226 | + port) |
| 227 | + (newline port) |
| 228 | + (do ((y 0 (fx+ y 1))) |
| 229 | + ((fx>= y height)) |
| 230 | + (display |
| 231 | + (do ((line (string (if (maze-has-wall? maze (cell 0 y) west) #\| #\space))) |
| 232 | + (x 0 (fx+ x 1))) |
| 233 | + ((fx>= x width) line) |
| 234 | + (string-append! line (if (maze-has-wall? maze (cell x y) east) " |" " "))) |
| 235 | + port) |
| 236 | + (newline port) |
| 237 | + (display |
| 238 | + (do ((line (string #\+)) |
| 239 | + (x 0 (fx+ x 1))) |
| 240 | + ((fx>= x width) line) |
| 241 | + (string-append! line (if (maze-has-wall? maze (cell x y) south) "---+" " +"))) |
| 242 | + port) |
| 243 | + (newline port))))) |
| 244 | + |
| 245 | + (define (maze->shape maze dx dy) |
| 246 | + (let-values (((width height) (maze-bounds maze))) |
| 247 | + (shape |
| 248 | + (do ((y 0 (fx1+ y))) |
| 249 | + ((fx>= y height)) |
| 250 | + (do ((x 0 (fx1+ x)) |
| 251 | + (cll (cell 0 y) (cell (fx1+ x) y))) |
| 252 | + ((fx>= x width)) |
| 253 | + (if (maze-has-wall? maze cll north) |
| 254 | + (begin |
| 255 | + (move-to (point (* x dx) (* y dy))) |
| 256 | + (relative-line-to (point dx 0)))) |
| 257 | + (if (maze-has-wall? maze cll west) |
| 258 | + (begin |
| 259 | + (move-to (point (* x dx) (* y dy))) |
| 260 | + (relative-line-to (point 0 dy)))))) |
| 261 | + (do ((x 0 (fx1+ x)) |
| 262 | + (y (fx1- height))) |
| 263 | + ((fx>= x width)) |
| 264 | + (if (maze-has-wall? maze (cell x y) south) |
| 265 | + (begin |
| 266 | + (move-to (point (* x dx) (* height dy))) |
| 267 | + (relative-line-to (point dx 0))))) |
| 268 | + (do ((x (fx1- width)) |
| 269 | + (y 0 (fx1+ y))) |
| 270 | + ((fx>= y height)) |
| 271 | + (if (maze-has-wall? maze (cell x y) east) |
| 272 | + (begin |
| 273 | + (move-to (point (* width dx) (* y dy))) |
| 274 | + (relative-line-to (point 0 dy)))))))) |
| 275 | + ) |
| 276 | +) |
| 277 | + |
| 278 | +(import (lispkit example maze) |
| 279 | + (lispkit draw)) |
| 280 | + |
| 281 | +;; Returns a random maze generated by a randomized depth first search algorithm. Backtracking |
| 282 | +;; is implemented by memorizing the previous cell using cell flags, as provided by library |
| 283 | +;; `(lispkit example maze)`. `height` and `width` define the dimensions of the maze in terms |
| 284 | +;; of number of vertical and horizontal cells. |
| 285 | +(define (make-maze/randomized-dfs width height . args) |
| 286 | + (let-optionals args ((startx 0) |
| 287 | + (starty 0)) |
| 288 | + (do ((maze (make-maze width height all-directions)) |
| 289 | + (current (cell startx starty)) |
| 290 | + (unvisited (fx1- (fx* width height)) |
| 291 | + (if (fxzero? count) unvisited (fx1- unvisited))) |
| 292 | + (next (make-vector 4)) |
| 293 | + (count 0 0)) |
| 294 | + ((fxzero? unvisited) maze) |
| 295 | + (maze-for-each-neighbor-cell maze current all-directions |
| 296 | + (lambda (ncll ndir rdir) |
| 297 | + (if (maze-cell-unvisited? maze ncll) |
| 298 | + (begin (vector-set! next count (cons ncll ndir)) |
| 299 | + (set! count (fx1+ count)))))) |
| 300 | + (if (fxzero? count) |
| 301 | + (set! current (maze-cell-id->cell maze (maze-cell-flags maze current))) |
| 302 | + (let ((target (vector-ref next (fxrandom count)))) |
| 303 | + (maze-remove-wall! maze current (cdr target)) |
| 304 | + (set-maze-cell-flags! maze (car target) (maze-cell-id maze current)) |
| 305 | + (set! current (car target))))))) |
| 306 | + |
| 307 | +;; Returns a random maze generated by a randomized binary tree algorithm. `height` and |
| 308 | +;; `width` define the dimensions of the maze in terms of number of vertical and horizontal |
| 309 | +;; cells. |
| 310 | +(define (make-maze/bintree width height . args) |
| 311 | + (let ((maze (make-maze width height 0)) |
| 312 | + (max-x (fx1- width))) |
| 313 | + (maze-add-border-walls! maze) |
| 314 | + (do ((x 1 (if (fx>= x max-x) 1 (fx1+ x))) |
| 315 | + (y 1 (if (fx>= x max-x) (fx1+ y) y))) |
| 316 | + ((fx>= y height) maze) |
| 317 | + (maze-add-wall! maze (cell x y) (if (fxzero? (fxrandom 2)) north west))))) |
| 318 | + |
| 319 | +;; Saves a maze into a PDF file at `path`. `dx` and `dy` refer to the dimensions of a single |
| 320 | +;; cell in the drawing that is used for generating the PDF file. The size of the PDF canvas |
| 321 | +;; gets automatically computed from the dimensions of the `maze` as well as `dx` and `dy`. |
| 322 | +(define (save-maze path maze dx dy) |
| 323 | + (let* ((shape (maze->shape maze dx dy)) |
| 324 | + (mdrawing (drawing (draw (transform-shape shape (translate 20 20))))) |
| 325 | + (dsize (size (fx+ (fx* (maze-width maze) dx) 40) |
| 326 | + (fx+ (fx* (maze-height maze) dy) 40)))) |
| 327 | + (save-drawing path mdrawing dsize))) |
0 commit comments