第12回オフラインリアルタイムどう書くの問題「サイコロを転がす」をHaskellで解く

第12回 オフラインリアルタイムどう書くの問題「サイコロを転がす」を、Haskellで解きました。
Stateモナド厨。

diceState.hs

-- http://nabetani.sakura.ne.jp/hena/ord12rotdice/
import Data.List
import Control.Monad.State

-- 1と2の向きで表わしたサイコロの方向の状態。NEは「1の目が北(N)、2の目が東(E)」を表わす。Uは上、Dは下を表わす。
data DiceState = NE|ES|SW|WN|EN|SE|WS|NW|UN|ND|DS|SU|NU|DN|SD|US|UE|ED|DW|WU|EU|DE|WD|UW deriving (Show, Eq)

-- それぞれのサイコロの状態で上面の数字(目)を表わす連想リスト。
deuce :: [(DiceState, Char)]
deuce = [(NE,'4'),(ES,'4'),(SW,'4'),(WN,'4'),(EN,'3'),(SE,'3'),
         (WS,'3'),(NW,'3'),(UN,'1'),(ND,'5'),(DS,'6'),(SU,'2'),
         (NU,'2'),(DN,'6'),(SD,'5'),(US,'1'),(UE,'1'),(ED,'5'),
         (DW,'6'),(WU,'2'),(EU,'2'),(DE,'6'),(WD,'5'),(UW,'1')]

-- ころがし操作。'N':北へころがす, 'W':西へころがす, 'S':南へころがす, 'E':東へころがす
type Roll = Char

-- サイコロの状態における目(上を向いている面の数値)を返す
getDeuce :: DiceState -> Char
getDeuce state = let (Just n) = lookup state deuce in n

mkpair :: (t, t, t, t) -> [(t, t)]
mkpair (a,b,c,d) = [(a,b),(b,c),(c,d),(d,a)]

-- 東にころがす回転('E')におけるサイコロ状態の変化
-- [(回転前の状態,回転後の状態), ...]の連想リスト
moveDataToEast :: [(DiceState, DiceState)]
moveDataToEast = concat [mkpair (UN,EN,DN,WN),
                         mkpair (ND,NW,NU,NE),
                         mkpair (DS,WS,US,ES),
                         mkpair (SU,SE,SD,SW),
                         mkpair (ED,DW,WU,UE),
                         mkpair (EU,DE,WD,UW)]
-- 北にころがす回転('N')におけるサイコロ状態の変化
-- [(回転前の状態,回転後の状態), ...]の連想リスト
moveDataToNorth :: [(DiceState, DiceState)]
moveDataToNorth = concat [mkpair (UN,ND,DS,SU),
                          mkpair (EN,ED,ES,EU),
                          mkpair (DN,SD,US,NU),
                          mkpair (WN,WD,WS,WU),
                          mkpair (NW,DW,SW,UW),
                          mkpair (SE,UE,NE,DE)]

-- 指定した状態に対して、ころがし操作を与えたとき、次状態を得る
step :: Roll -> DiceState -> DiceState
step r direc = case r of
                 'N' -> moveN direc
                 'W' -> moveW direc
                 'S' -> moveS direc
                 'E' -> moveE direc
               where
                 -- 北にころがしたときの次状態を返す
                 moveN :: DiceState -> DiceState
                 moveN s = let (Just d) = lookup s moveDataToNorth in d
                 -- 西にころがしたときの次状態を返す
                 moveW :: DiceState -> DiceState
                 moveW s = moveE $ moveE $ moveE s
                 -- 南にころがしたときの次状態を返す
                 moveS :: DiceState -> DiceState
                 moveS s = moveN $ moveN $ moveN s
                 -- 東にころがしたときの次状態を返す
                 moveE :: DiceState -> DiceState
                 moveE s = let (Just d) = lookup s moveDataToEast in d

-- ころがし操作を与えると次の状態モナドを返すモナディック関数
-- 状態は、(サイコロ上面の数値(目)の履歴, サイコロの状態)というタプルで表現。
stepSt :: Roll -> State (String, DiceState) ()
stepSt ch = do
  (xs, direc) <- get
  let nextDirec = step ch direc
  state $ const ((), (getDeuce nextDirec:xs, nextDirec))

-- ころがし操作の列と、結果(目の履歴)の期待値を与え、一致しているかどうかを返す
test :: String -> String -> Bool
test opr expected = let (xs, _) = execState (mapM stepSt opr) (['1'], UN)
                    in (reverse xs == expected)

main :: IO ()
main = do
    print $ test "NNESWWS" "15635624"  {-- 0 --}
    print $ test "EEEE" "13641"  {-- 1 --}
    print $ test "WWWW" "14631"  {-- 2 --}
    print $ test "SSSS" "12651"  {-- 3 --}
    print $ test "NNNN" "15621"  {-- 4 --}
    print $ test "EENN" "13651"  {-- 5 --}
    print $ test "WWNN" "14651"  {-- 6 --}
    print $ test "SSNN" "12621"  {-- 7 --}
    print $ test "NENNN" "153641"  {-- 8 --}
    print $ test "NWNNN" "154631"  {-- 9 --}
    print $ test "SWWWSNEEEN" "12453635421"  {-- 10 --}
    print $ test "SENWSWSNSWE" "123123656545"  {-- 11 --}
    print $ test "SSSWNNNE" "126546315"  {-- 12 --}
    print $ test "SWNWSSSWWE" "12415423646"  {-- 13 --}
    print $ test "ENNWWS" "1354135"  {-- 14 --}
    print $ test "ESWNNW" "1321365"  {-- 15 --}
    print $ test "NWSSE" "154135"  {-- 16 --}
    print $ test "SWNWEWSEEN" "12415154135"  {-- 17 --}
    print $ test "EWNWEEEEWN" "13154532426"  {-- 18 --}
    print $ test "WNEWEWWWSNW" "145151562421"  {-- 19 --}
    print $ test "NNEE" "15631"  {-- 20 --}
    print $ test "EEEEWNWSW" "1364145642"  {-- 21 --}
    print $ test "SENNWWES" "123142321"  {-- 22 --}
    print $ test "SWWWSNSNESWW" "1245363635631"  {-- 23 --}
    print $ test "WESSENSE" "141263231"  {-- 24 --}
    print $ test "SWNSSESESSS" "124146231562"  {-- 25 --}
    print $ test "ENS" "1353"  {-- 26 --}
    print $ test "WNN" "1453"  {-- 27 --}
    print $ test "SSEENEEEN" "1263124536"  {-- 28 --}
    print $ test "NWSNNNW" "15414632"  {-- 29 --}
    print $ test "ESSSSSWW" "132453215"  {-- 30 --}
    print $ test "ESE" "1326"  {-- 31 --}
    print $ test "SNWNWWNSSSS" "121456232453"  {-- 32 --}
    print $ test "SWEESEN" "12423653"  {-- 33 --}
    print $ test "NEEWNSSWWW" "15323631562"  {-- 34 --}
    print $ test "WSEW" "14212"  {-- 35 --}
    print $ test "SWSNNNSNWE" "12464131353"  {-- 36 --}
    print $ test "ENWEWSEEW" "1351513545"  {-- 37 --}
    print $ test "WSEWN" "142124"  {-- 38 --}
    print $ test "EWNEESEWE" "1315321414"  {-- 39 --}
    print $ test "NESEEN" "1531263"  {-- 40 --}
    print $ test "WSW" "1426"  {-- 41 --}
    print $ test "ENEWE" "135656"  {-- 42 --}