From a5de823ba0a9717a95994b1ec72720fb39dac12f Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Sun, 9 Apr 2023 13:03:42 +1200 Subject: [PATCH] Bugfix & pagination integration. --- Graphics/Layout.hs | 23 ++++++++++-------- Graphics/Layout/Flow.hs | 4 ++-- test/Test.hs | 52 ++++++++++++++++++++--------------------- 3 files changed, 41 insertions(+), 38 deletions(-) diff --git a/Graphics/Layout.hs b/Graphics/Layout.hs index c4aa012..bee9693 100644 --- a/Graphics/Layout.hs +++ b/Graphics/Layout.hs @@ -95,11 +95,11 @@ 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' +boxNatWidth parent (LayoutFlow val self childs) = LayoutFlow val self childs' where - self' = self { size = mapSizeX (B.mapAuto size') (size self) } + {-self' = self { size = mapSizeX (B.mapAuto size') (size self) } size' = flowNatWidth parent' self childs'' - childs'' = map (mapX' $ lowerLength selfWidth) $ map layoutGetBox 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 @@ -169,8 +169,9 @@ 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 cells childs) = LayoutGrid val self cells childs' +boxNatHeight parent (LayoutGrid val self cells childs) = LayoutGrid val self' cells childs' where + self' = Size (inline self) (block self) { trackNats = heights } heights = sizeTrackNats parent (block self) $ map block cells' cells' = map setCellBox' $ zip childs' cells childs' = map (boxNatHeight width) childs @@ -286,9 +287,9 @@ boxSplit maxheight pageheight (LayoutInline' a b self paging c) = where wrap self' = LayoutInline' a b self' paging c boxSplit _ _ self@(LayoutSpan _ _ _) = (self, Nothing) -- Can't split! -boxPaginate maxheight pageheight node - | (page, Just overflow) <- boxSplit maxheight pageheight node = - page:boxPaginate maxheight pageheight overflow +boxPaginate pageheight node + | (page, Just overflow) <- boxSplit pageheight pageheight node = + page:boxPaginate pageheight overflow | otherwise = [node] boxPosition :: PropertyParser x => (Double, Double) -> LayoutItem Double Double x -> @@ -311,8 +312,8 @@ boxPosition pos@(x, y) (LayoutInline' val font self paging vals) = layoutChildren vals self boxPosition pos (LayoutSpan val f self) = LayoutSpan (pos, val) f self -- No children... boxLayout :: PropertyParser x => PaddedBox Double Double -> LayoutItem Length Length x -> - Bool -> LayoutItem Double Double ((Double, Double), x) -boxLayout parent self paginate = self8 + Bool -> [LayoutItem Double Double ((Double, Double), x)] +boxLayout parent self paginate = self9 where self0 = boxMinWidth Nothing self self1 = boxNatWidth Nothing self0 @@ -322,7 +323,9 @@ boxLayout parent self paginate = self8 self5 = boxMinHeight (inline $ size parent) self4 self6 = boxMaxHeight parent self5 self7 = boxHeight parent self6 - self8 = boxPosition (0, 0) self7 + self8 | paginate = boxPaginate (block $ size parent) self7 + | otherwise = [self7] + self9 = map (boxPosition (0, 0)) self8 -- Useful for assembling glyph atlases. glyphsPerFont :: LayoutItem x y z -> M.Map (Pattern, Double) IS.IntSet diff --git a/Graphics/Layout/Flow.hs b/Graphics/Layout/Flow.hs index c857e15..0f95a74 100644 --- a/Graphics/Layout/Flow.hs +++ b/Graphics/Layout/Flow.hs @@ -73,9 +73,9 @@ positionFlow :: [PaddedBox Double Double] -> [Size Double Double] positionFlow childs = scanl inner (Size 0 0) $ marginCollapse childs where inner (Size x y) self = Size x $ height self layoutFlow :: PaddedBox Double Double -> PaddedBox Length Length -> - [PaddedBox Length Double] -> Bool -> + [PaddedBox Length Double] -> (PaddedBox Double Double, [(Size Double Double, PaddedBox Double Double)]) -layoutFlow parent self childs paginate = (self', zip positions' childs') +layoutFlow parent self childs = (self', zip positions' childs') where positions' = positionFlow childs' childs' = map layoutZooko childs diff --git a/test/Test.hs b/test/Test.hs index 6f70ef6..1315f75 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -35,43 +35,43 @@ spec = do size = Size 3 1 } lengthBox { border = Border (Pixels 0) (Pixels 0) (Pixels 2) (Pixels 2) - } [] False) `shouldBe` 4 + } []) `shouldBe` 4 width (fst $ layoutFlow zeroBox { size = Size 3 1 } lengthBox { padding = Border (Pixels 0) (Pixels 0) (Pixels 2) (Pixels 2) - } [] False) `shouldBe` 4 + } []) `shouldBe` 4 width (fst $ layoutFlow zeroBox { size = Size 3 1 } lengthBox { margin = Border (Pixels 0) (Pixels 0) (Pixels 2) (Pixels 2) - } [] False) `shouldBe` 4 + } []) `shouldBe` 4 it "Fits to parent" $ do width (fst $ layoutFlow zeroBox { size = Size 5 1 } lengthBox { border = Border (Pixels 0) (Pixels 0) (Pixels 2) (Pixels 2), size = Size Auto $ Pixels 1 - } [] False) `shouldBe` 5 + } []) `shouldBe` 5 width (fst $ layoutFlow zeroBox { size = Size 5 1 } lengthBox { padding = Border (Pixels 0) (Pixels 0) (Pixels 2) (Pixels 2), size = Size Auto $ Pixels 1 - } [] False) `shouldBe` 5 + } []) `shouldBe` 5 width (fst $ layoutFlow zeroBox { size = Size 5 1 } lengthBox { margin = Border (Pixels 0) (Pixels 0) (Pixels 2) (Pixels 2), size = Size Auto $ Pixels 1 - } [] False) `shouldBe` 5 + } []) `shouldBe` 5 it "Fits children" $ do let child = mapX' (lowerLength 100) $ lengthBox { size = Size (Pixels 10) (Pixels 10) } height (fst $ layoutFlow zeroBox { size = Size 100 100 - } lengthBox [child, child] False) `shouldBe` 20 + } lengthBox [child, child]) `shouldBe` 20 it "Collapses margins" $ do let a :: PaddedBox Length Double a = PaddedBox { @@ -93,16 +93,16 @@ spec = do } height (fst $ layoutFlow zeroBox { size = Size 100 100 - } lengthBox [a, a] False) `shouldBe` 25 + } lengthBox [a, a]) `shouldBe` 25 height (fst $ layoutFlow zeroBox { size = Size 100 100 - } lengthBox [b, b] False) `shouldBe` 25 + } lengthBox [b, b]) `shouldBe` 25 height (fst $ layoutFlow zeroBox { size = Size 100 100 - } lengthBox [a, b] False) `shouldBe` 20 + } lengthBox [a, b]) `shouldBe` 20 height (fst $ layoutFlow zeroBox { size = Size 100 100 - } lengthBox [b, a] False) `shouldBe` 25 + } lengthBox [b, a]) `shouldBe` 25 {-describe "Grid" $ do it "computes single-columns widths/heights" $ do let (pxGrid, pxCells) = gridLayout zeroBox { @@ -146,50 +146,50 @@ spec = do fst (head minCells) `shouldBe` Size 0 0-} describe "Abstract layout" $ do it "Can overflow parent" $ do - width (layoutGetBox $ boxLayout zeroBox { + width (layoutGetBox $ head $ boxLayout zeroBox { size = Size 3 1 } (LayoutFlow () lengthBox { border = Border (Pixels 0) (Pixels 0) (Pixels 2) (Pixels 2) } []) False) `shouldBe` 4 - height (layoutGetBox $ boxLayout zeroBox { + height (layoutGetBox $ head $ boxLayout zeroBox { size = Size 3 1 } (LayoutFlow () lengthBox { border = Border (Pixels 2) (Pixels 2) (Pixels 2) (Pixels 2) } []) False) `shouldBe` 4 - width (layoutGetBox $ boxLayout zeroBox { + width (layoutGetBox $ head $ boxLayout zeroBox { size = Size 3 1 } (LayoutFlow () lengthBox { padding = Border (Pixels 0) (Pixels 0) (Pixels 2) (Pixels 2) } []) False) `shouldBe` 4 - height (layoutGetBox $ boxLayout zeroBox { + height (layoutGetBox $ head $ boxLayout zeroBox { size = Size 3 1 } (LayoutFlow () lengthBox { padding = Border (Pixels 2) (Pixels 2) (Pixels 2) (Pixels 2) } []) False) `shouldBe` 4 - width (layoutGetBox $ boxLayout zeroBox { + width (layoutGetBox $ head $ boxLayout zeroBox { size = Size 3 1 } (LayoutFlow () lengthBox { margin = Border (Pixels 0) (Pixels 0) (Pixels 2) (Pixels 2) } []) False) `shouldBe` 4 - height (layoutGetBox $ boxLayout zeroBox { + height (layoutGetBox $ head $ boxLayout zeroBox { size = Size 3 1 } (LayoutFlow () lengthBox { margin = Border (Pixels 2) (Pixels 2) (Pixels 2) (Pixels 2) } []) False) `shouldBe` 4 it "Fits to parent" $ do - width (layoutGetBox $ boxLayout zeroBox { + width (layoutGetBox $ head $ boxLayout zeroBox { size = Size 5 1 } (LayoutFlow () lengthBox { border = Border (Pixels 0) (Pixels 0) (Pixels 2) (Pixels 2), size = Size Auto $ Pixels 1 } []) False) `shouldBe` 5 - width (layoutGetBox $ boxLayout zeroBox { + width (layoutGetBox $ head $ boxLayout zeroBox { size = Size 5 1 } (LayoutFlow () lengthBox { padding = Border (Pixels 0) (Pixels 0) (Pixels 2) (Pixels 2), size = Size Auto $ Pixels 1 } []) False) `shouldBe` 5 - width (layoutGetBox $ boxLayout zeroBox { + width (layoutGetBox $ head $ boxLayout zeroBox { size = Size 5 1 } (LayoutFlow () lengthBox { margin = Border (Pixels 0) (Pixels 0) (Pixels 2) (Pixels 2), @@ -200,10 +200,10 @@ spec = do size = Size (Pixels 10) (Pixels 10), B.max = Size (Pixels 10) (Pixels 10) } [] - height (layoutGetBox $ boxLayout zeroBox { + height (layoutGetBox $ head $ boxLayout zeroBox { size = Size 100 100 } child False) `shouldBe` 10 - height (layoutGetBox $ boxLayout zeroBox { + height (layoutGetBox $ head $ boxLayout zeroBox { size = Size 100 100 } (LayoutFlow () lengthBox [child, child]) False) `shouldBe` 20 it "Collapses margins" $ do @@ -225,16 +225,16 @@ spec = do border = Border (Pixels 0) (Pixels 0) (Pixels 0) (Pixels 0), margin = Border (Pixels 10) (Pixels 5) (Pixels 0) (Pixels 0) } [] - height (layoutGetBox $ boxLayout zeroBox { + height (layoutGetBox $ head $ boxLayout zeroBox { size = Size 100 100 } (LayoutFlow () lengthBox [a, a]) False) `shouldBe` 25 - height (layoutGetBox $ boxLayout zeroBox { + height (layoutGetBox $ head $ boxLayout zeroBox { size = Size 100 100 } (LayoutFlow () lengthBox [b, b]) False) `shouldBe` 25 - height (layoutGetBox $ boxLayout zeroBox { + height (layoutGetBox $ head $ boxLayout zeroBox { size = Size 100 100 } (LayoutFlow () lengthBox [a, b]) False) `shouldBe` 20 - height (layoutGetBox $ boxLayout zeroBox { + height (layoutGetBox $ head $ boxLayout zeroBox { size = Size 100 100 } (LayoutFlow () lengthBox [b, a]) False) `shouldBe` 25 -- 2.30.2