From f7444393d107bb90a9d4000994ae4cd0e5aac2b9 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Sat, 8 Apr 2023 13:00:52 +1200 Subject: [PATCH] Refactor grid sizes to be dynamically computed. --- Graphics/Layout.hs | 79 +++++++++----------------------- Graphics/Layout/Box.hs | 15 ++++--- Graphics/Layout/Grid.hs | 90 ++++++++++++++++++++----------------- Graphics/Layout/Grid/CSS.hs | 9 ++-- 4 files changed, 85 insertions(+), 108 deletions(-) diff --git a/Graphics/Layout.hs b/Graphics/Layout.hs index 388e7e6..57ed3a7 100644 --- a/Graphics/Layout.hs +++ b/Graphics/Layout.hs @@ -37,9 +37,9 @@ 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 + B.min = Size (fromDouble $ gridMinWidth toDouble self) (fromDouble $ gridMinHeight toDouble self), + B.size = Size (fromDouble $ gridNatWidth toDouble self) (fromDouble $ gridNatHeight toDouble self), + B.max = Size (fromDouble $ gridNatWidth toDouble self) (fromDouble $ gridNatHeight toDouble self) } layoutGetBox (LayoutInline _ f self _ _) = zero { B.min = inlineMin f self, B.size = inlineSize f self, B.max = inlineSize f self @@ -77,17 +77,14 @@ boxMinWidth parent (LayoutFlow val self childs) = LayoutFlow val self' childs' 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) - } + self' = self { colMins = cells } (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 + selfWidth = gridNatWidth (lowerLength parent') self parent' = fromMaybe (gridEstWidth self [ GridItem startRow endRow startCol endCol alignment zeroBox | (GridItem {..}, _) <- childs]) parent @@ -108,10 +105,7 @@ boxNatWidth parent (LayoutFlow val self childs) = LayoutFlow val self' childs' 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 - } + self' = self { colNats = cells } (size', cells) = gridNatWidths parent' self cells'' cells'' = [ cell { gridItemBox = mapX' (lowerLength selfWidth) $ gridItemBox cell } @@ -120,7 +114,7 @@ boxNatWidth parent (LayoutGrid val self childs) = LayoutGrid val self' $ zip cel 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 + selfWidth = gridNatWidth (lowerLength parent') self parent' = fromMaybe (gridEstWidth self [ GridItem startRow endRow startCol endCol alignment zeroBox | (GridItem {..}, _) <- childs]) parent @@ -136,10 +130,7 @@ boxMaxWidth parent (LayoutFlow val self childs) = LayoutFlow val 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 (LayoutGrid val self childs) = LayoutGrid val self childs boxMaxWidth parent self@(LayoutInline _ _ _ _ _) = self boxMaxWidth parent self@(LayoutInline' _ _ _ _ _) = self boxMaxWidth parent self@(LayoutSpan _ f self') = self @@ -158,26 +149,18 @@ boxWidth parent (LayoutGrid val self childs) = LayoutGrid val self' 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' - } + child' = boxWidth (mapX' (lowerLength size') $ gridItemBox cell) child 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, + rowMins = rowMins self, rowNats = rowNats self, + colMins = colMins self, colNats = colNats self, subgridRows = subgridRows self, subgridColumns = subgridColumns self } outerwidth = inline $ size parent - (size', widths) = gridWidths parent self $ colBounds self + (size', widths) = gridWidths parent self (colMins self) (colNats self) boxWidth parent (LayoutInline val font (Paragraph a b c d) paging vals) = LayoutInline val font (Paragraph a b c d { paragraphMaxWidth = round width }) paging vals where width = B.inline $ B.size parent @@ -191,18 +174,15 @@ boxNatHeight parent (LayoutFlow val self childs) = LayoutFlow val self' childs' 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' +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 + width = gridNatWidth id self boxNatHeight parent self@(LayoutInline _ _ _ _ _) = self boxNatHeight parent self@(LayoutInline' _ _ _ _ _) = self boxNatHeight parent self@(LayoutSpan _ _ _) = self @@ -219,17 +199,14 @@ boxMinHeight parent (LayoutGrid val self childs) = LayoutGrid val self' childs' 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) - } + self' = self { rowMins = heights } (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 + width = gridNatWidth id self boxMinHeight parent self@(LayoutInline _ _ _ _ _) = self boxMinHeight _ self@(LayoutInline' _ _ _ _ _) = self boxMinHeight parent self@(LayoutSpan _ font self') = self @@ -241,23 +218,14 @@ boxMaxHeight parent (LayoutFlow val self childs) = LayoutFlow val 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' +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 + child' = boxMaxHeight (mapY' (lowerLength width) $ gridItemBox cell) child + (max', heights) = gridMaxHeights parent self (rowMins self) (rowNats self) width = inline $ size parent boxMaxHeight parent (LayoutInline val font self' paging vals) = LayoutInline val font self' paging vals @@ -281,16 +249,13 @@ boxHeight parent (LayoutGrid val self childs) = LayoutGrid val self' childs' 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, + rows = map lowerSize $ rows self, rowMins = rowMins self, rowNats = rowNats self, + columns = columns self, colMins = colMins self, colNats = colNats self, subgridRows = subgridRows self, subgridColumns = subgridColumns self } - (size', heights) = gridHeights parent self $ rowBounds self + (size', heights) = gridHeights parent self (rowMins self) (rowNats self) lowerSize (Left x) = Left $ lowerLength width x lowerSize (Right x) = Right x width = inline $ size parent diff --git a/Graphics/Layout/Box.hs b/Graphics/Layout/Box.hs index f6304c7..391f369 100644 --- a/Graphics/Layout/Box.hs +++ b/Graphics/Layout/Box.hs @@ -97,13 +97,18 @@ instance (Zero m, Zero n) => Zero (PaddedBox m n) where min = Size zero zero, max = Size zero zero, size = Size zero zero, - padding = Border zero zero zero zero, - border = Border zero zero zero zero, - margin = Border zero zero zero zero + padding = Border zero zero zero zero, + border = Border zero zero zero zero, + margin = Border zero zero zero zero } class CastDouble a where fromDouble :: Double -> a + toDouble :: a -> Double -instance CastDouble Double where fromDouble = id -instance CastDouble Length where fromDouble = Pixels +instance CastDouble Double where + fromDouble = id + toDouble = id +instance CastDouble Length where + fromDouble = Pixels + toDouble = lowerLength 0 diff --git a/Graphics/Layout/Grid.hs b/Graphics/Layout/Grid.hs index 4355d25..a2b33d9 100644 --- a/Graphics/Layout/Grid.hs +++ b/Graphics/Layout/Grid.hs @@ -1,6 +1,7 @@ {-# LANGUAGE RecordWildCards, OverloadedStrings #-} module Graphics.Layout.Grid(Grid(..), GridItem(..), Alignment(..), Name, buildGrid, setCellBox, enumerate, + gridMinWidth, gridMinHeight, gridNatWidth, gridNatHeight, gridEstWidth, gridNatWidths, gridMinWidths, gridMaxWidths, gridWidths, gridNatHeights, gridMinHeights, gridMaxHeights, gridHeights, gridPosition, gridLayout) where @@ -15,15 +16,14 @@ import Debug.Trace (trace) -- TODO implement subgrid support... data Grid m n = Grid { rows :: [Either m Double], - rowBounds :: [(Double, Double)], + rowMins :: [Double], + rowNats :: [Double], subgridRows :: Int, columns :: [Either n Double], - colBounds :: [(Double, Double)], + colMins :: [Double], + colNats :: [Double], subgridColumns :: Int, - gap :: Size m n, - containerSize :: Size m n, -- wrap in a Flow box to get padding, etc. - containerMin :: Size m n, - containerMax :: Size m n + gap :: Size m n } data GridItem m n = GridItem { startRow :: Int, endRow :: Int, startCol :: Int, endCol :: Int, @@ -36,20 +36,34 @@ type Name = Text buildGrid rows columns = Grid { rows = rows, - rowBounds = [], + rowMins = [], rowNats = [], subgridRows = 0, -- disables columns = columns, - colBounds = [], + colMins = [], colNats = [], subgridColumns = 0, -- disables - gap = Size (Pixels 0) (Pixels 0), - containerSize = Size Auto Auto, - containerMin = Size Auto Auto, - containerMax = Size Auto Auto + gap = Size (Pixels 0) (Pixels 0) } -- Created to address typesystem issues with record syntax. setCellBox :: PaddedBox mm nn -> GridItem m n -> GridItem mm nn setCellBox box' GridItem {..} = GridItem startRow endRow startCol endCol alignment box' +gridMinWidth :: (n -> Double) -> Grid m n -> Double +gridMinWidth cb self@Grid { colMins = [] } = + sum $ intersperse (cb $ inline $ gap self) [cb x | Left x <- columns self] +gridMinWidth cb self = sum $ intersperse (cb $ inline $ gap self) $ colMins self +gridMinHeight :: (m -> Double) -> Grid m n -> Double +gridMinHeight cb self@Grid { rowMins = [] } = + sum $ intersperse (cb $ block $ gap self) [cb x | Left x <- rows self] +gridMinHeight cb self = sum $ intersperse (cb $ block $ gap self) $ rowMins self +gridNatWidth :: (n -> Double) -> Grid m n -> Double +gridNatWidth cb self@Grid { colMins = [] } = + sum $ intersperse (cb $ inline $ gap self) [cb x | Left x <- columns self] +gridNatWidth cb self = sum $ intersperse (cb $ inline $ gap self) $ colNats self +gridNatHeight :: (m -> Double) -> Grid m n -> Double +gridNatHeight cb self@Grid { rowNats = [] } = + sum $ intersperse (cb $ block $ gap self) [cb x | Left x <- rows self] +gridNatHeight cb self = sum $ intersperse (cb $ block $ gap self) $ rowNats self + cellsForCol :: [GridItem y x] -> Int -> [GridItem y x] cellsForCol cells ix = [cell | cell <- cells, startCol cell == ix, startCol cell == pred (endCol cell)] @@ -66,7 +80,7 @@ verifyGrid self childs = and [ height = length $ rows self gridEstWidth :: Grid b Length -> [GridItem y Double] -> Double -gridEstWidth self childs = fst $ gridMaxWidths zeroBox self $ zip mins nats +gridEstWidth self childs = fst $ gridMaxWidths zeroBox self mins nats where mins = snd $ gridMinWidths 0 self childs nats = snd $ gridNatWidths 0 self childs @@ -92,10 +106,11 @@ gridNatWidths parent self childs = maximum $ (0:) $ map (inline . B.min . gridItemBox) $ cellsForCol childs ix colNatWidth (ix, _) = maximum $ (0:) $ map (inline . size . gridItemBox) $ cellsForCol childs ix -gridMaxWidths :: PaddedBox b Double -> Grid y Length -> [(Double, Double)] -> (Double, [Double]) -gridMaxWidths parent self subwidths = +gridMaxWidths :: PaddedBox b Double -> Grid y Length -> [Double] -> [Double] -> (Double, [Double]) +gridMaxWidths parent self submins subnats = (sum $ intersperse (lowerLength outerwidth $ inline $ gap self) ret, ret) where + subwidths = zip submins subnats ret = map (colMaxWidth fr) $ zip subwidths $ columns self fr = Prelude.max 0 fr' fr' = (outerwidth - estimate)/(countFRs $ columns self) @@ -108,10 +123,11 @@ gridMaxWidths parent self subwidths = colMaxWidth _ ((min, _), Left Min) = min colMaxWidth fr (_, Left Auto) = fr colMaxWidth fr (_, Right x) = x*fr -gridWidths :: PaddedBox b Double -> Grid y Length -> [(Double, Double)] -> (Double, [Double]) -gridWidths parent self subwidths = +gridWidths :: PaddedBox b Double -> Grid y Length -> [Double] -> [Double] -> (Double, [Double]) +gridWidths parent self submins subnats = (sum $ intersperse (lowerLength outerwidth $ inline $ gap self) ret, ret) where + subwidths = zip submins subnats ret = map (colWidth fr) $ zip subwidths $ columns self fr = (outerwidth - estimate)/(countFRs $ columns self) outerwidth = inline $ size parent @@ -148,9 +164,10 @@ gridMinHeights parent self childs = rowMinHeight (ix, _) = maximum $ (0:) $ map (block . B.min . gridItemBox) $ cellsForCol childs ix gridMaxHeights :: PaddedBox Double Double -> Grid Length Double -> - [(Double, Double)] -> (Double, [Double]) -gridMaxHeights parent self subheights = (sum $ intersperse (inline $ gap self) ret, ret) + [Double] -> [Double] -> (Double, [Double]) +gridMaxHeights parent self submins subnats = (sum $ intersperse (inline $ gap self) ret, ret) where + subheights = zip submins subnats ret = map (colMaxHeight fr) $ zip subheights $ rows self fr = (outerheight - estimate)/(countFRs $ rows self) outerwidth = inline $ size parent @@ -164,9 +181,10 @@ gridMaxHeights parent self subheights = (sum $ intersperse (inline $ gap self) r colMaxHeight fr (_, Left Auto) = fr colMaxHeight fr (_, Right x) = x*fr gridHeights :: PaddedBox Double Double -> Grid Length Double -> - [(Double, Double)] -> (Double, [Double]) -gridHeights parent self subheights = (sum $ intersperse (inline $ gap self) ret, ret) + [Double] -> [Double] -> (Double, [Double]) +gridHeights parent self submins subnats = (sum $ intersperse (inline $ gap self) ret, ret) where + subheights = zip submins subnats ret = map (colHeight fr) $ zip subheights $ rows self fr = (outerheight - estimate)/(countFRs $ rows self) outerwidth = inline $ size parent @@ -209,33 +227,25 @@ gridLayout parent self childs paginate = (self', zip positions childs) positions = gridPosition self' childs self' = self { rows = map Left rows', - rowBounds = rowBounds', + rowMins = rowMins', rowNats = rowNats', columns = map Left cols', - colBounds = colBounds', - gap = Size (lowerLength width' gapX) (lowerLength width' gapY), - containerSize = Size width' height', - containerMin = Size width' height', - containerMax = Size width' height' + colMins = colMins', colNats = colNats', + gap = Size (lowerLength width' gapX) (lowerLength width' gapY) } Size gapX gapY = gap self - (height', rows') = gridHeights parent self0 rowBounds' - rowBounds' = zip rowMins rowNats - (_, rowMins) = gridMinHeights width' self0 childs - (_, rowNats) = gridNatHeights width' self0 childs + (height', rows') = gridHeights parent self0 rowMins' rowNats' + (_, rowMins') = gridMinHeights width' self0 childs + (_, rowNats') = gridNatHeights width' self0 childs self0 = self { columns = map Left cols', - colBounds = colBounds', - gap = Size (lowerLength width' gapX) gapY, - containerSize = let Size _ y = containerSize self in Size width' y, - containerMin = let Size _ y = containerSize self in Size width' y, - containerMax = let Size _ y = containerSize self in Size width' y + colMins = colMins', colNats = colNats', + gap = Size (lowerLength width' gapX) gapY } - (width', cols') = gridWidths parent self colBounds' - colBounds' = zip colMins colNats - (_, colMins) = gridMinWidths estWidth self childs - (_, colNats) = gridNatWidths estWidth self childs + (width', cols') = gridWidths parent self colMins' colNats' + (_, colMins') = gridMinWidths estWidth self childs + (_, colNats') = gridNatWidths estWidth self childs estWidth = gridEstWidth self childs enumerate = zip [0..] diff --git a/Graphics/Layout/Grid/CSS.hs b/Graphics/Layout/Grid/CSS.hs index a785d66..3888140 100644 --- a/Graphics/Layout/Grid/CSS.hs +++ b/Graphics/Layout/Grid/CSS.hs @@ -258,16 +258,13 @@ finalizeGrid self@CSSGrid { where self' = Grid { rows = map finalizeFR $ map snd rows0, - rowBounds = [], + rowMins = [], rowNats = [], subgridRows = 0, -- disable columns = map finalizeFR $ map snd cols0, - colBounds = [], + colMins = [], colNats = [], subgridColumns = 0, -- disable gap = Size (finalizeLength (inline $ cssGap self) font) - (finalizeLength (block $ cssGap self) font), - containerSize = Size Auto Auto, -- Proper size is set on parent. - containerMin = Size Auto Auto, - containerMax = Size Auto Auto + (finalizeLength (block $ cssGap self) font) } (cells', rows0, cols0) = finalizeCells cells rows' cols' -- 2.30.2