snake.hs

import Control.Monad
import Data.List

-- type synonyms for convenience
type Board     = (Int, Int)
type Pos       = (Int, Int)
type Obstacle  = Pos
type Path      = [Pos]

---------- DIRTY INPUT FUNCTIONS ----------
main = do
    board     <- liftM read2Ints getLine     -- get board dimensions
    obstacleN <- liftM readInt getLine       -- get number of obstacles
    obstacles <- readObstacles obstacleN     -- read said number of obstacles
    mapM_ putStrLn $ snakeIt board obstacles -- print results of snakeIt

-- read x number of obstacles (that is, if x was properly read)
readObstacles :: Maybe Int -> IO (Maybe [Obstacle])
readObstacles Nothing  = return Nothing -- readInts must have returned []
readObstacles (Just x) = do
    obstacleStrs <- sequence $ replicate x getLine -- get x lines
    return $ mapM read2Ints obstacleStrs           -- read Int pairs
---------- PURE FUNCTIONS ----------

-- read Ints from string 
-- the list will list the numbers in reverse order from how
-- they appeared in the input string, blame the : operator
readInts :: Int -> String -> [Int]
readInts n str = take n $ go (reads str) []
    where go []         acc = acc -- done reading
          -- if we got x, put in the accumulator and keep reading
          go [(x,str')] acc = go (reads str') (x:acc)

-- read 2 Ints from string
read2Ints :: String -> Maybe (Int, Int)
read2Ints str = case readInts 2 str of [x,y] -> Just (y,x) -- exactly 2
                                       _     -> Nothing    -- less than 2
-- read 1 int from string
readInt :: String -> Maybe Int
readInt str = case readInts 1 str of [x] -> Just x  -- exactly 1
                                     _   -> Nothing -- none found

-- turn a Path into a list of Strings in the format: "x y"
showPath :: Path -> [String]
showPath = map showPos . reverse -- undo : reversal from getPaths
    where showPos (x,y) = (show x) ++ " " ++ (show y)

-- compare the size of 2 lists, pretty simple
listSize :: [a] -> [a] -> Ordering
listSize xs ys = compare (length xs) (length ys)

-- here's where the magic starts
snakeIt :: Maybe Board -> Maybe [Obstacle] -> [String]
snakeIt Nothing _ = ["Parse failure"]
snakeIt _ Nothing = ["Parse failure"]
snakeIt (Just board@(w,h)) (Just os)
    | sane board os =
            -- number of available tiles
        let full          = w * h - (length os)
            -- find the longest solution (reverse because we want the longest)
            getBestPath   = head . reverse . sortBy listSize
            path          = getBestPath $ getPaths board os
            -- make a string showing how successful we were
            fillStr       = (show $ length path) ++ " / " ++ (show full)
            -- first the fillStr then a list of movements
        in fillStr : showPath path
    | otherwise     = ["You've got some bad data, bro."]

-- make sure board and obstacles are sane
sane :: Board -> [Obstacle] -> Bool
sane (w,h) os
    | (w < 1) || (h < 1) = False -- can't have a negative board
    | any outOfRange os  = False -- make sure obstacles are on board
    | otherwise          = True  -- hooray! it's sane!
    where outOfRange (x,y) = or [x<0, y<0, x>=w, y>=h]

-- here's where the magic happens
-- again, the first move is going to be at the end of the list
-- damn that : operator
getPaths :: Board -> [Obstacle] -> [Path]
getPaths (w,h) os = move [(0,0)] -- starting point
    where move p@((x,y):t) =
                                -- left     right    down     up
              let moves         = [(x+1,y), (x-1,y), (x,y+1), (x,y-1)]
                  -- obstacles and snake's tail block the path
                  blocked       = os ++ t
                  -- make sure it's on board and not blocked
                  valid (x',y') = and [x'>=0, y'>=0, x'<w, y'<h
                                      ,(x',y') `notElem` blocked]
                  validMoves    = filter valid moves
                  -- find new paths based on validMoves
                  ps            = map (:p) validMoves
              in if null validMoves then [p]               -- dead end
                                    else concatMap move ps -- keep recursing