ALGOBIT

方針

各手順を行った際の各杭の状態を順に出力したいので, 変化していく状態を, 状態のリストとして返したいです.
(第七階と同じです.)

状態の表現

各状態を, {各杭に積まれた円盤の番号を小さい順に並べたリスト} を三つの杭 A, B, C についてこの順に並べたリスト, とします.
例えば円盤の数 3 のハノイの塔の初期状態は

'((1 2 3) () ())

杭 A から杭 C に1 の円盤を移した状態は

'((2 3) () (1))

とします.

手順をあらわす関数

一手の円盤の移動に相当する関数を考えてみます.
A の杭の一番上の円盤を B の杭に動かす関数は

(fn [[[af & ar] b c]] (list ar (cons af b) c))

と書けます.
REPL で確かめてみます.

user=> ((fn [[[af & ar] b c]] (list ar (cons af b) c)) '((2 3) () (1)))
((3) (2) (1))

どの杭からどの杭に移すかを指定すると上記のような関数を返す関数を考えてみましょう.

(defn move [s d]
  (letfn [(rev [[a b c]]
            (if (< 0 (mod (- (+ 2 d) s) 3)) (list a c b) (list a b c)))
          (move01 [[[af & ar] b c]] (list ar (cons af b) c))]
    (fn [x]
      (->> x cycle (drop s) (take 3) rev move01
        rev cycle (drop (- 3 s)) (take 3)))))

->> は, フォーム列を与えると, 直前の結果を次のフォームの最後の引数として順に適用するマクロです.
s が 1, d が 0 (杭 B から, 杭 A に一番上の円盤を移動）として, ‘((3 4) (1 2) ()) を引数に与えた場合途中経過は以下のようになります.

(defn move [s d]
  (letfn [(rev [[a b c]]
            (if (< 0 (mod (- (+ 2 d) s) 3)) (list a c b) (list a b c)))
          (move01 [[[af & ar] b c]] (list ar (cons af b) c))]
    (fn [x]
      (->>
        x              ; '((3 4) (1 2) ())
        cycle          ; '((3 4) (1 2) () (3 4) (1 2) () ...)
        (drop s)       ; '((1 2) () (3 4) (1 2) () ...)
        (take 3)       ; '((1 2) () (3 4))
        rev            ; '((1 2) (3 4) ())
        move01         ; '((2) (1 3 4) ())
        rev            ; '((2) () (1 3 4))
        cycle          ; '((2) () (1 3 4) (2) () (1 3 4) ...)
        (drop (- 3 s)) ; '((1 3 4) (2) () (1 3 4) ...)
        (take 3)       ; '((1 3 4) (2) ())
      ))))

コードを toh09.clj に保存してあるものとして, REPL で確かめてみます.

user=> (load-file "toh09.clj")
#'user/-main
user=> ((move 0 1) '((1 2) () (3)))
((2) (1) (3))
user=> ((move 2 1) '((1 2) () (3)))
((1 2) (3) nil)
user=> ((move 2 0) '((1 2) () (3)))
((3 1 2) () nil)

空になった杭が nil になってしまいますが, cons に対して nil は空リストのように振る舞います

user=> (cons 1 nil)
(1)

ので気にしないことにします.

手順をあらわす関数のリスト

次に, 手順を表す関数のリストを返す関数を考えてみます.
円盤の数 n と, どの杭から(インデクス s) どの杭に (インデクス d) に移すかを与え, 先ほどの手順のリストを返します.
t は残りの杭のインデクスです.

(defn hanoi [s t d n]
  (if (zero? n) '()
      (concat (hanoi s d t (- n 1))
              (list (move s d))
              (hanoi t s d (- n 1)))))

s から d に n 番目以下の全ての円盤を移す手順の列は, s から t に (n – 1) 番以下の全ての円盤を移す手順の列と, s から d に一番上の円盤を移す手順と, t から d に (n – 1) 番以下の全ての円盤を移す手順を順に並べたものです.

(hanoi 0 1 2 n) で 目的の関数列が得られます.
(first (hanoi 0 1 2 n)) は最初の手順を表す関数です.
n == 3 として, 最初の手順を初期状態 ‘((1 2 3) () ()) に適用してみます.

user=> (load-file "toh09.clj")
#'user/-main
user=> ((first (hanoi 0 1 2 3)) '((1 2 3) () ()))
((2 3) () (1))

手順のリストを状態に順に適用

関数のリストと初期値を引数に取り, 初期値, 最初の関数を適用した結果, 前の結果に次の関数を適用した結果, … といった値の列を得るような関数について考えます.
つまり (list f0 f1 f2 …) と x を与えると
(list x (f0 x) (f1 (f0 x)) (f2 (f1 (f0 x))) … )
を返すような関数です.
これは

(defn iterf [[f & fs] x] (if f (cons x (iterf fs (f x))) (list x)))

のようにかけます.
やっていることは ->> と同じですが ->> はマクロなので,

(apply ->> (list x f0 f1 f2 ...))

のようには使えないと思いますたぶん.

円盤の数 n のハノイの塔を解く過程の全ての状態を出力するには

(iterf (hanoi 0 1 2 n) (list (range 1 (+ n 1)) '() '())

とすれば良いです.

user=> (load-file "toh09.clj")
#'user/-main
user=> (iterf (hanoi 0 1 2 3) (list (range 1 (+ 3 1)) '() '()))
(((1 2 3) () ()) ((2 3) () (1)) ((3) (2) (1)) ((3) (1 2) nil) (nil (1 2) (3)) ((1) (2) (3)) ((1) nil (2 3)) (nil nil (1 2 3)))

これで問題を解く部分は完成です.

整形

円盤の数 n と
‘((2 3) (1) ())
という状態を与えると

    |        |        |
  --|--      |        |
 ---|---    -|-       |
===========================

のような n + 1 行の文字列を返す関数を作ります.

(defn form [n s]
  (letfn [(ws [m] (take m (repeat \space)))
          (bar [m] (take m (repeat \-)))
          (pad0 [s] (map #(reverse (take n (concat (reverse %) (repeat 0)))) s))
          (rod [x] (concat (ws (+ (- n x) 1)) (bar x) "|"
                           (bar x) (ws (+ (- n x) 1))))
          (line [a b c] (concat (rod a) (rod b) (rod c) "\n"))
          (form_ [[[x & xs] [y & ys] [z & zs]]]
            (if x (concat (line x y z) (form_ (list xs ys zs)))
                  (concat (take (+ (* 6 n) 9) (repeat \=)) "\n")))]
     (apply str (form_ (pad0 s)))))

(ws [m]) は長さ m の空白文字, (bar [m]) は m 個のハイフンからなる文字列を返します.
pad0 は, 各状態を文字列で表現しやすいよう, 各杭を表すリストの先頭に長さが n になるまで に 0 を追加します.
n が 3 ならば, (pad0 ‘((2 3) (1) ())) は ‘((0 2 3) (0 0 1) (0 0 0)) となります.

(rod [x]) は杭を表す縦棒の両側に, 円盤の大きさ x 個のハイフンと, 余白の空白からなる文字列を返します.
n が 3 の時, (rod 1) は ” -|- “, (rod 3) は ” —|— ” のようになります.

(line [a b c]) は, ある行に相当する各杭の円盤の大きさから, 一行分の文字列を作ります.

form_ は, 各杭の状態を表すデータが格段の円盤の大きさ (無い場合は 0) を表すよう pad0 で変形された状態を受け取り, line で作った一行分の文字列と {各杭の次の段以後の円盤のを引数として呼び出した自分自身} と連結します.
最後の行は (concat (take (+ (* 6 n) 9) (repeat \=)) “\n”) で適当な数の ‘=’ にします.

確認

user=> (load-file "toh09.clj")
#'user/-main
user=> (print (form 3 '((1 2 3) () ())))
   -|-       |        |
  --|--      |        |
 ---|---     |        |
===========================
nil
user=> (print (form 3 '((2 3) (1) ())))
    |        |        |
  --|--      |        |
 ---|---    -|-       |
===========================
nil

main

(defn -main [& args]
  (let [argc (count args)
        n (if (< 0 argc) (Integer/parseInt (first args)) 3)
        w (if (< 1 argc) (Integer/parseInt (second args)) 500)]
    (dorun
      (map (fn [x]
             (print "\u001b[2J\u001b[2;1H")
             (print (form n x))
             (flush)
             (Thread/sleep w))
           (iterf (hanoi 0 1 2 n) (list (range 1 (+ n 1)) '() '()))))))

iterf と hanoi で作った状態のリストに対して順にを map の第一引数として指定した無名関数を適用します.
map は遅延シーケンスを返しますので, 副作用を全部処理するよう, dorun で包みます.
無名関数内では, エスケープシーケンスで端末をクリアし,
状態の表示を行い, flush でバッファをフラッシュし (しないと最終結果しか表示されません),
w ミリ秒停止します.

引数で, 円盤の数 n と, 各状態の表示の間の待ち時間 w (ミリ秒) を与えます.
指定しない場合は円盤の数 3, 待ち時間 500 ミリ秒とします.

クラスファイル等にコンパイルする場合は, -main がエントリポイントになるように調整します.
インタプリタで実行する場合は

;(apply -main *command-line-args*)

をアンコメントして, コマンドライン引数を -main に引き渡すようにします.

実行してみます.

ソースコード全体は以下のようになります.
toh09.clj

(defn move [s d]
  (letfn [(rev [[a b c]]
            (if (< 0 (mod (- (+ 2 d) s) 3)) (list a c b) (list a b c)))
          (move01 [[[af & ar] b c]] (list ar (cons af b) c))]
    (fn [x]
      (->> x cycle (drop s) (take 3) rev move01
        rev cycle (drop (- 3 s)) (take 3)))))

(defn hanoi [s t d n]
  (if (zero? n) '()
      (concat (hanoi s d t (- n 1))
              (list (move s d))
              (hanoi t s d (- n 1)))))

(defn iterf [[f & fs] x] (if f (cons x (iterf fs (f x))) (list x)))

(defn form [n s]
  (letfn [(ws [m] (take m (repeat \space)))
          (bar [m] (take m (repeat \-)))
          (pad0 [s] (map #(reverse (take n (concat (reverse %) (repeat 0)))) s))
          (rod [x] (concat (ws (+ (- n x) 1)) (bar x) "|"
                           (bar x) (ws (+ (- n x) 1))))
          (line [a b c] (concat (rod a) (rod b) (rod c) "\n"))
          (form_ [[[x & xs] [y & ys] [z & zs]]]
            (if x (concat (line x y z) (form_ (list xs ys zs)))
                  (concat (take (+ (* 6 n) 9) (repeat \=)) "\n")))]
     (apply str (form_ (pad0 s)))))

(defn -main [& args]
  (let [argc (count args)
        n (if (< 0 argc) (Integer/parseInt (first args)) 3)
        w (if (< 1 argc) (Integer/parseInt (second args)) 500)]
    (dorun
      (map (fn [x]
             (print "\u001b[2J\u001b[2;1H")
             (print (form n x))
             (flush)
             (Thread/sleep w))
           (iterf (hanoi 0 1 2 n) (list (range 1 (+ n 1)) '() '()))))))

;(apply -main *command-line-args*)

プログラミングClojure

Stuart Halloway

オーム社

発売日：2010-01-26

ブクログでレビューを見る»