plonk/reverse-delete.lisp

## reverse-delete.lisp
;; 逆削除法による迷路作成。
(defparameter *w* 10) ; 頂点グリッドの幅。
(defparameter *h* 10) ; 頂点グリッドの高さ。
(defparameter *adj* (make-array (* *w* *h*) :initial-element '())) ; 隣接配列。
(defparameter *edges* '()) ; 辺のリスト。

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

;; 印刷する内容。
(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))) ;; right
  (when (< (truncate v *w*) (- *h* 1))
    (add-edge v (+ v *w*)))) ;; down

(defun add-edge (e1 e2)
  (push e2 (aref *adj* e1))
  (push e1 (aref *adj* e2))
  (push (list e1 e2) *edges*))

(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)))

;; 頂点 v からたどれるすべての頂点を訪問する。
(defun dfs (v visited)
  (setf (aref visited v) t)
  (loop for a in (aref *adj* v)
        do
        (unless (aref visited a)
          (dfs a visited))))

;; 頂点 0 から初めてすべての頂点を訪問できたらグラフは連結である。
(defun connected-p ()
  (let ((visited (make-array (* *w* *h*) :initial-element nil)))
    (dfs 0 visited)
    (every (lambda (x) x) visited)))

;; *map* に床を書き入れる。右か下の頂点と連結していたらその方向の壁を掘る。
(defun draw-vertex (v)
  (destructuring-bind (x y) (map-coords v)
                      (setf (aref *map* (+ x (* y *map-width*))) +floor-char+)
                      (when (and (< (mod v *w*) (1- *w*))
                                 (find (1+ v) (aref *adj* v)))
                        (setf (aref *map* (+ (1+ x) (* y *map-width*))) +floor-char+))
                      (when (and (< (truncate v *w*) (- *h* 1))
                                 (find (+ v *w*) (aref *adj* v)))
                        (setf (aref *map* (+ x (* (1+ y) *map-width*))) +floor-char+))))

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

(defun reverse-delete ()
  (shuffle *edges* (make-random-state t))
  (loop for e in *edges*
        do
        (destructuring-bind
         (u v) e
         ;; 辺を削除する。
         (setf (aref *adj* u) (delete v (aref *adj* u)))
         (setf (aref *adj* v) (delete u (aref *adj* v)))
         (unless (connected-p) ; グラフが非連結になったら辺を戻す。
           (push v (aref *adj* u))
           (push u (aref *adj* v))))))

(defun main ()
  ;; 頂点と辺を登録。
  (loop for i from 0 below (* *w* *h*)
        do (add-vertex i))
  ;; 迷路を生成。
  (reverse-delete)
  ;; 生成した迷路を *map* に書く。
  (loop for i from 0 below (* *w* *h*)
        do (draw-vertex i))
  ;; *map* を表示。
  (print-map))

(main)