[Haskell] 切手を切って

CodeIQコード銀行の問題、切手を切って
https://codeiq.jp/ace/code_teller/q1093
をHaskellを使って解きました。

問題は縦の枚数と横の枚数を与えられた長方形に並んだ切手から、指定された枚数をつながった状態で切り取る方法は何通りあるか答える問題です。たとえば、縦２枚、横２枚の田の字型に並んだ切手から、２枚をつながった状態で切り取る方法は４通りと数えます。問題文ファイルを読んで、解答ファイルを書くプログラムです。

Haskellのプログラムでは、mainから３つの関数を呼び出していて、そのうち、readQuestion（問題文ファイルを読む）と、writeAnswer(解答ファイルを書く）だけがIOを扱う不純(impure)な関数で、stampGame(問題を全部解く）が純粋(pure)な関数で副作用がありません。純粋な関数からは純粋な関数しか呼び出せないので、stampGameから呼び出すすべての関数が純粋な関数でできあがっています。

関数型プログラミング言語では、純粋な関数からは副作用のない純粋な関数しか呼び出せません。不純な関数からは不純な関数でも純粋な関数でも呼び出せます。できるだけ多くの部分を純粋な関数で書けるように、関数を１つ作るたびにそれは純粋な関数なのか不純な関数なのかを意識させるように、言語の方で支援してくれます。副作用がない関数であれば、同じ入力にいつも同じ出力を返すと言え、不具合が入りにくいと言われています。

プログラムを解説する設計資料として、astah*のマインドマップで表現してみました。mainから呼び出す関数をサブトピックでつなげてゆき、注目したい関数が出てきたところで、矢印付きベジェ曲線でつないで新たな幹として一番左に描きます。新たな幹は、フローティングトピックという機能を使って描きました。

黒色の枝の先、灰色の雲で囲まれているトピックだけが不純な関数で、色付きなトピックが全て純粋な関数です。

それぞれの関数に簡単な説明をつければ、関数構成が俯瞰でき、どういうアルゴリズムで解いたのかわかりやすい設計資料を作ることができます。こういう図をつけておくと自分が思い出すのにもとても便利です。

Stamp.hs

{-# OPTIONS -Wall -Werror #-}
{-# LANGUAGE CPP #-}　 -- | __LINE__ が使えるように
module Main where
import Control.Applicative hiding ((<|>),many)
import Test.HUnit
import Data.Char
import System.IO

-- | 切手型
type Stamp = String

-- | 切手のサンプル
a0,a1,a2,a3,b0,b1,b2,b3 :: Stamp
[a0,a1,a2,a3] = ["a0","a1","a2","a3"]
[b0,b1,b2,b3] = ["b0","b1","b2","b3"]

-- | 2つの切手がつながっているときTrue
connect :: Stamp -> Stamp -> Bool
connect kitte1 kitte2 
  | abs (tate1 - tate2) > 1 = False
  | abs (yoko1 - yoko2) > 1 = False
  | tate1 == tate2 && abs (yoko1 - yoko2) == 1 = True
  | yoko1 == yoko2 && abs (tate1 - tate2) == 1 = True
  | otherwise = False
    where [tate1,yoko1] = map ord kitte1
          [tate2,yoko2] = map ord kitte2

-- | 1つの切手が複数の切手のどれかとつながっているときTrue
oneConnect :: Stamp -> [Stamp] -> Bool
oneConnect n list
  | null list = False
  | connect n x = True
  | otherwise = oneConnect n xs
      where (x:xs) = list

-- | dest src keepで、destにつながっているsrcをdestにできるだけ移してdestを返す
move3 :: [Stamp] -> [Stamp] -> [Stamp] -> [Stamp]
move3 dest [] _ = dest
move3 dest (x:xs) keep = 
   if oneConnect x dest then move3 (x:dest) (xs ++ keep) []
                        else move3 dest xs (x:keep)

-- | listがhead listに全部つながっていたらlistを返す
move2 :: [Stamp] -> [Stamp]
move2 list = reverse $ move3 [x] xs []
             where (x:xs) = list 

-- | listが全部つながっていたらTrue
move1 :: [Stamp] -> Bool
move1 [] = False
move1 list = len1 == len2
             where len1 = length list
                   len2 = length $ move2 list 

-- | listが全部つながっていたらTrue
trained :: [Stamp] -> Bool
trained = move1

------------------------------------------------------
-- | test
line :: Int -> String
line n = "line: " ++ show (n::Int)

move2Test :: Test
move2Test = test [
    line __LINE__ ~: True  ~=? connect a1 a2,
    line __LINE__ ~: False ~=? connect a1 b2,

    line __LINE__ ~: True  ~=? oneConnect a1 [a2],
    line __LINE__ ~: True  ~=? oneConnect a1 [a2, a3],
    line __LINE__ ~: False ~=? oneConnect b1 [a3, b3],

    line __LINE__ ~: [a1,a0,b1,b0]  ~=? move2 [a1,b0,a0,b1],
    line __LINE__ ~: [a0,b0]  ~=? move2 [a0,b0,a2,b2],

    line __LINE__ ~: False ~=? trained [a0,b0,b2],
    line __LINE__ ~: False ~=? trained [a0,b1,a2],
    line __LINE__ ~: True  ~=? trained [a0,a1,a2],
    line __LINE__ ~: True  ~=? trained [a2,a0,a1],
    line __LINE__ ~: True  ~=? trained [a1,b0,b1],
    line __LINE__ ~: True  ~=? trained [a2,b1,b2],
    line __LINE__ ~: True  ~=? trained [a1,a2,a3,b1],
    line __LINE__ ~: True  ~=? trained [a1,a2,b2,b3],
    line __LINE__ ~: True  ~=? trained [b2,a1,b3,a2],
    line __LINE__ ~: False ~=? trained [a1,a3,b2,b3],
    line __LINE__ ~: False ~=? trained [a1,b1,a3,b3],
    line __LINE__ ~: False ~=? trained [a1,b3,a3,b1],
    True ~=? True
    ]

moveTest :: IO Counts
moveTest = runTestTT move2Test

main3 :: IO ()
main3 = do
       _ <- moveTest
       _ <- cardTest
       let stamps = makeStampComb 2 3 3
       mapM_ print $ zip stamps $ map move2 stamps
       putStrLn $ "line: " ++ show (__LINE__::Int)

------------------------------------------------------
-- | 切手の集合を作る
makeStamps :: Int -> Int -> [Stamp]
makeStamps tate yoko = [[t,y]|t <- ts, y <- ys]
                       where nextChar = chr . succ . ord :: Char -> Char
                             tates = 'a':map nextChar tates :: String
                             yokos = '0':map nextChar yokos :: String
                             ts = take tate tates :: String
                             ys = take yoko yokos :: String

-- | 組み合わせを作る
combination :: [a] -> Int -> [[a]]
combination _ 0     = [[]]
combination [] _    = []
combination (x:xs) n = map (x:) (combination xs (n-1)) ++ combination xs n

-- | 切手の組み合わせを作る
makeStampComb :: Int -> Int -> Int -> [[Stamp]]
makeStampComb tate yoko maisuu = combination stamps maisuu
        where stamps = makeStamps tate yoko

-- | 縦、横、枚数から　組み合わせの数 (答え)を求める
count :: Int -> Int -> Int -> Int
count tate yoko maisuu =
  length $ filter (==True) $ map trained combs
      where combs2 = makeStampComb tate yoko maisuu
            combs = filterStamps maisuu combs2

-- | 切手リストの幅と高さの両方が枚数より小さい時にTrue
inRange :: Int -> [Stamp] -> Bool
inRange maisuu stamps = maisuu > max haba takasa
  where (yokos,tates) = unzip $ map (\x->(ord (x!!0),ord (x!!1))) stamps
        haba   = maximum yokos - minimum yokos
        takasa = maximum tates - minimum tates

-- | 切手リストから、幅と高さの両方が枚数より小さい切手リストを選ぶ
-- | 22秒ー＞16秒ぐらいに短縮
filterStamps :: Int->[[Stamp]]->[[Stamp]]
filterStamps maisuu = filter (inRange maisuu) 

------------------------------------------------------
-- | test
testCards :: Test
testCards = test [
    line __LINE__ ~: 4 ~=? count 2 2 2,
    line __LINE__ ~: 4 ~=? count 2 2 3,
    line __LINE__ ~: 7 ~=? count 2 3 2,
    line __LINE__ ~: 10 ~=? count 2 3 3,
    -- | CodeIQ 出題
    line __LINE__ ~: 40 ~=? count 5 5 2,
    line __LINE__ ~: 34 ~=? count 3 4 3,
    line __LINE__ ~: 65 ~=? count 3 4 4,
    line __LINE__ ~: 1282 ~=? count 6 7 5,
    line __LINE__ ~: True ~=? True
    ]

cardTest :: IO Counts
cardTest = runTestTT testCards

------------------------------------------------------
-- | 解答作成
game4 :: String -> String
game4 question = show $ count tate yoko maisuu
                 where [tate,yoko,maisuu] = map (\s -> read s :: Int) $ words question

-- | 問題文解釈
game3 :: Int -> [String] -> [String] -> [String]
game3 0 _  dest = reverse dest
game3 n ss dest = game3 (n-1) xs (game4 x:dest)
                  where (x:xs) = ss

-- | 問題文解釈
game2 :: [String] -> [String]
game2 ss = game3 n xs []
           where (x:xs) = ss
                 n = read x :: Int

-- | 問題文解釈
stampGame :: String -> String
stampGame = unlines . game2 . lines

-- | IO functions
readQuestion :: FilePath -> IO String
readQuestion fname1 = 
  withFile fname1 ReadMode $ \h -> do
    contents <- hGetContents h
    putStr contents  -- | これを入れておくと遅延しない
    return contents

writeAnswer :: FilePath -> String -> IO ()
writeAnswer fname2 contents = 
  withFile fname2 WriteMode $ \h -> hPutStr h contents

main2 :: IO ()
main2 = main3 >> stampGame <$> readQuestion "sample.in.txt" >>= writeAnswer "sample.out.txt"

main :: IO ()
main = stampGame <$> readQuestion "testdata.in.txt" >>= writeAnswer "testdata.out.txt"

『これを入れておくと遅延しない』と書いたところ、本当はどう書けば良かったのでしょう？