第7回オフラインリアルタイムどう書く。Haskellでの実装

すっきり書けるような気がしてたのに超絶ごちゃごちゃに。

問題: http://nabetani.sakura.ne.jp/hena/ord7selectchair/
解答リンク集: http://qiita.com/items/4364285801d1c9f370a1

nonbiri.hs

-- のんびり問題
-- http://nabetani.sakura.ne.jp/hena/ord7selectchair/

import Data.List
import Data.List.Split
import Data.Char

data Chair = Chair{number :: Int, shittingMan :: Char}
           | Empty {number :: Int}
           | NoChair deriving(Show,Eq)

type Prior = Int
type CandidateChair =  (Prior , Chair)

inputs = ("6:NABEbBZn","-ZAB-E")
  : ("1:A","A")
  : ("1:Aa","-")
  : ("2:AB","AB")
  : ("2:AaB","B-")
  : ("2:AZa","-Z")
  : ("2:AZz","A-")
  : ("3:ABC","ACB")
  : ("3:ABCa","-CB")
  : ("4:ABCD","ADBC")
  : ("4:ABCbBD","ABDC")
  : ("4:ABCDabcA","-D-A")
  : ("5:NEXUS","NUESX")
  : ("5:ZYQMyqY","ZM-Y-")
  : ("5:ABCDbdXYc","AYX--")
  : ("6:FUTSAL","FAULTS")
  : ("6:ABCDEbcBC","AECB-D")
  : ("7:FMTOWNS","FWMNTSO")
  : ("7:ABCDEFGabcdfXYZ","YE-X-GZ")
  : ("10:ABCDEFGHIJ","AGBHCIDJEF")
  : []

main = putStrLn $ foldr (++) "" (map showSimulate inputs)

  where showSimulate (i, e) =  "i -> "++ i ++ "\n"
                                      ++ "  e -> " ++ e ++ "\n"
                                      ++ "  a -> " ++ solve (fst $ parse i) (snd $ parse i) ++ "\n"
        parse :: String -> (Int , String)
        parse s = (read $ head sp, sp!!1)
          where sp = splitOn ":" s

initChairs :: Int -> [Chair]
initChairs num = NoChair : (take num $ map (\x -> Empty x ) [1..]) ++ [NoChair]

showChairState :: [Chair] -> String
showChairState  = foldr f ""
    where f NoChair acc = acc
          f (Empty _) acc = '-' : acc
          f (Chair _ name) acc = name : acc

solve num messages = showChairState $ simulate messages $ initChairs num

simulate :: String -> [Chair] ->[Chair]
simulate [] cs =  cs
simulate messages cs = simulate (tail messages) (shitOrGo $ head messages)
    where
           shitOrGo :: Char -> [Chair]
           shitOrGo m
            | isUpper m = shit m (choiceChairToShit $ findCandidates (head cs) (tail cs) [] ) cs
            | otherwise = goaway (toUpper m) cs

shit ::  Char -> Chair -> [Chair] -> [Chair]
shit _ _ []=  []
shit _ NoChair cs = cs
shit manName to cs =
        case head cs of
            NoChair -> head cs : shit manName to (tail cs)
            otherwise -> (shitOrNot $ head cs) : shit  manName to (tail cs)
                where shitOrNot c @ (Empty n)  = if n == (number to) then Chair n manName else c
                      shitOrNot c = c

goaway :: Char -> [Chair] -> [Chair]
goaway _ [] = []
goaway manName  cs =
        case head cs of
            NoChair -> head cs : goaway manName (tail cs)
            otherwise -> (goOrNot $ head cs) : goaway  manName (tail cs)
                where goOrNot c @ (Chair n name)  = if manName == name then Empty n else c
                      goOrNot c = c

choiceChairToShit :: [CandidateChair] -> Chair
choiceChairToShit [] = NoChair
choiceChairToShit css = snd $ head $ sortBy sortByPriority css

sortByPriority :: CandidateChair -> CandidateChair -> Ordering
sortByPriority (p1, Empty n1 ) (p2,Empty n2 )
    | p1 < p2 = LT
    | p1 > p2 = GT
    | p1 == p2 = if n1 < n2 then LT else GT

findCandidates :: Chair -> [Chair] ->  [CandidateChair] -> [CandidateChair]

findCandidates _ [] cas  = cas
findCandidates _ [NoChair] cas  = cas

findCandidates l cs cas
    | isAllEmpty $ l : take 2 cs =  findCandidates' cs $ (1, cand) : cas
    | isAllEmpty  [l , cand] = findCandidates' cs $ (2, cand) : cas
    | isAllEmpty $ take 2 cs = findCandidates' cs $ (2, cand) : cas
    | isEmpty  cand = findCandidates' cs $ (3, cand) : cas
    | otherwise = findCandidates' cs cas
    where cand = head cs
          findCandidates' cs' = findCandidates (head cs') (tail cs')

isAllEmpty :: [Chair] -> Bool
isAllEmpty = all isEmpty

isEmpty :: Chair -> Bool
isEmpty (Empty _)  =  True
isEmpty (Chair _ _) =  False
isEmpty NoChair = True