人材獲得作戦・試験問題を解いてみた

単純な経路探索なので、コピペすれば10分もかからないだろうが、なんとなく解いてみた。時間は記事を読み始めてから85分ほどかかった。ただし、xyzzy上で動くプログラムなので、要求は正確には満たしていないだろう。

本当は幅優先探索と反復深化深度優先探索を組み合わせるべきだが、深度優先探索は再帰処理が面倒なので幅優先探索のみ行っている*1。

(defvar start-chr #\S)
(defvar end-chr #\G)
(defvar space-chr #\SPC)
(defvar wall-chr #\*)
(defvar path-chr #\$)
(defvar max-calc 100)

(defun run-command (txt)
  (interactive "*s入力: ")
  (insert (run txt)))

(defun run (txt)
  "入力をテキストで受ける"
  (solve (convert-input txt)))

(defun convert-input (txt)
  (mapcar (lambda (x) (coerce x 'list))(split-string txt #\LFD)))

(defun solve (lst)
  (let ((path (solve-inner lst (s-get lst start-chr) (s-get lst end-chr))))
    (values
     (convert-output
      (app-path lst path))
     (length path))))

(defun convert-output (lst)
  "結果をテキストで出力する"
   (format nil "~{~&~{~A~}~}" lst))

(defun app-path (lst path)
  "経路情報を地図に書き込む"
  (let ((l (copy-tree lst)))
    (mapcar (lambda (x)
            (setf (pick l (car x) (cadr x)) path-chr)) path)
    l))

(defun solve-inner (lst start end)
  (let ((stp 0)
        (start-pos-l (list start))
        (start-path-hash (make-hash-table :test 'equal :size 177))
        (end-pos-l (list end))
        (end-path-hash (make-hash-table :test 'equal :size 177)))
    (setf (gethash end end-path-hash) t)
    (loop
      (setq end-pos-l (enhance-path lst end-path-hash end-pos-l))
      (setq start-pos-l (enhance-path lst start-path-hash start-pos-l))
      (let ((r (dolist (p start-pos-l)
                  (if (gethash p end-path-hash)
                      (return p)))))
        (if r (return
               (append (cddr (route r start-path-hash))
                       (cdr (reverse (cddr (route r end-path-hash))))))
          (do-events))
        (and (not end-pos-l)
             (not start-pos-l)
             (error "経路は塞がっています。"))
        (if (>= (incf stp) max-calc)
            (error "経路が~Aステップ中に見つかりませんでした。" max-calc))))))

(defun route (pos hash)
  (let ((mp pos)
        (path (list pos)))
    (loop
    (let ((p (gethash mp hash)))
      (if (or (eq p t) (eq p nil))
          (return (append (list p) path)))
      (push p path)
      (setq mp p)))))

(defun enhance-path (lst path-hash pos-l)
  "pathを延長"
  (let ((my (length lst))
        (mx (length (car lst))))
    (labels ((new-pos (nx ny)
             (and nx ny
                  (not (gethash (list nx ny) path-hash))
                  (eq (pick lst nx ny) space-chr)
                  (list nx ny))))
    (mapcan
     (lambda (pos)
       (let* ((x (car pos))
              (y (cadr pos))
              (x-1 (if (< 0 x) (1- x)))
              (y-1 (if (< 0 y) (1- y)))
              (x+1 (if (< x mx) (1+ x)))
              (y+1 (if (< y my) (1+ y)))
              (new-pos-l
               (remove nil
                       (list
                        (new-pos x-1 y)
                        (new-pos x y-1)
                        (new-pos x+1 y)
                        (new-pos x y+1)))))
         (mapc (lambda (x) (setf (gethash x path-hash) pos))
               new-pos-l)))
     pos-l))))

(defmacro pick (lst x y)
  `(elt (elt ,lst ,y) ,x))

(defun s-get (lst chr)
  (dotimes (y (length lst))
    (let ((a (let ((l (elt lst y)))
               (dotimes (x (length l))
                 (if (eq chr (elt l x))
                     (return (list x y)))))))
      (if a (return a)))))

*1:3.10 8パズルと2つの後者関数 - 象徴ヶ淵で書いているが、書くのに手間取った記憶がある。