{-# LANGUAGE OverloadedStrings, RecordWildCards #-}
module Graphics.Layout(LayoutItem(..),
        layoutGetBox, layoutGetChilds, layoutGetInner,
        boxMinWidth, boxMaxWidth, boxNatWidth, boxWidth,
        boxNatHeight, boxMinHeight, boxMaxHeight, boxHeight,
        boxSplit, boxPaginate, boxPosition, boxLayout, glyphsPerFont) where

import Data.Text.ParagraphLayout (Paragraph(..), ParagraphOptions(..), PageOptions(..), Fragment(..))

import Graphics.Layout.Box as B
import Graphics.Layout.Grid as G
import Graphics.Layout.Flow as F
import Graphics.Layout.Inline as I
import Graphics.Layout.CSS.Font (Font'(..))

import Data.Maybe (fromMaybe)

-- To gather glyphs for atlases.
import qualified Data.IntSet as IS
import qualified Data.Map.Strict as M
import qualified Data.Text.Glyphize as Hb
import Graphics.Text.Font.Choose (Pattern)

data LayoutItem m n x =
    LayoutFlow x (PaddedBox m n) [LayoutItem m n x]
    | LayoutGrid x (Grid m n) [(GridItem m n, LayoutItem m n x)]
    | LayoutInline x Font' Paragraph PageOptions [x] -- Balkon holds children.
    | LayoutSpan x Font' Fragment
-- More to come...

layoutGetBox :: (Zero m, Zero n, CastDouble m, CastDouble n) =>
        LayoutItem m n x -> PaddedBox m n
layoutGetBox (LayoutFlow _ ret _) = ret
layoutGetBox (LayoutGrid _ self _) = zero {
    B.min = containerMin self,
    B.size = containerSize self,
    B.max = containerMax self
}
layoutGetBox (LayoutInline _ f self _) = zero {
    B.min = inlineMin f self, B.size = inlineSize f self, B.max = inlineSize f self
}
layoutGetBox (LayoutSpan _ f self) = zero {
    B.min = fragmentSize f self, B.size = fragmentSize f self, B.max = fragmentSize f self
}
layoutGetChilds (LayoutFlow _ _ ret) = ret
layoutGetChilds (LayoutGrid _ _ ret) = map snd ret
layoutGetChilds (LayoutSpan _ _ _) = []
layoutGetChilds (LayoutInline _ font self _ vals) = map inner $ inlineChildren vals self
  where inner (val, fragment) = LayoutSpan val font fragment
layoutGetInner (LayoutFlow ret _ _) = ret
layoutGetInner (LayoutGrid ret _ _) = ret
layoutGetInner (LayoutInline ret _ _ _ _) = ret
layoutGetInner (LayoutSpan ret _ _) = ret

setCellBox' (child, cell) = cell { gridItemBox = layoutGetBox child }

boxMinWidth :: (Zero y, CastDouble y) =>
        Maybe Double -> LayoutItem y Length x -> LayoutItem y Length x
boxMinWidth parent (LayoutFlow val self childs) = LayoutFlow val self' childs'
  where
    self' = self { B.min = mapSizeX (B.mapAuto min') (B.min self) }
    min' = flowMinWidth parent' self childs''
    childs'' = map (mapX' $ lowerLength selfWidth) $ map layoutGetBox childs'
    childs' = map (boxMinWidth $ Just selfWidth) childs
    selfWidth = width $ mapX' (lowerLength parent') self
    parent' = fromMaybe 0 parent
boxMinWidth parent (LayoutGrid val self childs) = LayoutGrid val self' $ zip cells' childs'
  where
    self' = self {
        containerMin = Size (Pixels min') (block $ containerMin self),
        colBounds = zip cells (map snd (colBounds self) ++ repeat 0)
      }
    (min', cells) = gridMinWidths parent' self cells''
    cells'' = [ setCellBox (mapX' (lowerLength selfWidth) $ gridItemBox cell) cell
                | cell <- cells']
    cells' = map setCellBox' $ zip childs' $ map fst childs
    childs'' = map (mapX' $ lowerLength selfWidth) $ map layoutGetBox childs'
    childs' = map (boxMinWidth $ Just selfWidth) $ map snd childs
    selfWidth = lowerLength parent' $ inline $ containerSize self
    parent' = fromMaybe (gridEstWidth self [
        GridItem startRow endRow startCol endCol alignment zeroBox |
        (GridItem {..}, _) <- childs]) parent
    zeroBox :: PaddedBox Double Double
    zeroBox = zero
boxMinWidth _ self@(LayoutInline _ _ _ _) = self
boxMinWidth _ self@(LayoutSpan _ _ _) = self
boxNatWidth :: (Zero y, CastDouble y) =>
        Maybe Double -> LayoutItem y Length x -> LayoutItem y Length x
boxNatWidth parent (LayoutFlow val self childs) = LayoutFlow val self' childs'
  where
    self' = self { size = mapSizeX (B.mapAuto size') (size self) }
    size' = flowNatWidth parent' self childs''
    childs'' = map (mapX' $ lowerLength selfWidth) $ map layoutGetBox childs'
    childs' = map (boxNatWidth $ Just selfWidth) childs
    selfWidth = width $ mapX' (lowerLength parent') self
    parent' = fromMaybe 0 parent
boxNatWidth parent (LayoutGrid val self childs) = LayoutGrid val self' $ zip cells' childs'
  where
    self' = self {
        containerSize = Size (Pixels size') (block $ containerSize self),
        colBounds = zip (map fst (colBounds self) ++ repeat 0) cells
      }
    (size', cells) = gridNatWidths parent' self cells''
    cells'' = [
        cell { gridItemBox = mapX' (lowerLength selfWidth) $ gridItemBox cell }
        | cell <- cells']
    cells' = map setCellBox $ zip childs' $ map fst childs
    setCellBox (child, cell) = cell { gridItemBox = layoutGetBox child }
    childs'' = map (mapX' $ lowerLength selfWidth) $ map layoutGetBox childs'
    childs' = map (boxNatWidth $ Just selfWidth) $ map snd childs
    selfWidth = lowerLength parent' $ inline $ containerSize self
    parent' = fromMaybe (gridEstWidth self [
        GridItem startRow endRow startCol endCol alignment zeroBox |
        (GridItem {..}, _) <- childs]) parent
    zeroBox :: PaddedBox Double Double
    zeroBox = zero
boxNatWidth _ self@(LayoutInline _ _ _ _) = self
boxNatWidth _ self@(LayoutSpan _ _ _) = self
boxMaxWidth :: PaddedBox a Double -> LayoutItem y Length x -> LayoutItem y Length x
boxMaxWidth parent (LayoutFlow val self childs) = LayoutFlow val self' childs'
  where
    childs' = map (boxMaxWidth self'') childs
    self'' = mapX' (lowerLength $ inline $ B.size parent) self'
    self' = self { B.max = Size (Pixels max') (block $ B.max self) }
    max' = flowMaxWidth parent self
boxMaxWidth parent (LayoutGrid val self childs) = LayoutGrid val self' childs
  where
    self' = self { containerMax = Size (Pixels max') (block $ containerMax self) }
    (max', _) = gridMaxWidths parent self $ colBounds self
boxMaxWidth parent self@(LayoutInline _ _ _ _) = self
boxMaxWidth parent self@(LayoutSpan _ f self') = self
boxWidth :: (Zero y, CastDouble y) => PaddedBox b Double -> LayoutItem y Length x ->
        LayoutItem y Double x
boxWidth parent (LayoutFlow val self childs) = LayoutFlow val self' childs'
  where
    childs' = map (boxWidth self') childs
    self' = (mapX' (lowerLength $ inline $ size parent) self) {
        size = Size size' $ block $ B.max self
      }
    size' = flowWidth parent self
boxWidth parent (LayoutGrid val self childs) = LayoutGrid val self' childs'
  where
    childs' = map recurse childs
    recurse (cell, child) = (cell', child')
      where
        cell' = cell { gridItemBox = layoutGetBox child' }
        child' = boxWidth parent' child
        parent' = zero {
            B.min = containerMin self',
            B.size = containerSize self',
            B.max = containerMax self'
          }
    self' = Grid {
        containerSize = Size size' $ block $ containerSize self,
        containerMin = mapSizeX (lowerLength outerwidth) $ containerMin self,
        containerMax = mapSizeX (lowerLength outerwidth) $ containerMax self,
        gap = mapSizeX (lowerLength outerwidth) $ gap self,
        columns = map Left widths,

        rows = rows self,
        rowBounds = rowBounds self,
        colBounds = colBounds self,
        subgridRows = subgridRows self, subgridColumns = subgridColumns self
      }
    outerwidth = inline $ size parent
    (size', widths) = gridWidths parent self $ colBounds self
boxWidth parent (LayoutInline val font (Paragraph a b c d) vals) =
    LayoutInline val font (Paragraph a b c d { paragraphMaxWidth = round width }) vals
  where width = B.inline $ B.size parent
boxWidth parent (LayoutSpan val font self') = LayoutSpan val font self'

boxNatHeight :: Double -> LayoutItem Length Double x -> LayoutItem Length Double x
boxNatHeight parent (LayoutFlow val self childs) = LayoutFlow val self' childs'
  where
    self' = self { size = mapSizeY (mapAuto size') (size self) }
    size' = flowNatHeight parent self childs''
    childs'' = map (mapY' (lowerLength parent)) $ map layoutGetBox childs'
    childs' = map (boxNatHeight $ inline $ size self) childs
boxNatHeight parent (LayoutGrid val self childs) = LayoutGrid val self' $ zip cells childs'
  where
    self' = self {
        containerSize = Size width $ Pixels size'
    }
    lowerGridUnit (Left length) = Left $ lowerLength width length
    lowerGridUnit (Right x) = Right x
    (size', heights) = gridNatHeights parent self cells'
    cells' = [setCellBox (mapY' (lowerLength width) $ gridItemBox cell) cell | cell <- cells]
    cells = map setCellBox' $ zip childs' $ map fst childs
    childs' = map (boxNatHeight width) $ map snd childs
    width = inline $ containerSize self
boxNatHeight parent self@(LayoutInline _ _ _ _) = self
boxNatHeight parent self@(LayoutSpan _ _ _) = self
boxMinHeight :: Double -> LayoutItem Length Double x -> LayoutItem Length Double x
boxMinHeight parent (LayoutFlow val self childs) = LayoutFlow val self' childs'
  where
    childs' = map (boxMinHeight $ inline $ size self) childs
    self' = self { B.min = Size (inline $ B.min self) (Pixels min') }
    min' = flowMinHeight parent self
boxMinHeight parent (LayoutGrid val self childs) = LayoutGrid val self' childs'
  where
    childs' = map recurse childs
    recurse (cell, child) = (cell', child')
      where
        cell' = setCellBox (layoutGetBox child') cell
        child' = boxMinHeight width child
    self' = self {
        containerMin = Size width $ Pixels min',
        rowBounds = zip heights (map snd (rowBounds self) ++ repeat 0)
      }
    (min', heights) = gridMinHeights width self childs0
    childs0 = [ GridItem {
        gridItemBox = mapY' (lowerLength width) $ gridItemBox cell,
        startRow = startRow cell, endRow = endRow cell,
        startCol = startCol cell, endCol = endCol cell, alignment = alignment cell
      } | (cell, _) <- childs]
    width = inline $ containerSize self
boxMinHeight parent self@(LayoutInline _ font self' _) = self
boxMinHeight parent self@(LayoutSpan _ font self') = self
boxMaxHeight :: PaddedBox Double Double -> LayoutItem Length Double x ->
        LayoutItem Length Double x
boxMaxHeight parent (LayoutFlow val self childs) = LayoutFlow val self' childs'
  where
    childs' = map (boxMaxHeight $ mapY' (lowerLength width) self') childs
    self' = self { B.max = Size (inline $ B.max self) (Pixels max') }
    max' = flowMaxHeight (inline $ size parent) self
    width = inline $ size self
boxMaxHeight parent (LayoutGrid val self childs) = LayoutGrid val self' childs'
  where
    childs' = map recurse childs
    recurse (cell, child) = (cell', child')
      where
        cell' = setCellBox (layoutGetBox child') cell
        child' = boxMaxHeight parent' child
        parent' :: PaddedBox Double Double
        parent' = zero {
            B.min = mapSizeY (lowerLength width) $ containerMin self,
            B.size = mapSizeY (lowerLength width) $ containerSize self,
            B.max = Size (inline $ containerMax self') max'
        }
    self' = self {
        containerMax = Size (inline $ containerSize self) (Pixels max')
      }
    (max', heights) = gridMaxHeights parent self $ rowBounds self
    width = inline $ size parent
boxMaxHeight parent (LayoutInline val font self' vals) = LayoutInline val font self' vals
boxMaxHeight parent (LayoutSpan val font self') = LayoutSpan val font self'
boxHeight :: PaddedBox Double Double -> LayoutItem Length Double x -> LayoutItem Double Double x
boxHeight parent (LayoutFlow val self childs) = LayoutFlow val self' childs'
  where
    childs' = map (boxHeight self') childs
    self' = (mapY' (lowerLength $ inline $ size parent) self) {
        size = Size (inline $ size self) size'
      }
    size' = flowHeight parent self
    width = inline $ size self
boxHeight parent (LayoutGrid val self childs) = LayoutGrid val self' childs'
  where
    childs' = map recurse childs
    recurse (cell, child) = (cell', child')
      where
        cell' = setCellBox (layoutGetBox child') cell
        child' = boxHeight (layoutGetBox $ LayoutGrid val self' []) child
    self' = Grid {
        containerSize = Size (inline $ containerSize self) size',
        containerMin = mapSizeY (lowerLength width) $ containerMin self,
        containerMax = mapSizeY (lowerLength width) $ containerMax self,
        gap = mapSizeY (lowerLength width) $ gap self,

        rows = map lowerSize $ rows self, rowBounds = rowBounds self,
        columns = columns self, colBounds = colBounds self,
        subgridRows = subgridRows self, subgridColumns = subgridColumns self
      }
    (size', heights) = gridHeights parent self $ rowBounds self
    lowerSize (Left x) = Left $ lowerLength width x
    lowerSize (Right x) = Right x
    width = inline $ size parent
boxHeight parent (LayoutInline val font self' vals) = LayoutInline val font self' vals
boxHeight _ (LayoutSpan val font self') = LayoutSpan val font self'

boxSplit :: Double -> Double -> LayoutItem Double Double x ->
    (LayoutItem Double Double x, Maybe (LayoutItem Double Double x))
boxSplit maxheight _ node | height (layoutGetBox node) <= maxheight = (node, Nothing)
boxSplit maxheight pageheight (LayoutFlow val self childs)
    | (next:_) <- childs1, ((y,_):_) <- childs0',
        (tail,Just nextpage) <- boxSplit (maxheight - y) pageheight next =
            (LayoutFlow val self {
                size = (size self) { B.block = y }
            } (childs0 ++ [tail]),
             Just $ LayoutFlow val self {
                size = (size self) { B.block = B.block (size self) - y }
             } (nextpage:childs1))
    | otherwise =
        (LayoutFlow val self { size = (size self) { B.block = maxheight } } childs0,
         Just $ LayoutFlow val self childs1) -- TODO recompute height
  where
    childs0 = map snd childs0'
    childs1 = map snd childs1'
    (childs0', childs1') = break overflowed $ inner 0 childs
    overflowed (y, _) = y >= maxheight
    inner start (child:childs) = (start', child):inner start' childs -- TODO margin collapse?
        where start' = start + height (layoutGetBox child)
    inner _ [] = []
boxSplit _ _ self@(LayoutGrid _ _ _) = (self, Nothing) -- TODO
boxSplit _ _ self@(LayoutInline _ _ _ _) = (self, Nothing) -- TODO
boxSplit _ _ self@(LayoutSpan _ _ _) = (self, Nothing) -- Can't split!
boxPaginate maxheight pageheight node
    | (page, Just overflow) <- boxSplit maxheight pageheight node =
        page:boxPaginate maxheight pageheight overflow
    | otherwise = [node]

boxPosition :: (Double, Double) -> LayoutItem Double Double x ->
    LayoutItem Double Double ((Double, Double), x)
boxPosition pos@(x, y) (LayoutFlow val self childs) = LayoutFlow (pos, val) self childs'
  where
    childs' = map recurse $ zip pos' childs
    recurse ((Size x' y'), child) = boxPosition (x + x', y + y') child
    pos' = positionFlow $ map layoutGetBox childs
boxPosition pos@(x, y) (LayoutGrid val self childs) = LayoutGrid (pos, val) self childs'
  where
    childs' = map recurse $ zip pos' childs
    recurse ((Size x' y'), (cell, child)) = (cell, boxPosition (x + x', y + y') child)
    pos' = gridPosition self $ map fst childs
boxPosition pos@(x, y) (LayoutInline val font self vals) =
    LayoutInline (pos, val) font self $ map (\(x, y) -> (fragmentPos font pos y, x)) $
            inlineChildren vals self
boxPosition pos (LayoutSpan val f self) = LayoutSpan (pos, val) f self -- No children...
boxLayout :: PaddedBox Double Double -> LayoutItem Length Length x -> Bool ->
        LayoutItem Double Double ((Double, Double), x)
boxLayout parent self paginate = self8
  where
    self0 = boxMinWidth Nothing self
    self1 = boxNatWidth Nothing self0
    self2 = boxMaxWidth parent self1
    self3 = boxWidth parent self2
    self4 = boxNatHeight (inline $ size parent) self3
    self5 = boxMinHeight (inline $ size parent) self4
    self6 = boxMaxHeight parent self5
    self7 = boxHeight parent self6
    self8 = boxPosition (0, 0) self7

-- Useful for assembling glyph atlases.
glyphsPerFont :: LayoutItem x y z -> M.Map (Pattern, Double) IS.IntSet
glyphsPerFont (LayoutSpan _ font self) =
    (pattern font, fontSize font) `M.singleton` IS.fromList glyphs
  where glyphs = map fromEnum $ map Hb.codepoint $ map fst $ fragmentGlyphs self
glyphsPerFont node = M.unionsWith IS.union $ map glyphsPerFont $ layoutGetChilds node