Haskellでハノイの塔

ハノイの塔と脳の弱いウンコード

よく考えたら今まで一度も「ハノイの塔」を書いたことがないことに気がついた。
AからCにn枚移すには、AからBに(n-1)枚移してAからCに1枚移してBからCに(n-1)枚移す、という再帰のお手本のような話だが、それをそのまま書いただけのウンコード。

手順のリストを塔の状態から塔の状態への関数のリストとして書いて最後にscanlで逐次適用して状態遷移をつくり上げるところが少し面白かったくらいかな。そういえば(flip ($))はどこかで見たような……F#のパイプライン演算子？

第一投

TowersOfHanoi.hs

module Main where
import Data.List (unwords)
import Control.Applicative ((<$>))
import System.Environment (getArgs)

type Tower = ([Int],[Int],[Int])
type Move = Tower -> Tower

-- :: Move
aTb (a:as,bs,cs) = (as, a:bs, cs)
aTc (a:as,bs,cs) = (as, bs, a:cs)
bTc (as,b:bs,cs) = (as, bs, b:cs)
bTa (as,b:bs,cs) = (b:as, bs, cs)
cTa (as,bs,c:cs) = (c:as, bs, cs)
cTb (as,bs,c:cs) = (as, c:bs, cs)

-- :: Int -> [Move]
moveAtoC 1  = [aTc]
moveAtoC n  = moveAtoB (n-1) ++ moveAtoC 1 ++ moveBtoC (n-1)
moveAtoB 1  = [aTb]
moveAtoB n  = moveAtoC (n-1) ++ moveAtoB 1 ++ moveCtoB (n-1)
moveBtoC 1  = [bTc]
moveBtoC n  = moveBtoA (n-1) ++ moveBtoC 1 ++ moveAtoC (n-1)
moveBtoA 1  = [bTa]
moveBtoA n  = moveBtoC (n-1) ++ moveBtoA 1 ++ moveCtoA (n-1)
moveCtoA 1  = [cTa]
moveCtoA n  = moveCtoB (n-1) ++ moveCtoA 1 ++ moveBtoA (n-1)
moveCtoB 1  = [cTb]
moveCtoB n  = moveCtoA (n-1) ++ moveCtoB 1 ++ moveAtoB (n-1)

run :: Tower -> [Move] -> [Tower]
run = scanl (flip ($))


main = solve<$>read<$>head<$>getArgs >>= mapM_ print
    where solve n = run ([1..n],[],[]) (moveAtoC n)

実行結果

> ./TowersOfHanoi 3
([1,2,3],[],[])
([2,3],[],[1])
([3],[2],[1])
([3],[1,2],[])
([],[1,2],[3])
([1],[2],[3])
([1],[],[2,3])
([],[],[1,2,3])

結果から逆算するクソコード

上のコードの実行結果を少し眺めてみる：

> ./TowersOfHanoi 1
([1],[],[])
([],[],[1])

> ./TowersOfHanoi 2
([1,2],[],[])
([2],[1],[])
([],[1],[2])
([],[],[1,2])

まあアレだ、上のヤツを捏ねくり回せば下のやつが作れそうに見えないですかね。まず、下の前半は上のヤツの最初の柱に2をくっつけたものに似ている。で、下の後半は上のヤツの最後の柱に2をくっつけたものに似ている。

([1,2],[],[])
([2],[],[1])
([1],[],[2])
([],[],[1,2])

こりゃそっくりですわ。違いは、前半は2番めの柱と3番めの柱が入れ替わっていること、後半は1番めと2番めの柱が入れ替わっていること、だけだ。というわけで、露骨にそう書くとどうなるか。

第二投

TowersOfHanoi2.hs

module Main where
import Control.Applicative ((<$>))
import System.Environment (getArgs)

solve 0 = [([],[],[])]
solve n = -- n-1枚をaからcに移す一連の遷移 solve (n-1) がわかっているとするとそれに対し
    map (\(a,b,c)->(a++[n],c,b)) (solve (n-1)) ++ -- 柱aにnをくっつけて柱bと柱cを交換
    map (\(a,b,c)->(b,a,c++[n])) (solve (n-1))    -- 柱cにnをくっつけて柱aと柱bを交換


main = solve<$>read<$>head<$>getArgs >>= mapM_ print

というわけで、これでまったく等価。最初の$n=1,2,3$辺りの遷移を手で書いてみれば思いつく話ではあり、はじめからこう書くべきであったような気もする。実にウンコである。

おまけでワンライナー

main = fix (\r n -> if n>0 then [\(a,b,c) -> (n:a,c,b),\(a,b,c) -> (b,a,n:c)] <*> r (n-1) else [([],[],[])])<$>read<$>head<$>getArgs >>= mapM_ print

実行結果

> ./TowersOfHanoi2 3
([1,2,3],[],[])
([2,3],[],[1])
([3],[2],[1])
([3],[1,2],[])
([],[1,2],[3])
([1],[2],[3])
([1],[],[2,3])
([],[],[1,2,3])