plonk · August 4, 2022 10:57 · plonk · Aug 3, 2022
diff --git a/reverse-delete.lisp b/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)