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
type PageBinding = LabelMap [Area]
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
]
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
repeatTails :: [a] -> [[a]]
repeatTails [] = []
repeatTails orig@(x:xs) = reverse (tails xs) ++ map (++ orig) infinitePrefixes
where
infinitePrefixes = inits (repeat x)
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
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
]
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 (boxTop1) lns
(middle, after) = splitAt (boxBottomboxTop+1) rest
cleared = map (fillLine boxLeft . ((,) whiteSpace)) middle
whiteSpace = S.replicate (boxRightboxLeft+1) ' '
fillArea :: Row -> Col -> Area -> Page -> Page
fillArea row col (MkPage areaLines) (MkPage lns) = MkPage $ before ++ replaced ++ after
where
(before, rest) = splitAt (row1) lns
(middle, after) = splitAt (length areaLines) rest
replaced = map (fillLine col) (areaLines `zip` middle)
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 (col1) 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) ]
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