プリム法による迷路作成

prim.lisp

;; プリム法による迷路作成。
(defparameter *w* 10) ; 頂点グリッドの幅。
(defparameter *h* 10) ; 頂点グリッドの高さ。
(defparameter *adj* (make-array (* *w* *h*) :initial-element '())) ; 隣接配列。
(defparameter *cost* (make-array (* *w* *h*) :initial-element nil))

;; 印刷に使う文字。
(defconstant +floor-char+ #\・)
(defconstant +wall-char+ #\鬱)

;; 辺のコストの無限大。
(defconstant +big-enough+ 999)

;; 印刷する内容。
(defparameter *map-width* (1+ (* 2 *w*)))
(defparameter *map-height* (1+ (* 2 *h*)))
(defparameter *map* (make-array (* *map-width* *map-height*) :initial-element +wall-char+)) ; １次 元配列。壁文字で初期化する。

;; 右の頂点への辺と下の頂点への辺を登録する。
(defun add-vertex (v)
  (when (< (mod v *w*) (1- *w*))
    (add-edge v (1+ v) 1)) ;; right
  (when (< (truncate v *w*) (- *h* 1))
    (add-edge v (+ v *w*) 1))) ;; down

(defun add-edge (e1 e2 w)
  (push e2 (aref *adj* e1))
  (push e1 (aref *adj* e2))
  (when (null (aref *cost* e1))
    (setf (aref *cost* e1) (make-array (* *w* *h*) :initial-element nil)))
  (setf (aref (aref *cost* e1) e2) w)
  (when (null (aref *cost* e2))
    (setf (aref *cost* e2) (make-array (* *w* *h*) :initial-element nil)))
  (setf (aref (aref *cost* e2) e1) w))

(defun print-map ()
  (loop for y from 0 below *map-height*
        do
        (loop for x from 0 below *map-width*
              do
              (princ (aref *map* (+ x (* y *map-width*)))))
        (terpri)))

;; 頂点番号からマップ上の床座標に変換する。
(defun map-coords (v)
  (let ((x (1+ (* 2 (mod v *w*))))
        (y (1+ (* 2 (truncate v *w*)))))
    (list x y)))

;; リストをシャッフル。
(defun shuffle (ls rs)
  (loop for i from (length ls) downto 2
        do (rotatef (nth (random i rs) ls)
                    (nth (1- i) ls)))
  ls)

(defun iota (n)
  (loop for i below n collect i))

(defun min-by (ls f)
  (when ls
    (loop for elt in (cdr ls)
          with minelt = (first ls)
          with minval = (funcall f (first ls))
          finally (return minelt)
          do
          (let ((val (funcall f elt)))
            (when (< val minval)
              (setf minval val)
              (setf minelt elt))))))

(defun prim ()
  (let ((queue (shuffle (iota (* *w* *h*)) (make-random-state t)))
        (forest nil)
        (edges (make-array (* *w* *h*) :initial-element nil))
        (costs (make-array (* *w* *h*) :initial-element +big-enough+)))
    ;; (print (list 'queue queue))
    ;; (print (list 'costs costs))
    (loop for v = (min-by queue (lambda (u) (aref costs u)))
          while v
          do
      (setf queue (delete v queue))
      (push v forest)
      (loop for w in (aref *adj* v)
            do
            (when (and (find w queue)
                     (< (aref (aref *cost* v) w) (aref costs w)))
              (setf (aref costs w) (aref (aref *cost* v) w))
              (setf (aref edges w) v))))
    ;; (print (list 'costs costs))
    (values forest edges)))

(defun midpoint (x1 x2)
  (/ (+ x1 x2) 2))

(defun main ()
  ;; 頂点と辺を登録。
  (loop for i from 0 below (* *w* *h*)
        do (add-vertex i))
  ;; 迷路を生成。
  (multiple-value-bind
   (forest edges) (prim)
   ;; (print (list 'forest forest))
   ;; (print (list 'edges edges))
   ;; 生成した迷路を *map* に書く。
   (loop for i from 0 below (* *w* *h*)
         do
         (destructuring-bind
          (x y) (map-coords i)
          (setf (aref *map* (+ x (* y *map-width*))) +floor-char+)
          (when (aref edges i)
            (destructuring-bind
             (x2 y2) (map-coords (aref edges i))
             (setf (aref *map* (+ (midpoint x x2) (* (midpoint y y2) *map-width*))) +floor-char+))))))
  ;; *map* を表示。
  ;; (terpri)
  (print-map))

(main)

$ sbcl --script prim.lisp
鬱鬱鬱鬱鬱鬱鬱鬱鬱鬱鬱鬱鬱鬱鬱鬱鬱鬱鬱鬱鬱
鬱・・・鬱・鬱・・・鬱・・・・・・・・・鬱
鬱鬱鬱・鬱・鬱・鬱鬱鬱鬱鬱鬱鬱・鬱鬱鬱・鬱
鬱・・・・・・・・・鬱・鬱・・・・・鬱・鬱
鬱・鬱鬱鬱・鬱鬱鬱鬱鬱・鬱鬱鬱・鬱鬱鬱・鬱
鬱・鬱・鬱・鬱・鬱・・・鬱・・・・・鬱・鬱
鬱鬱鬱・鬱・鬱・鬱鬱鬱・鬱鬱鬱・鬱鬱鬱鬱鬱
鬱・・・・・・・・・鬱・鬱・鬱・鬱・鬱・鬱
鬱鬱鬱・鬱・鬱・鬱鬱鬱・鬱・鬱・鬱・鬱・鬱
鬱・・・鬱・鬱・鬱・・・鬱・鬱・鬱・・・鬱
鬱鬱鬱鬱鬱・鬱鬱鬱鬱鬱・鬱・鬱・鬱・鬱鬱鬱
鬱・鬱・・・・・鬱・鬱・・・・・・・・・鬱
鬱・鬱鬱鬱・鬱鬱鬱・鬱・鬱鬱鬱・鬱鬱鬱・鬱
鬱・鬱・・・・・鬱・・・・・鬱・・・鬱・鬱
鬱・鬱鬱鬱・鬱鬱鬱・鬱鬱鬱鬱鬱・鬱鬱鬱鬱鬱
鬱・・・・・・・・・・・鬱・・・・・・・鬱
鬱・鬱鬱鬱・鬱・鬱鬱鬱鬱鬱鬱鬱・鬱・鬱鬱鬱
鬱・鬱・鬱・鬱・・・鬱・・・・・鬱・・・鬱
鬱鬱鬱・鬱鬱鬱・鬱鬱鬱鬱鬱・鬱・鬱・鬱・鬱
鬱・・・・・・・・・鬱・・・鬱・鬱・鬱・鬱
鬱鬱鬱鬱鬱鬱鬱鬱鬱鬱鬱鬱鬱鬱鬱鬱鬱鬱鬱鬱鬱