import Control.Monad
import Data.Array.Base
import Data.Binary.Put
import qualified Data.ByteString.Lazy as BS
import Data.Char
import Data.List
import Data.Ord
import Data.Maybe
import Text.Regex.Posix
import Text.Regex.Posix.String ()

import AcrossLite

parseExtents :: String -> [(Int, (Int, Int, Int))]
parseExtents = map munge . (=~ "([0-9]+),([A-Z])([0-9]+),([0-9]+);")
    where munge [_, a, [b], c, d] =
              (read a, (read c - 1, fromEnum b - fromEnum 'A', read d))

unescape [] = []
unescape ('\\':'\'':xs) = '\'' : unescape xs
unescape (x:xs) = x : unescape xs

parseParams :: String -> [(String, String)]
parseParams = map munge . (=~ "<param name=\"([^\"]+)\" value=\"([^\"]*)\"")
    where munge = (\[_, name, value] -> (name, unescape value))

parseClues :: [(String, String)] -> ([String], [String])
parseClues params = (map snd . filter ((== 1) . fst) $ clues,
                     map snd . filter ((== 0) . fst) $ clues)
    where clues :: [(Int, String)]
          clues = map (munge . drop 2 . concat . (=~ "[^|]+") . snd) .
                     filter (\(n, v) -> "clue" `isPrefixOf` n) $ params
          munge [a, b, c, d] = (read a, c ++ " (" ++ d ++ ")")
          munge [a, b, c] = (read a, c)
          munge x = error (show x)

parseHTML h = fromJust $ do
    let params = parseParams h
    width <- read `fmap` lookup "gridwidth" params
    height <- read `fmap` lookup "gridheight" params
    acrossExts <- parseExtents `fmap` lookup "across" params
    downExts <- parseExtents `fmap` lookup "down" params
    solutions <- lookup "solutions" params
    let (acrossClues, downClues) = parseClues params
    let z (n, (x, y, l)) c = (n, (x, y, l, c))
    let across = zipWith z acrossExts acrossClues
    let down   = zipWith z downExts downClues
    return (width, height, across, down, solutions)

flipGrid a = let (_, (bx, by)) = bounds a in
                 [a ! (y, x) | y <- [0..by], x <- [0..bx]]

formatGrid g = unlines (map formatRow rows)
    where (_, (w, h)) = bounds g
          rows = [[g ! (y, x) | x <- [0..w]] | y <- [0..h]]
          formatRow = (' ':) . intersperse ' '

fillSolutions :: UArray (Int, Int) Char -> String -> UArray (Int, Int) Char
fillSolutions grid solutions = listArray (bounds grid) $
                                   fill (flipGrid grid) solutions
    where fill _ [] = repeat '.'
          fill ('-':xs) (y:ys) = toUpper y : fill xs ys
          fill ('.':xs)    ys  =       '.' : fill xs ys

packStr = BS.pack . map (fromIntegral . fromEnum)

main = do
    contents <- getContents
    let (width, height, across, down, solutions) = parseHTML contents
    let grid = listArray ((0, 0), (height - 1, width - 1)) (repeat '.')
                   // [((y, x+i), '-') |
                       (_, (x, y, len, _)) <- across, i <- [0..len-1]]
                   // [((y+i, x), '-') |
                       (_, (x, y, len, _)) <- down, i <- [0..len-1]]
    let solved = fillSolutions grid solutions
    let clues = map (\(x, y, l, c) -> c) .
                sortBy (comparing (\(x, y, l, c) -> (y, x))) $
                    map snd (across ++ down)
    BS.putStr $ runPut $ putAcrossLite $
        Crossword (packStr "title") (packStr "author") (packStr "copyright")
            width height (map packStr clues)
            (packStr $ flipGrid solved) (packStr $ flipGrid grid)