diff options
| -rw-r--r-- | Makefile | 2 | ||||
| -rw-r--r-- | tests/013/maze.expected | 61 | ||||
| -rw-r--r-- | tests/013/maze.tl | 91 |
3 files changed, 154 insertions, 0 deletions
@@ -286,11 +286,13 @@ tst/tests/009/json.out: TXR_ARGS := $(addprefix tests/009/,webapp.json pass1.jso tst/tests/010/align-columns.out: TXR_ARGS := tests/010/align-columns.dat tst/tests/010/block.out: TXR_OPTS := -B tst/tests/010/reghash.out: TXR_OPTS := -B +tst/tests/013/maze.out: TXR_ARGS := 20 20 tst/tests/002/%: TXR_SCRIPT_ON_CMDLINE := y tst/tests/011/%: TXR_DBG_OPTS := tst/tests/012/%: TXR_DBG_OPTS := +tst/tests/013/%: TXR_DBG_OPTS := .PRECIOUS: tst/%.out tst/%.out: %.txr diff --git a/tests/013/maze.expected b/tests/013/maze.expected new file mode 100644 index 00000000..f0a09770 --- /dev/null +++ b/tests/013/maze.expected @@ -0,0 +1,61 @@ ++ +----+----+----+----+----+----+----+----+----+----+----+----+----+----+----+----+----+----+----+ +| | | | | | | +| | | | | | | ++ + + + +----+----+----+----+ + + + + +----+----+----+ + +----+ + +| | | | | | | | | | | +| | | | | | | | | | | ++----+ + + +----+ +----+ +----+----+ +----+----+ +----+ +----+----+ +----+ +| | | | | | | | | | | +| | | | | | | | | | | ++----+----+ + + +----+ +----+----+ + +----+----+----+----+----+ +----+----+ + +| | | | | | | | | | | +| | | | | | | | | | | ++ + + +----+----+----+ + +----+----+ + +----+ + + + + +----+----+ +| | | | | | | | | | | | | +| | | | | | | | | | | | | ++ +----+----+ +----+ +----+----+----+ + + + +----+ +----+----+ + + + +| | | | | | | | | | | +| | | | | | | | | | | ++----+----+ + + +----+ +----+ + +----+ + + +----+----+----+----+ + + +| | | | | | | | | | | | | +| | | | | | | | | | | | | ++ +----+----+----+ +----+----+ + +----+ + + + + + +----+ + + + +| | | | | | | | | | | | | +| | | | | | | | | | | | | ++ + + + +----+ + +----+----+----+----+ +----+ + + + +----+----+----+ +| | | | | | | | | | +| | | | | | | | | | ++ +----+----+----+----+----+----+----+----+ + +----+----+----+ +----+ +----+----+ + +| | | | | | | | +| | | | | | | | ++ + + +----+----+----+----+ +----+ +----+ +----+ +----+----+----+ +----+ + +| | | | | | | | | | | | | +| | | | | | | | | | | | | ++ +----+----+----+ + + +----+ +----+ +----+ + + + + +----+ + + +| | | | | | | | | | | +| | | | | | | | | | | ++----+ + + +----+----+ +----+ + +----+ +----+----+----+----+----+ +----+ + +| | | | | | | | | | | | +| | | | | | | | | | | | ++ + +----+ + +----+----+ +----+ + +----+ + + + +----+----+ + + +| | | | | | | | | +| | | | | | | | | ++ + +----+----+----+----+----+----+ +----+----+----+----+----+----+----+ + +----+ + +| | | | | | | | | +| | | | | | | | | ++ + +----+----+ +----+ +----+----+ + + + + +----+ + +----+----+ + +| | | | | | | | | | | | | | | +| | | | | | | | | | | | | | | ++----+ + + +----+ +----+ + + +----+----+ +----+ +----+----+ + + + +| | | | | | | | | | | +| | | | | | | | | | | ++ +----+ +----+ +----+----+ + +----+----+ +----+----+----+----+ +----+----+ + +| | | | | | | | | | +| | | | | | | | | | ++----+----+ + +----+ + +----+----+ +----+----+----+----+ + +----+ + +----+ +| | | | | | | | | | | | +| | | | | | | | | | | | ++ + + + + +----+----+----+ +----+----+----+----+ + +----+ + + + + +| | | | | | | +| | | | | | | ++----+----+----+----+----+----+----+----+----+----+----+----+----+----+----+----+----+----+----+ + diff --git a/tests/013/maze.tl b/tests/013/maze.tl new file mode 100644 index 00000000..f65bc9e0 --- /dev/null +++ b/tests/013/maze.tl @@ -0,0 +1,91 @@ +(defvar vi) ;; visited hash +(defvar pa) ;; path connectivity hash +(defvar sc) ;; count, derived from straightness fator + +(defun scramble (list) + (let ((out ())) + (each ((item list)) + (let ((r (rand (+ 1 (length out))))) + (set [out r..r] (list item)))) + out)) + +(defun rnd-pick (list) + (if list [list (rand (length list))])) + +(defun neigh (loc) + (tree-bind (x . y) loc + (list (- x 1)..y (+ x 1)..y + x..(- y 1) x..(+ y 1)))) + +(defun make-maze-impl (cu) + (let ((fr (hash :equal-based)) + (q (list cu)) + (c sc)) + (set [fr cu] t) + (while q + (let* ((cu (first q)) + (ne (rnd-pick (remove-if (orf vi fr) (neigh cu))))) + (cond (ne (set [fr ne] t) + (push ne [pa cu]) + (push cu [pa ne]) + (push ne q) + (cond ((<= (dec c) 0) + (set q (scramble q)) + (set c sc)))) + (t (set [vi cu] t) + (del [fr cu]) + (pop q))))))) + +(defun make-maze (w h sf) + (let ((vi (hash :equal-based)) + (pa (hash :equal-based)) + (sc (max 1 (int-flo (trunc (* sf w h) 100.0))))) + (each ((x (range -1 w))) + (set [vi x..-1] t) + (set [vi x..h] t)) + (each ((y (range* 0 h))) + (set [vi -1..y] t) + (set [vi w..y] t)) + (make-maze-impl 0..0) + ;; Open start and end + (push 0..-1 [pa 0..0]) + (push (- w 1)..(- h 1) [pa (- w 1)..h]) + pa)) + +(defun print-tops (pa w j) + (each ((i (range* 0 w))) + (if (memqual i..(- j 1) [pa i..j]) + (put-string "+ ") + (put-string "+----"))) + (put-line "+")) + +(defun print-sides (pa w j) + (let ((str "")) + (each ((i (range* 0 w))) + (if (memqual (- i 1)..j [pa i..j]) + (set str `@str `) + (set str `@str| `))) + (put-line `@str|\n@str|`))) + +(defun print-maze (pa w h) + (each ((j (range* 0 h))) + (print-tops pa w j) + (print-sides pa w j)) + (print-tops pa w h)) + +(defun usage () + (let ((invocation (ldiff *full-args* *args*))) + (put-line "usage: ") + (put-line `@invocation <width> <height> [<straightness>]`) + (put-line "straightness-factor is a percentage, defaulting to 15") + (exit 1))) + +(let ((args [mapcar num-str *args*])) + (if (memq nil args) + (usage)) + (tree-case args + ((w h s ju . nk) (usage)) + ((w h : (s 15)) (set w (max 1 w)) + (set h (max 1 h)) + (print-maze (make-maze w h s) w h)) + (else (usage)))) |