tests/013/maze.tl


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
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))))