DevQuizに参加しました(3)

スライドパズル

最後はスライドパズル。いわゆる15パズルを解く問題なのですが、4x4だけではなく3x3〜6x6、4x3などの長方形もあり、「壁」という動かないパネルもあるという、変形15パズルです。
これはチャレンジ問題ということで、とても難しかったです。
結果、5000問中1335問正解で時間切れになってしまいました。
この問題は反省しきりです。

module Main where
import Prelude hiding (Left, Right)
import Time
import Directory

sampletable :: Table
sampletable = ((0, 0), [(1, (1, 0)), (2, (1, 1)), (3, (0, 1))])
samplegoal :: Table
samplegoal  = ((1, 1), [(1, (0, 0)), (2, (1, 0)), (3, (0, 1))])
-- solve001 = moves2str $ solve (5, 6) $ readTable 5 "12=E4D9HIF8=GN576LOABMTPKQSR0J"
-- solve007 = moves2str $ solve (3, 3) q007
q007 :: Table
q007 = readTable 3 "168452=30"
{- 
q007 =
  ((2, 2), [
    (1, (0, 0)),
    (2, (2, 1)),
    (3, (1, 2)),
    (4, (0, 1)),
    (5, (1, 1)),
    (6, (1, 0)),
    (8, (2, 0))
  ])
-}


main = do
  start <- getClockTime
  putStrLn $ show start
  udlf <- getLine
  limitstr <- getLine
  readPuzzles (read limitstr) 1
  end <- getClockTime
  putStrLn $ show $ diffClockTimes end start

readPuzzles limit count = do
  wid <- getNum
  hig <- getNum
  puz <- getLine
  if wid + hig <= 9
  -- if wid <= 3 && hig <= 3
    then do
      nam <- return ("ans" ++ show count)
      exist <- doesFileExist nam
      if exist
	then return ()
        else do
	  putStrLn nam
	  (moves, ccount) <- return $ solve (wid, hig) $ readTable wid puz
          appendFile ("ans" ++ show count) $ moves2str $ moves
	  putStrLn $ show ccount
    else do
      return ()
  if count == limit
    then return ()
    else readPuzzles limit (count + 1)

getNum = do
  str <- getNumStr
  return $ read str

getNumStr = do
  c <- getChar
  if c == ','
    then return ""
    else do
      l <- getNumStr
      return (c:l)

readTable width tstr = (take0, dropwall)
  where 
    take0 = snd $ head $ filter isZeroPanel panels
    isZeroPanel (val, _) = val == 0
    dropwall = filter isNomalPanel panels
    isNomalPanel (val, _) = val > 0
    panels = map mkPanel $ zip tstr [0..]
    mkPanel (ch, ipos) = (char2id ch, (ipos `mod` width, ipos `div` width))

char2id ch = (length $ takeWhile ((/=) ch) "=0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ") - 1

moves2str :: [[Move]] -> String
moves2str mss = unlines $ map (map move2char) mss

move2char :: Move -> Char
move2char Left  = 'L'
move2char Right = 'R'
move2char Up    = 'U'
move2char Down  = 'D'



type Pos = (Int, Int)
type Panel = (Int, Pos)
type Table = (Pos, [Panel])
type Size = (Int, Int)
data Move = Left | Right | Up | Down
  deriving (Show, Eq)
data CanMove = None | Can Move
  deriving (Show, Eq)
type Solution = ((Table, Integer), [Move])
type SolveState = ([Integer], [Solution], [Solution])
giveup = 200
toprank = 30

canmove :: Pos -> Pos -> CanMove
canmove (x0, y0) (x1, y1)
  | x0 - 1 == x1 && y0 == y1 = Can Left
  | x0 + 1 == x1 && y0 == y1 = Can Right
  | x0 == x1 && y0 - 1 == y1 = Can Up
  | x0 == x1 && y0 + 1 == y1 = Can Down
  | otherwise                = None

filtpanel :: Table -> [(Move, Panel)]
filtpanel (_, []) = []
filtpanel (pos, (p:ps))
  | cm p == Can Left  = (Left , p) : nr
  | cm p == Can Right = (Right, p) : nr
  | cm p == Can Up    = (Up   , p) : nr
  | cm p == Can Down  = (Down , p) : nr
  | cm p == None  = nr
  where
    cm (_, posn) = canmove pos posn
    nr = filtpanel (pos, ps)

move :: Table -> Panel -> Table
move (zpos, panels) (tch, tpos) = (tpos, exchange panels (tch, zpos))

exchange :: [Panel] -> Panel -> [Panel]
exchange ps target = map changeone ps
  where
    changeone org
      | fst org == fst target = target
      | otherwise = org

solve :: Size -> Table -> ([[Move]], Integer)
solve size inittable = (map reverse $ fst resultsolve, snd resultsolve)
  where
    goalhash = makeGoalHash size inittable
    resultsolve = solve2 0 goalhash size ([], [((inittable, makeHash size inittable), [])], [])

solve2 :: Integer -> Integer -> Size -> SolveState -> ([[Move]], Integer)
solve2 count goalhash size (hashes, ss, ss0)
  | count > giveup = ([], count)
  | restsolve == 0 = ([], count)
  | getgoals == [] = solve2 (count + 1) goalhash size nextsolvestate
  | otherwise      = (getgoals, count)
  where
    restsolve = length (ss ++ ss0)
    getgoals = snd $ unzip $ filter (\((_, h), _) -> h == goalhash) ss
    nextsolvestate = (nexthashes, newsolutions, waitedsolutions)
    nexthashes = hashes ++ (snd $ unzip $ fst $ unzip ss)
    newsolutions = makenext size nexthashes $ take toprank sortedsolutions
    waitedsolutions = drop toprank sortedsolutions
    sortedsolutions = sortbyrank size (ss ++ ss0)

makeGoalHash :: Size -> Table -> Integer
makeGoalHash size (_, ps) = sum $ map (goalhashval size) ps

goalhashval :: Size -> (Int, Pos) -> Integer
goalhashval size (val, _) = (toInteger mulsize ^ val * (toInteger val))
  where
    mulsize = fst size * snd size

makeHash :: Size -> Table -> Integer
makeHash size (_, ps) = sum $ map (hashval size) ps

hashval :: Size -> (Int, Pos) -> Integer
hashval size (val, pos) = (toInteger mulsize ^ val * (toInteger $ getGoalValue size pos))
  where
    mulsize = fst size * snd size

sortbyrank :: Size -> [Solution] -> [Solution]
sortbyrank size ss = snd $ unzip $ qsort $ map withrank ss
  where
    withrank s = (ranktable size $ fst $ fst s, s)

qsort [] = []
qsort (x:xs) = qsort smaller ++ [x] ++ qsort larger
  where
    smaller = [a | a <- xs, fst a <= fst x]
    larger  = [b | b <- xs, fst b >  fst x]

ranktable :: Size -> Table -> Int
ranktable size (_, ts) = foldr (distance size) 0 ts

distance :: Size -> Panel -> Int -> Int
distance (w, h) (val, (x, y)) sum = sum + abs((val - 1) `mod` w - x) + abs((val - 1) `div` w - y)

getGoalValue :: Size -> Pos -> Int
getGoalValue (w, _) (x, y) = x + y * w + 1

makenext :: Size -> [Integer] -> [Solution] -> [Solution]
makenext size hashes ss = concatMap (\((t, h), ms) -> makeonenext size hashes (t, ms)) ss

makeonenext :: Size -> [Integer] -> (Table, [Move]) -> [Solution]
makeonenext size hashes (table, moves) = filter (\((_, h), _) -> not $ loopsolution hashes h) $ map process $ filtpanel table
  where
    process (m, p) = ((nexttable, makeHash size nexttable), m : moves)
      where
        nexttable = move table p

loopsolution :: [Integer] -> Integer -> Bool
loopsolution hashes newhash = any ((==) newhash) $ hashes 

Haskellで解きました。

• まずは幅優先の総当り（大きいパズルでは全然）
• ゴールへの近さを定義して、近いものから優先して解く
• ハッシュを計算して盤の比較
• 解けた問題の解答はファイルに保存して2度解かないようにする
• 時間がかかったらギブアップして次の問題へ行く

てな感じで上記のコードになりました。
反省点

• 解く速さにこだわってしまい、本格的に計算を始めるのが遅れた
• そのせいで時間切れ
• ギブアップなど、早く解くこと以外に力を入れ解ける問題をさっさと済ませればよかった
• あんま関数型っぽく解けなかった気がする
• データ型を木構造にするなどもうちょっと凝れば、効率もが上がったかもしれない

なんとなく自分の仕事のやり方の問題点も顕になってしまった気もする。
自分の仕事のやり方を見直す意味でもこういう機会はちょくちょく作りたい。