content: import Data.Maybe
  import Data.List
  import Control.Monad.State
  import qualified Data.Map as M
  import Text.Printf
  
  ------------------------------------------------------------
  -- Primitive graph representation
  
  type Node = Int
  type Color = Int
  type Graph = M.Map Node [Node]
  
  nodes :: Graph -> [Node]
  nodes = M.keys
  
  adjacentNodes :: Graph -> Node -> [Node]
  adjacentNodes g n = fromMaybe [] $ M.lookup n g
  
  degree :: Graph -> Node -> Int
  degree g = length . adjacentNodes g
  
  fromList :: [(Node, [Node])] -> Graph
  fromList  = foldr add M.empty
    where
      add (a, bs) g = foldr (join [a]) (join bs a g) bs
      join = flip (M.insertWith (++))
  
  readGraph :: String -> Graph
  readGraph = fromList . map interprete . words
    where
      interprete s = case span (/= '-') s of
        (a, "") -> (read a, [])
        (a, '-':b) -> (read a, [read b])
  
  ------------------------------------------------------------
  -- Graph coloring functions
  
  uncolored :: Node -> State [(Node, Color)] Bool
  uncolored n = isNothing <$> colorOf n
  
  colorOf :: Node -> State [(Node, Color)] (Maybe Color)
  colorOf n = gets (lookup n)
  
  greedyColoring :: Graph -> [(Node, Color)]
  greedyColoring g = mapM_ go (nodes g) `execState` []
    where
      go n = do
        c <- colorOf n
        when (isNothing c) $ do
          adjacentColors <- nub . catMaybes <$> mapM colorOf (adjacentNodes g n)
          let newColor = head $ filter (`notElem` adjacentColors) [1..]
          modify ((n, newColor) :)
        filterM uncolored (adjacentNodes g n) >>= mapM_ go
  
  wpColoring :: Graph -> [(Node, Color)]
  wpColoring g = go [1..] nodesList `execState` []
    where
      nodesList = sortOn (negate . degree g) (nodes g)
  
      go _ [] = pure ()
      go (c:cs) ns = do
        mark c ns
        filterM uncolored ns >>= go cs
  
      mark c [] = pure () :: State [(Node, Color)] ()
      mark c (n:ns) = do
        modify ((n, c) :)
        mark c (filter (`notElem` adjacentNodes g n) ns)
  