ハノイの塔

	--hanoi.hs
	import System.Environment
	getN :: IO Int
	getN = do
	a:_ <- getArgs
	return $ read a
	main = do
	n <- getN
	hanoi [1..n] 'A' 'B' 'C'
	hanoi [] _ _ _ = return ()
	hanoi (x:xs) o d t = do
	hanoi xs o t d
	putStrLn $ o:'-':d:[]
	hanoi xs t d o

view raw hanoi.hs hosted with ❤ by GitHub

ハノイの塔の由来や、ルール、解き方のアルゴリズムは省略します。

---

hanoi.hs

実質３行のプログラムです。

haskellが提供する再帰とｄｏ記法で極めて簡潔に書くことができます。

実行例

$ runghc hanoi.hs 3

A-B

A-C

B-C

A-B

C-A

C-B

A-B

最短の解き手順を表示します。

円盤３枚の場合です。

A-Bというのは塔Aの一番上の円盤を塔Bに移動するという意味です。

---

GUI版

---

	import Graphics.UI.Gtk
	import System.IO.Error
	import Data.Char
	import Control.Exception
	import System.Environment
	import Control.Monad
	getNs :: IO (Int,Int)
	getNs = getArgs >>= \[a,b] -> return (read a,read b)
	getN, getT :: IO Int
	getN = getNs >>= \(a,_) -> return a
	getT = getNs >>= \(_,b) -> return b
	recompose :: String -> [Int]
	recompose s = map length (words s)
	recompose' ss = return [recompose x|x <- ss]
	filWith0 :: [Int] -> IO [Int]
	filWith0 il = do
	n <- getN
	return $ zeros n ++ il
	where zeros x = replicate (x-length il) (0 :: Int)
	showLst :: [Int] -> String
	showLst [] = []
	showLst (x:xs) | x == 0 = '\n' : showLst xs
	| otherwise = replicate x (toUpper (intToDigit x)) ++ "\n" ++ showLst xs
	showTowers tw lbs = zipWithM_ (\x y -> x `set` [labelText := y])
	lbs
	[showLst x| x<- tw]
	move "A-B" (a:as,b,c) = (as,a:b,c)
	move "A-C" (a:as,b,c) = (as,b,a:c)
	move "B-A" (a,b:bs,c) = (b:a,bs,c)
	move "B-C" (a,b:bs,c) = (a,bs,b:c)
	move "C-A" (a,b,c:cs) = (c:a,b,cs)
	move "C-B" (a,b,c:cs) = (a,c:b,cs)
	move _ x = x
	move' s [aa,bb,cc] = let (a,b,c) = move s (aa,bb,cc) in return [a,b,c]
	update towers lbs = do
	l <- (catchIOError getLine (\_ -> return ""))
	mapM labelGetText lbs
	>>= recompose'
	>>= move' l
	>>= mapM filWith0
	>>= flip showTowers lbs
	main = do
	n <- getN
	let nullList = [] :: [Int]
	let towers@(a,b,c) = ([1..n],nullList,nullList)
	initGUI
	window <- windowNew
	box <- hBoxNew False 0
	(la,fa) <- myLabelWithFrameNew $ showLst a
	(lb,fb) <- myLabelWithFrameNew $ showLst b
	(lc,fc) <- myLabelWithFrameNew $ showLst c
	mapM_ (\x -> boxPackStart box x PackNatural 0) [fa,fb,fc]
	containerAdd window box
	widgetShowAll window
	window `on` unrealize $ mainQuit
	getT >>= timeoutAdd (f towers [la,lb,lc])
	mainGUI
	f t l = do
	update t l
	return True
	myLabelWithFrameNew , myLabelWithFrameNew' :: String -> IO (Label,Frame)
	myLabelWithFrameNew' s = do
	(l,f) <- myLabelWithFrameNew s
	return (l,f)
	myLabelWithFrameNew s = do
	l <- labelNewWithMnemonic s
	l `set` [labelJustify := JustifyCenter]
	getN >>= labelSetWidthChars l
	frame <- frameNew
	containerAdd frame l
	frame `set` [frameShadowType := ShadowOut]
	return (l, frame)

view raw guihanoi.hs hosted with ❤ by GitHub

$ runghc hanoi.hs 3 | runghc guihanoi.hs 3 100

labelhanoi.hsへの第2引数はタイミングです。ミリ秒で指定します。

同じ引数を渡すのは面倒なのでhanoi という名前でスクリプトを書いておきます。

ｒunghc hanoi.hs $1 | runghc guihanoi.hs $1 $2

＄ ./hanoi 9 500

---

コンソール版

	import Control.Monad.State
	import System.Environment
	dohanoi :: StateT ([Int], [Int], [Int]) IO b
	dohanoi = do
	showTowers
	l <- liftIO $ getLine
	ts <- get
	move l
	dohanoi
	move "" = return ()
	move "A-B" = do{ (a:as,b,c) <- get; put (as,a:b,c)}
	move "A-C" = do{ (a:as,b,c) <- get; put (as,b,a:c)}
	move "B-A" = do{ (a,b:bs,c) <- get; put (b:a,bs,c)}
	move "B-C" = do{ (a,b:bs,c) <- get; put (a,bs,b:c)}
	move "C-A" = do{ (a,b,c:cs) <- get; put (c:a,b,cs)}
	move "C-B" = do{ (a,b,c:cs) <- get; put (a,c:b,cs)}
	showTowers = do
	(a,b,c) <- get
	mapM_ (liftIO . print . reverse) [a,b,c]
	liftIO $ print ()
	nullList = [] ::[Int]
	getN :: IO Int
	getN = do{a:_ <- getArgs; return $ read a;}
	main :: IO (a, ([Int], [Int], [Int]))
	main = do
	n <- getN
	let towers = ([1..n],nullList,nullList)
	runStateT dohanoi towers

view raw doHanoi.hs hosted with ❤ by GitHub

---

スクリプト

runghc hanoi.hs  $1 | runghc -XFlexibleContexts doHanoi.hs $1

実行例

./dohanoi 64

こちらも参照ください。

https://senjounosantafe.blogspot.com/2018/05/hanoi.html