Frank Buss wrote:
> could be enhanced easily for 3D and higher dimension mazes.
done:
(defun fill-maze (maze start add value dimensions &optional (index nil))
(let ((max (car dimensions)))
(if max
(let ((rest (cdr dimensions)))
(loop for i from start below max by add do
(fill-maze maze start add value rest (cons i index))))
(setf (apply #'aref maze (reverse index)) value))))
(defun get-possible-directions (maze ofs position maze-dimensions)
(let ((dimension-count (length maze-dimensions)))
(loop for i from 0 below dimension-count
with directions = '()
finally (return directions) do
(loop for ofs from (* -1 ofs) to (* 1 ofs) by (* 2 ofs)
with add do
(setf add t)
(let ((direction
(loop for j from 0 below dimension-count
for p in position
for d in maze-dimensions collect
(let ((coord
(if (= i j)
(+ ofs p)
p)))
(when (or (< coord 0)
(= coord d))
(setf add nil)
(loop-finish))
coord))))
(when (and add (not (apply #'aref maze direction)))
(push direction directions)))))))
(defun create-maze (dimensions)
"Create a so called 'perfect maze'"
(let* ((maze-dimensions (loop for i in dimensions collect (1+ (* 2 i))))
(maze (make-array maze-dimensions
:initial-element nil))
(position (loop for i in dimensions collect (1+ (* 2 (random
i)))))
(stack '())
(size (* (reduce #'* dimensions)))
(visited 0))
;; fill with walls
(fill-maze maze 0 1 :wall maze-dimensions)
;; delete markers
(fill-maze maze 1 2 nil maze-dimensions)
;; break walls
(loop while (< visited size) do
(unless (apply #'aref maze position)
(setf (apply #'aref maze position) :visited)
(incf visited))
(let ((directions (get-possible-directions maze 2 position
maze-dimensions)))
(if (car directions)
(let* ((new-position (elt directions
(random (length directions)))))
(push new-position stack)
(setf (apply #'aref maze (loop for i in new-position
for j in position
collect (ash (+ i j) -1)))
nil)
(setf position new-position))
(setf position (pop stack)))))
;; delete markers
(fill-maze maze 1 2 nil maze-dimensions)
maze))
(defun print-maze-layer (maze dimensions &optional (index nil))
(let ((max (car dimensions)))
(if (> (length dimensions) 2)
(let ((rest (cdr dimensions)))
(loop for i from 0 below max do
(print-maze-layer maze rest (cons i index))))
(loop for y from 0 below (cadr dimensions) do
(loop for x from 0 below (car dimensions) do
(princ (case (apply #'aref maze (append index (list x)
(list y)))
(:path ".")
(:wall "#")
(t " "))))
(terpri)))
(terpri)))
(defun print-maze (maze)
"Print a maze"
(print-maze-layer maze (array-dimensions maze)))
(defun solve-maze (maze)
"Return t, if maze is solved (filled with :path) or nil if not solvable"
(let* ((maze-dimensions (array-dimensions maze))
(position (loop for i in maze-dimensions collect 1))
(end (loop for i in maze-dimensions collect (- i 2)))
(stack '())
(size (* (reduce #'* maze-dimensions)))
(visited 0))
(loop while (< visited size) do
(unless (apply #'aref maze position)
(setf (apply #'aref maze position) :path)
(incf visited))
(when (equalp position end) (return-from solve-maze t))
(let ((directions (get-possible-directions maze 1 position
maze-dimensions)))
(if (car directions)
(let* ((new-position (elt directions
(random (length directions)))))
(push position stack)
(setf position new-position))
(let ((new-position (pop stack)))
(unless new-position (return-from solve-maze))
(setf (apply #'aref maze position) :dead-end)
(setf position new-position)))))))
(defun test-2d ()
(let ((maze (create-maze '(16 10))))
(solve-maze maze)
(print-maze maze)))
(defun test-3d ()
(let ((maze (create-maze '(2 16 10))))
(solve-maze maze)
(print-maze maze)))
(defun test-4d ()
(let ((maze (create-maze '(3 3 5 4))))
(solve-maze maze)
(print-maze maze)))
--
Frank Buss, [EMAIL PROTECTED]
http://www.frank-buss.de, http://www.it4-systems.de
_______________________________________________
Gardeners mailing list
[email protected]
http://www.lispniks.com/mailman/listinfo/gardeners
