クラスカル法による迷路作成

kruskal.lisp

;; クラスカル法による迷路作成。
(defparameter *w* 10) ; 頂点グリッドの幅。
(defparameter *h* 10) ; 頂点グリッドの高さ。
(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+)) ; １次元配列。壁文字で初期 化する。

;; Disjoint Set 実装。
(defparameter par nil)
(defun dj-init (n)
  (setf par (make-array n :initial-element nil))
  )

(defun dj-find (i)
  (if (null (aref par i))
      i
    (setf (aref par i) (dj-find (aref par i)))))

(defun dj-union (x y)
  (let ((rootx (dj-find x))
        (rooty (dj-find y)))
    (unless (= rootx rooty)
      (setf (aref par rootx) rooty))))

(defun dj-test ()
  (dj-init 10)
  (dj-union 0 9)
  (dj-union 2 0)
  (loop for i from 0 below 10
        do
        (format t "要素 ~A は 集合 ~A に属しています。~%" i (dj-find i)))
  )

;; 右の頂点への辺と下の頂点への辺を登録する。
(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 (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 shuffle (ls rs)
  (loop for i from (length ls) downto 2
        do (rotatef (nth (random i rs) ls)
                    (nth (1- i) ls))))

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

(defun kruskal ()
  (let ((forest nil))
    (dj-init (* *w* *h*))
    (loop for e in *edges*
          do
          (destructuring-bind
           (u v) e
           (when (/= (dj-find u) (dj-find v))
             (push (list u v) forest)
             (dj-union u v))))
    (setf *edges* forest)
  ))

(defun main ()
  ;; 頂点と辺を登録。
  (loop for i from 0 below (* *w* *h*)
        do (add-vertex i))
  (shuffle *edges* (make-random-state t))
  ;; 迷路を生成。
  (kruskal)
  ;; 生成した迷路を *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+)))
  (loop for e in *edges*
        do
        (destructuring-bind
         (u v) e
         (destructuring-bind
          (ux uy) (map-coords u)
          (destructuring-bind
           (vx vy) (map-coords v)
           (setf (aref *map* (+ (truncate (+ ux vx) 2) (* (truncate (+ uy vy) 2) *map-width*))) +floor-char+)))))
  ;; *map* を表示。
  (print-map)
  )

(main)

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