LISPUSER

どう書く？ というサイトで見かけた「n人中m人が当選するくじ (http://ja.doukaku.org/4/ )」という問題が出題されていました。

;; 最初に投稿しようと思った例
(defun lot-A (lst m)
  (assert (>= (length lst) m) () "...")
  (flet ((random-select () (let ((e (nth (random (length lst)) lst))) (setf lst (remove e lst)) e)))
    (loop repeat m collect (random-select))))

;; 実際に書くであろう例
(defun lot-B (lst m)
  (assert (>= (length lst) m) () "...")
  (srfi-1:take (alexander:shuffle lst) m))

結局 Lisp で書くと ``(loop repeat m collect (random-select))`` あるいは ``(take (shuffle lst) m)`` と書くだろうなーと。 標準機能だけで一関数にはしないだろうなぁ、とか悩んでしまった。フォルダ内のバックアップ削除のお題にしても CL-FAD ライブラを使って ``(fad:walk-directory dir #'byebye-backup)`` と書くだろうしなぁ。むむむ。

また、掲示板では次のような書き込みを見かけたので勝手に添削。

 From: [163] デフォルトの名無しさん <>
 Date: 2007/07/01(日) 21:04:30
 
 http://karetta.jp/article/blog/ll-spirit/033840
 これをCLで素朴にやってみたんですけど誰か添削してくれませんか。

油売り算というものらしい。

斗桶 (a) に油が 1 斗 (10 升) ある。これを等分したい。7 升枡 (b) と 3 升枡 (c) しかない。この 2 つの枡
だけで、5 升ずつ等分する方法を記述せよ。

この問題を解くにあたり、(a) に入っている油の容量を第 1 引数、(b) の容量を第 2 引数、(c) の容量を第 3
引数とするプログラムとせよ。

(http://karetta.jp/article/blog/ll-spirit/033840 より)

で、こちらが元コード。素朴というわりには、関数型言語経験者ぽいコードですが…。

(defvar *capacity* nil) ; int list
(defvar *goal-p* nil) ; int list -> bool

(defun room-of (n state) (- (nth n *capacity*) (nth n state)))
(defun lset (l n v) (cond ((= n 0) (cons (+ (first l) v) (rest l)))
                           (t (cons (first l) (lset (rest l) (- n 1) v)))))

; int list -> (int . int) -> int list
(defun move (state pair)
  (let* ((from (first pair))
        (to (rest pair))
        (m (min (room-of to state) (nth from state))))
    (lset (lset state from (- m)) to m)))

; int list -> (int . int) list
(defun all-moves (l)
  (remove-if #'(lambda (pair) (= (first pair) (rest pair)))
      (mapcan #'(lambda (x)
                (mapcar #'(lambda (y) (cons x y))
                        l))
              l)))
; int list -> int list list
(defun successors (state)
  (mapcar #'(lambda (x) (move state x)) (all-moves '(0 1 2))))

(defun solve-abura (a b c)
  (let* ((*capacity* (list a b c))
         (target-amount (/ a 2))
         (*goal-p* #'(lambda (state) (= (count target-amount state) 2)))
         (start (list a 0 0)))
    (abura (list start))))

(defun abura (goal-stack)
  (let ((state (first goal-stack)))
    (cond
      ((funcall *goal-p* state) (reverse goal-stack))
      ((member state (rest goal-stack) :test #'equal) nil)
      ((some #'(lambda (amt cap) (> amt cap)) state *capacity*) nil)
      (t (reduce
           #'(lambda (result new-goal-stack) (or result (abura new-goal-stack)))
           (mapcar #'(lambda (s) (cons s goal-stack)) (successors state))
           :initial-value nil)))))

;(trace abura)
(print (solve-abura 10 7 3))

とりあえず実行してみます。

CL-USER> (solve-abura 10 7 3)
((10 0 0) (3 7 0) (0 7 3) (7 0 3) (7 3 0) (4 3 3) (4 6 0) (1 6 3) (1 7 2)
 (8 0 2) (8 2 0) (5 2 3) (5 5 0))

結果を見やすくするため、表示用関数を作ります。

(defun print-result (path &aux (n 0))
  (flet ((print-step (old new)
           (let* ((names '(a b c))
                  (m (mapcar #'- new old))
                  (from (nth (position-if #'minusp m) names))
                  (to (nth (position-if #'plusp m) names)))
             (format t "[~D] ~A から ~A へ ~A 移す~%" (incf n) from to (find-if #'plusp m))
             new)))
    (if (null path)
        (format t "解が見つかりません >_<~%")
        (reduce #'print-step path))))

CL-USER> (print-result (solve-abura 10 7 3))
[1] A から B へ 7 移す
[2] A から C へ 3 移す
[3] B から A へ 7 移す
[4] C から B へ 3 移す
[5] A から C へ 3 移す
[6] C から B へ 3 移す
[7] A から C へ 3 移す
[8] C から B へ 1 移す
[9] B から A へ 7 移す
[10] C から B へ 2 移す
[11] A から C へ 3 移す
[12] C から B へ 3 移す
(5 5 0)

むー。普通に解けてるようなので、中身を見てみます。メインの探索関数は abura のようです。

(defun abura (goal-stack)
  (let ((state (first goal-stack)))
    (cond
      ((funcall *goal-p* state) (reverse goal-stack))
      ((member state (rest goal-stack) :test #'equal) nil)
      ((some #'(lambda (amt cap) (> amt cap)) state *capacity*) nil)
      (t (reduce
           #'(lambda (result new-goal-stack) (or result (abura new-goal-stack)))
           (mapcar #'(lambda (s) (cons s goal-stack)) (successors state))
           :initial-value nil)))))

処理に着目すると深さ優先探索を実施することになっていそうです。 (reduce :initial-value nil) より、 最初に state に対して successors を実施して全移動を試した後、reduce の一発目で先頭要素に abura に再帰して… とどんどん先頭要素を深くしてゆき、 ゴールに到達する、member もしくは some でダメな条件だと nil を返すと。

ここは、もうちょっと関数名をズバリ depth-first-search とかすると Lisp ぽいでしょう。 探索なんて大抵は深さ優先か幅優先の二つですし、PAIP という教科書にでてくる基礎的な探索関数を紹介しましょう。 ツリーに対する一般的な探索関数 tree-search をベースに depth-first-search, breadth-first-search を用意します。

(defun tree-search (state goal-p successors combiner)
  (cond ((null state) nil)
        ((funcall goal-p (first state)) (first state))
        (t
         (tree-search
          (funcall combiner
                   (funcall successors (first state))
                   (rest state))
          goal-p successors combiner))))

(defun depth-first-search (start goal-p successors)
  (tree-search (list start) goal-p successors #'append))

(defun breadth-first-search (start goal-p successors)
  (tree-search (list start) goal-p successors #'(lambda (x y) (append y x))))

で、あとは問題をこれに当てはめましょう。現在 abura の中でやっている現在の state から 全ての移動を試す処理を、次の状態を計算するということで next-step として取り出します。 ついでに、現在は不正な移動処理でもとりあえず状態を作って abura 関数内で排除していますが これも移動処理時に 1 つの状態だけではなく、goal-stack 相当の情報を渡すようにすれば移動処理時に 排除できます。そこまでのパス (状態のリスト) を使うことにします path == (stateN state1 state0)。

defun するのが面倒だったので labels でローカル関数で済ませちゃいます。 all-moves も手抜きでハードコーディング（拡張性を考えると all-move のほうが良いと思います）。

(defun solve-problem (a b c &optional (search #'depth-first-search))
  (let* ((capacity (list a b c))
         (target-value (/ a 2))
         (init (list a 0 0)))
    (labels ((goal-p (path)
               (= (count target-value (first path)) 2))
             (room-of (state n)
               (- (nth n capacity) (nth n state)))
             (move (path from to)
               (let* ((new (copy-list (first path)))
                      (d (min (room-of new to) (nth from new))))
                 (decf (nth from new) d)
                 (incf (nth to new) d)
                 (unless (member new path :test #'equal)
                   (cons new path))))
             (next-step (path)
               (loop for (from to) in '((0 1) (0 2) (1 0) (1 2) (2 0) (2 1))
                     for newpath = (move path from to)
                     if newpath collect newpath)))
      (nreverse (funcall search (list init) #'goal-p #'next-step)))))

できました!! 基本的には abura と同じですが、探索アルゴリズムが分離されていて汎用的になりました。 添削というより別解になってしまいましたが…。関数型な人だと move を書き直したくなると思いますが :-)

CL-USER> (print-result (solve-problem 10 7 3))
[1] A から B へ 7 移す
[2] A から C へ 3 移す
[3] B から A へ 7 移す
[4] C から B へ 3 移す
[5] A から C へ 3 移す
[6] C から B へ 3 移す
[7] A から C へ 3 移す
[8] C から B へ 1 移す
[9] B から A へ 7 移す
[10] C から B へ 2 移す
[11] A から C へ 3 移す
[12] C から B へ 3 移す
(5 5 0)
CL-USER> (print-result (solve-problem 10 7 3 #'breadth-first-search))
[1] A から B へ 7 移す
[2] B から C へ 3 移す
[3] C から A へ 3 移す
[4] B から C へ 3 移す
[5] C から A へ 3 移す
[6] B から C へ 1 移す
[7] A から B へ 7 移す
[8] B から C へ 2 移す
[9] C から A へ 3 移す
(5 5 0)

幅優先探索だと最短経路が見つかります。 今気がつきましたが、 print-result がこのインターフェースだと「全部もどして」という表示ができませんね。 capacity を渡してやるか、move 時に文字列を組み立てておくほうがいいのかもしれません。