{-# LANGUAGE RecordPuns, ParallelListComp, PatternGuards #-}
{-# OPTIONS -fno-warn-name-shadowing #-}

module Text.PageIO.Transform where
import Data.Maybe
import Data.Monoid
import Data.Char (isDigit)
import Data.Function (on)
import Data.List (find, inits, tails, sortBy, groupBy)
import Text.Printf
import qualified Text.PageIO.LabelMap as LM
import qualified Data.ByteString.Char8 as S

import Text.PageIO.Types
import Text.PageIO.Extract (extractPage, SheetResult(..), BlockResult(..), Area)

type Doc = [Page]

type ValueMap = LabelMap [Value]
data AppliedVariable = MkAppliedVariable
    { avRow     :: Row
    , avCol     :: Col
    , avValue   :: Value
    }
    deriving (Show, Eq, Ord)

data Slot = MkSlot
    { slotSize      :: Row
    , slotBlocks    :: [Label]
    }
    deriving (Eq, Ord, Show)

type Ordered a = ([OrderBy (Maybe Value)], a)

data BlockData = MkBlockData
    { dataSize      :: Row
    , dataAreas     :: [Ordered Area]
    }
    deriving (Eq, Ord, Show)

instance Monoid BlockData where
    mempty = MkBlockData (error "impossible") []
    mappend x y = x{ dataAreas = dataAreas x ++ dataAreas y }
    mconcat []  = mempty
    mconcat xs  = MkBlockData
        { dataSize  = dataSize (head xs)
        , dataAreas = concatMap dataAreas xs
        }

type PageCapacity = [Slot]
type FitAttempt = LabelMap BlockData

-- The actual data bound to that area.
type PageBinding = LabelMap [Area]

-- Turn a list of page into pages grouped by results
transformPages :: Sheet -> [Page] -> [Doc]
transformPages sheet pages = map (makeDoc sheet) docGroups
    where
    docGroups = case sheetGroupBy sheet of
        []      -> [resultAndPages]
        lbls    -> groupBy ((==) `on` docKeys) resultAndPages
            where
            docKeys (res, _) = map (`LM.lookup` resultFields res) lbls
    resultAndPages = 
        [ (res, page)
        | Just res  <- map (extractPage sheet) pages
        | page      <- pages
        ]

-- Using Sheet+Page as template to rewrite a page
-- First, rewrite SheetResult to eliminate all Variable fields
-- Next, populate all fields
-- Finally, populate frames with blocks and space-ify the rest of the frame lines
--
-- First try fitting everything on the last page.
-- All frames must be consumed by blocks mentioned on that page.
-- If it won't fit, then retry with the last two pages, etc.
--
-- Oh, and we re-extract the result pages to fill in vars! What joy!
--
-- XXX - If data would expand, then maybe repeat the first page indefinitely?
--
makeDoc :: Sheet -> [(SheetResult, Page)] -> Doc
makeDoc sheet resultAndPages = case find (isJust . fst) pageBindings of
    Just (Just bindings, boundPages) -> fillVariables sheet
        [ makePage sheet b p
        | b <- bindings
        | p <- boundPages
        ]
    _  -> error "Impossible - cannot bind?"
    where
    results             = map fst resultAndPages
    pages               = map snd resultAndPages
    orders              = sheetBlockOrderBys sheet
    (capacity, attempt) = foldr (doResult sheet orders) ([], mempty) results 
    capacityTails       = repeatTails capacity
    pageTails           = repeatTails pages
    pageBindings        = 
        [ (tryFit pc sortedAttempt, pages)
        | pc    <- capacityTails
        | pages <- pageTails
        ]
    sortedAttempt       = fmap (\dat -> dat{ dataAreas = sortBy (compare `on` fst) $ dataAreas dat }) attempt

-- Given "abc", generate ["", "c", "bc", "abc", "aabc", "aaabc", "aaaabc"...]
repeatTails :: [a] -> [[a]]
repeatTails [] = []
repeatTails orig@(x:xs) = reverse (tails xs) ++ map (++ orig) infinitePrefixes
    where
    infinitePrefixes = inits (repeat x)

-- We now calculate the applied vars for each page
fillVariables :: Sheet -> Doc -> Doc
fillVariables sheet pages =
    [ fillPageVariables appliedVars p
    | p             <- pages
    | appliedVars   <- map applyVariable ([1..] `zip` valueMaps)
    ]
    where
    vars        = sheetVariableFields sheet
    valueMaps   = map makeValueMap results
    docVals     = LM.unionsWith (++) valueMaps
    results     = map (maybe (error "Roundtrip failed!") id . extractPage sheet) pages
    applyVariable :: (Int, ValueMap) -> LabelMap AppliedVariable
    applyVariable (pageNum, pageVals) = LM.mapMaybeWithKey applyOneVariable vars
        where
        applyOneVariable :: Label -> Field -> Maybe AppliedVariable
        applyOneVariable lbl MkField{ fieldBox, fieldVariable }
            | Just var <- fieldVariable
            , LM.member lbl pageVals  = Just MkAppliedVariable
                { avRow     = boxTop fieldBox
                , avCol     = boxLeft fieldBox
                , avValue   = getVar var
                }
            | otherwise                 = Nothing
            where
            len = boxRight fieldBox - boxLeft fieldBox + 1
            valOf :: Scope -> Label -> [Value]
            valOf scope lbl = maybe [] id $ LM.lookup lbl vals
                where
                vals = case scope of
                    SDoc    -> docVals
                    SPage   -> pageVals
            getVar VPage                = formatNumber pageNum
            getVar (VSum scope label)   = formatDotted $ sum (map parseVal $ valOf scope label)
            getVar (VCount scope label) = formatNumber $ length (valOf scope label)
            getVar (VLiteral lit)       = lit `S.append` S.replicate (len - S.length lit) ' '
            formatNumber = S.pack . printf ("%" ++ show len ++ "d")
            formatDotted n = S.pack $ (replicate pad ' ') ++ dottedStr ++ ".00"
                where
                pad         = len - length dottedStr - 3
                str         = show n
                dottedStr   = reverse (addDot $ reverse str)
                addDot (x:y:z:rest@(_:_))   = (x:y:z:',':addDot rest)
                addDot xs                   = xs
            parseVal :: Value -> Int
            parseVal val = case S.readInt (S.filter isDigit (S.takeWhile (/= '.') val)) of
                Just (num, _)   -> num
                _               -> 0

makeValueMap :: SheetResult -> ValueMap
makeValueMap MkSheetResult{ resultFields, resultBlocks } = LM.unionsWith (++) (fieldMap:blockMaps)
    where
    fieldMap  = fmap (:[]) resultFields
    blockMaps :: [ValueMap]
    blockMaps = map makeBlockValueMap $ LM.elems resultBlocks
    makeBlockValueMap :: BlockResult -> ValueMap
    makeBlockValueMap (MkBlockResult avs) = LM.unionsWith (++) maps
        where
        maps :: [LabelMap [Value]]
        maps = map (fmap (:[]) . snd) avs

-- Now comes the fun part.
-- For each frame, see if any of its blocks are there.
-- If yes, concat them and pain the rest white.
makePage :: Sheet -> PageBinding -> Page -> Page
makePage MkSheet{ sheetFrames } binding page = foldl makeFrame page sheetFrames
    where
    makeFrame page MkFrame{ frameBox, frameBlocks }
        | null frameBindings = page
        | otherwise          = pageReplaced
        where
        pageCleared   = clearArea frameBox page
        pageReplaced  = replaceArea frameBox (concat frameBindings) pageCleared
        frameBindings = 
            [ fromJust result
            | frameLabel <- LM.keys frameBlocks
            , let result = LM.lookup frameLabel binding
            , isJust result
            ]

-- Start with 
replaceArea :: Box -> [Area] -> Page -> Page
replaceArea _ [] page = page
replaceArea box@MkBox{ boxTop, boxLeft } (area:rest) page = replaceArea box' rest page'
    where
    box'  = box{ boxTop = boxTop + areaRows area}
    page' = fillArea boxTop boxLeft area page

clearArea :: Box -> Page -> Page
clearArea MkBox{ boxTop, boxLeft, boxBottom, boxRight } (MkPage lns) = MkPage $ before ++ cleared ++ after
    where
    (before, rest)  = splitAt (boxTop-1) lns
    (middle, after) = splitAt (boxBottom-boxTop+1) rest
    cleared         = map (fillLine boxLeft . ((,) whiteSpace)) middle
    whiteSpace      = S.replicate (boxRight-boxLeft+1) ' '

{-# INLINE fillArea #-}
fillArea :: Row -> Col -> Area -> Page -> Page
fillArea row col (MkPage areaLines) (MkPage lns) = MkPage $ before ++ replaced ++ after
    where
    (before, rest)  = splitAt (row-1) lns
    (middle, after) = splitAt (length areaLines) rest
    replaced        = map (fillLine col) (areaLines `zip` middle)

{-# INLINE fillLine #-}
fillLine :: Col -> (Value, Value) -> Value
fillLine col (areaLine, origLine) = S.concat [before, areaLine, after]
    where
    origLinePadded
        | padLength <= 0    = origLine
        | otherwise         = origLine `S.append` S.replicate padLength ' ' 
    padLength       = S.length origLine - (col + areaLength - 1)
    (before, rest)  = S.splitAt (col-1) origLinePadded
    after           = S.drop areaLength rest
    areaLength      = S.length areaLine

doResult :: Sheet -> LabelMap [OrderBy Label] -> SheetResult -> ([PageCapacity], FitAttempt)
            -> ([PageCapacity], FitAttempt)
doResult MkSheet{ sheetFrames } orders MkSheetResult{ resultBlocks } (pcs, att) = (pc:pcs, att')
    where
    pc              = map frameToSlot framesOccured
    framesOccured   = filter (labelOccured . frameBlocks) sheetFrames
    labelOccured lm = any (`LM.member` lm) resultLabels
    resultLabels    = LM.keys resultBlocks
    att'            = LM.unionsWith mappend [att, LM.mapMaybeWithKey blockToData resultBlocks]
    blockToData lbl (MkBlockResult lms) = case areas of 
        []              -> Nothing
        ((_, area):_)   -> Just MkBlockData
            { dataSize  = areaRows area
            , dataAreas = areas
            }
        where
        orderFrom = case LM.lookup lbl orders of
            Just orderBys   -> \vals -> map (fmap (`LM.lookup` vals)) orderBys
            Nothing         -> const []
        areas = [ (orderFrom vals, area) | (area, vals) <- lms ]
    frameToSlot MkFrame{ frameBox, frameBlocks } = MkSlot
        { slotSize   = boxBottom frameBox - boxTop frameBox + 1
        , slotBlocks = LM.keys frameBlocks
        }

areaRows :: Area -> Row
areaRows (MkPage lns) = length lns

fillPageVariables :: LabelMap AppliedVariable -> Page -> Page
fillPageVariables avs page = foldl fillOneVar page (LM.elems avs)
    where
    fillOneVar page MkAppliedVariable{ avRow, avCol, avValue }
        = fillArea avRow avCol (valueToArea avValue) page

valueToArea :: Value -> Area
valueToArea val = MkPage [val]

sheetVariableFields :: Sheet -> LabelMap Field
sheetVariableFields MkSheet{ sheetFrames, sheetFields } = LM.unions filteredMaps
    where
    filteredMaps = map (LM.filter (isJust . fieldVariable)) fieldMaps
    fieldMaps = sheetFields : concatMap frameVariableFields sheetFrames
    frameVariableFields frame@MkFrame{ frameBox } = map blockVariableFields blocks
        where
        blocks    = LM.elems (frameBlocks frame)
        rowOffset = boxTop frameBox - 1
        colOffset = boxLeft frameBox - 1
        blockVariableFields = fmap adjustField . blockFields
        adjustField field@MkField{ fieldBox = MkBox{ boxTop, boxLeft, boxBottom, boxRight } } = field
            { fieldBox = MkBox
                { boxTop    = boxTop      + rowOffset
                , boxLeft   = boxLeft     + colOffset
                , boxBottom = boxBottom   + rowOffset
                , boxRight  = boxRight    + colOffset
                }
            }

sheetBlockOrderBys :: Sheet -> LabelMap [OrderBy Label]
sheetBlockOrderBys MkSheet{ sheetFrames } = LM.unions (map frameBlockOrderBys sheetFrames)
    where
    frameBlockOrderBys MkFrame{ frameBlocks } = LM.fromList
        [ (lbl, order) | (lbl, order@(_:_)) <- LM.toList (fmap blockOrderBy frameBlocks) ]

-- Each try is on a list of Frame Capacities
-- Each frame capacity is a number of rows, and the label of blocks it can consume
-- We try it with the total number of blocks

tryFit :: [PageCapacity] -> FitAttempt -> Maybe [PageBinding]
tryFit pcs att = go pcs ([], att)
    where
    go []     (bindings, att)
        | all (null . dataAreas) (LM.elems att) = Just (reverse bindings)
        | otherwise                             = Nothing
    go (p:ps) (bindings, att) = go ps ((bnd:bindings), att')
        where
        (bnd, att') = fitOnePage p (mempty, att)

fitOnePage :: [Slot] -> (PageBinding, FitAttempt) -> (PageBinding, FitAttempt)
fitOnePage [] x     = x
fitOnePage (s:ss) x = fitOnePage ss $ fitOneSlot s x

fitOneSlot :: Slot -> (PageBinding, FitAttempt) -> (PageBinding, FitAttempt)
fitOneSlot slot@MkSlot{ slotSize, slotBlocks } x@(binding, att) = case slotBlocks of
    []      -> x
    (b:bs)  -> case LM.lookup b att of
        Just dat@MkBlockData{ dataSize, dataAreas } ->
            let consumed     = min (length dataAreas) (slotSize `div` dataSize)
                consumedSize = consumed * dataSize
                newData      = dat{ dataAreas = drop consumed dataAreas }
                newAttempt   = LM.insert b newData att
                newBinding   = LM.insertWith (++) b (map snd $ take consumed dataAreas) binding
                newSlot      = slot
                    { slotSize   = slotSize - consumedSize
                    , slotBlocks = bs
                    }
             in fitOneSlot newSlot (newBinding, newAttempt)
        _   -> fitOneSlot slot{ slotBlocks = bs } x