迷路を解くアルゴリズム

Common Lisp で書いてみた。
人材獲得作戦・４　試験問題ほか（http://okajima.air-nifty.com/b/2010/01/post-abc6.html）
でもメモリ確保が簡単にできるということ以外は、ほとんどＣで書くのと同じに……。
まず file-to-matrix でファイルから文字を読み取り、必要十分な大きさの２次元配列にする。せっかくなので一般的なものにしようと、デフォルトの文字を与えることができるようにしてある。
この配列を make-adjacent-list-array に渡して、それぞれのマスから別のどのマスに行けるかというリストの配列を作る。ここからマスの座標をシーケンシャルな番号（id）で表すことにしている。局所関数の to-id はそのためのもの。
ここまでがコードの前半。ＩＯはいつも面倒だ。最初からＳ式で書いてくれれば read 一発なのに……、というのは Lisper の永遠の悲願。さて、迷路の情報を読み取ってしまえば、あとはキューを使って幅優先探索をするだけ。
solve-maze 内で、二つの記憶用配列を用意している。どちらも添字はマスの通し番号。dist はスタートからの距離、prev は直前に訪れたマス。
キューから id を取り出しつつ、そこから行けるマスを走査していく。ゴールなら prev を辿って道筋を書き込み、印字して終了。ゴールでなく、しかもそのマスをまだ訪れていなかったのなら、距離を保存したあと id をエンキュー。これを繰り返してゴールへの道を見つける。幅優先で探索しているので、最初に見つかった経路が自動的に最短経路となる。

コード：

;; Counts the number of rows and the max column length

(defun file-matrix-size (istream)
  (let ((row 0) (col 0)
        (fpos (file-position istream)))
    (file-position istream 0)
    (do ((line (read-line istream nil nil)
               (read-line istream nil nil)))
        ((null line))
      (incf row)
      (setq col (max col (length line))))
    (file-position istream fpos)
    (list row col)))



;; Maze in file -> Matrix (necessary and sufficient size)

(defun file-to-matrix (file-path &optional initial-element)
  (with-open-file (in file-path)
    (let* ((size (file-matrix-size in))
           (maze-matrix (make-array size
                                    :initial-element initial-element)))
      (do ((line (read-line in nil nil)
                 (read-line in nil nil))
           (r 0 (1+ r)))
          ((null line))
        (dotimes (i (length line))
          (setf (aref maze-matrix r i) (char line i))))
      (values maze-matrix (first size) (second size)))))



;; Maze matrix -> Array of the list of neighbors

(defun make-adjacent-list-array (maze-matrix)
  (destructuring-bind (row col) (array-dimensions maze-matrix)
    (let ((adjacent-list-array
           (make-array (* row col) :initial-element nil))
          start goal)
      (flet ((to-id (i j)               ; (row col) -> serial id
               (+ (* i col) j)))
        (dotimes (i row)
          (dotimes (j col)
            (let ((ch (aref maze-matrix i j))
                  (id (+ (* i col) j)))
              (when (char/= ch #\*)
                (case ch
                  ((#\s #\S)
                   (if start
                       (error "Two start points exist")
                       (setq start (to-id i j))))
                  ((#\g #\G)
                   (if goal
                       (error "Two goal points exist")
                       (setq goal (to-id i j)))))
                (when (char/= #\* (aref maze-matrix i (1- j))) ; left
                  (push (to-id i (1- j))
                        (svref adjacent-list-array id)))
                (when (char/= #\* (aref maze-matrix i (1+ j))) ; right
                  (push (to-id i (1+ j))
                        (svref adjacent-list-array id)))
                (when (char/= #\* (aref maze-matrix (1- i) j)) ; up
                  (push (to-id (1- i) j)
                        (svref adjacent-list-array id)))
                (when (char/= #\* (aref maze-matrix (1+ i) j)) ; down
                  (push (to-id (1+ i) j)
                        (svref adjacent-list-array id))))))))
      (if (and start goal)
          (values adjacent-list-array start goal)
          (error "Just one start and goal is required")))))



;; Queue utility

(defun make-queue ()  (cons nil nil))

(defun deq (q)  (pop (car q)))

(defun enq (q obj)
  (if (car q)
      (setf (cdr q)
            (setf (cddr q) (cons obj nil)))
      (setf (cdr q)
            (setf (car q) (cons obj nil)))))



;; Printer

(defun print-matrix (matrix)
  (destructuring-bind (row col) (array-dimensions matrix)
    (dotimes (i row)
      (dotimes (j col)
        (princ (aref matrix i j)))
      (terpri))))



;; Main: Solves a maze by the breadth-first search

(defun solve-maze (file-path)
  (multiple-value-bind (maze-matrix row col)
      (file-to-matrix file-path #\*)
    (declare (ignore row))
    (multiple-value-bind (adjacent-list-array start goal)
        (make-adjacent-list-array maze-matrix)
      (let* ((size (length adjacent-list-array)) ; the limit of id
             (dist (make-array size              ; distance from start
                               :initial-element nil))
             (prev (make-array size))   ; previous id
             (q (make-queue)))
        (setf (svref dist start) 0)
        (enq q start)
        (loop
           for id = (deq q) do
           (if id
               (dolist (adj (svref adjacent-list-array id)) ; for each neighbor
                 (if (= adj goal)
                     (do ((pid id (svref prev pid)))
                         ((= pid start)
                          (print-matrix maze-matrix)
                          (return-from solve-maze (svref dist id)))
                       (multiple-value-bind (i j)
                           (floor pid col) ; id -> (row col)
                         (setf (aref maze-matrix i j) #\$)))
                     (unless (svref dist adj) ; when adj has not been visited
                       (enq q adj)
                       (setf (svref dist adj) (1+ (svref dist id)))
                       (setf (svref prev adj) id))))
               (return-from solve-maze
                 (format t "No answer exists~%"))))))))