From 15a1fd9420538aa265f04d60606636918ca1be07 Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Wed, 31 May 2023 16:23:39 +1200
Subject: [PATCH] Correctly assign positions, prepare to incorporate padding
 into size calc

---
 Graphics/Layout.hs        | 39 +++++++++++++++++++++++++++++++++------
 Graphics/Layout/Inline.hs | 25 +++++++++++++++++--------
 2 files changed, 50 insertions(+), 14 deletions(-)

diff --git a/Graphics/Layout.hs b/Graphics/Layout.hs
index d0cfa6a..09b740c 100644
--- a/Graphics/Layout.hs
+++ b/Graphics/Layout.hs
@@ -44,6 +44,8 @@ data LayoutItem m n x =
     -- | Results laying out richtext, has fixed width.
     -- Generated from `LayoutInline` for the sake of pagination.
     | LayoutInline' x (ParagraphLayout (UserData x)) PageOptions
+    -- | A branch with constant bounding box.
+    | LayoutConst x (PaddedBox m n) [LayoutItem m n x]
     -- | Children of a `LayoutInline` or `LayoutInline'`.
     | LayoutSpan (FragmentTree (UserData x))
 -- | An empty box.
@@ -71,17 +73,20 @@ layoutGetBox (LayoutInline' _ self _) = zero {
 layoutGetBox (LayoutSpan self) = zero {
     B.min = fragmentSize self, B.size = fragmentSize self, B.max = fragmentSize self
 }
+layoutGetBox (LayoutConst _ ret _) = ret
 -- | Retrieve the subtree under a node.
 layoutGetChilds (LayoutFlow _ _ ret) = ret
 layoutGetChilds (LayoutGrid _ _ _ ret) = ret
 layoutGetChilds (LayoutSpan _) = []
 layoutGetChilds (LayoutInline _ self _) = map LayoutSpan $ inlineChildren self
 layoutGetChilds (LayoutInline' _ self _) = map LayoutSpan $ layoutChildren self
+layoutGetChilds (LayoutConst _ _ childs) = childs
 -- | Retrieve the caller-specified data attached to a layout node.
 layoutGetInner (LayoutFlow ret _ _) = ret
 layoutGetInner (LayoutGrid ret _ _ _) = ret
 layoutGetInner (LayoutInline ret _ _) = ret
 layoutGetInner (LayoutInline' ret _ _) = ret
+layoutGetInner (LayoutConst ret _ _) = ret
 layoutGetInner (LayoutSpan x) = subtreeInner x
 
 -- | map-ready wrapper around `setCellBox` sourcing from a child node.
@@ -111,6 +116,8 @@ boxMinWidth parent (LayoutGrid val self cells0 childs) = LayoutGrid val self' ce
     zeroBox = zero
 boxMinWidth _ self@(LayoutInline _ _ _) = self
 boxMinWidth _ self@(LayoutInline' _ _ _) = self
+boxMinWidth _ (LayoutConst val self' childs) =
+    LayoutConst val self' $ map (boxMinWidth Nothing) childs
 boxMinWidth _ self@(LayoutSpan _) = self
 -- | Update a (sub)tree to compute & cache ideal width.
 boxNatWidth :: (Zero y, CastDouble y) =>
@@ -136,6 +143,8 @@ boxNatWidth parent (LayoutGrid val self cells0 childs) = LayoutGrid val self' ce
     zeroBox = zero
 boxNatWidth _ self@(LayoutInline _ _ _) = self
 boxNatWidth _ self@(LayoutInline' _ _ _) = self
+boxNatWidth _ (LayoutConst val self' childs) =
+    LayoutConst val self' $ map (boxNatWidth Nothing) childs
 boxNatWidth _ self@(LayoutSpan _) = self
 -- | Update a (sub)tree to compute & cache maximum legible width.
 boxMaxWidth :: CastDouble y => PaddedBox a Double -> LayoutItem y Length x -> LayoutItem y Length x
@@ -153,6 +162,8 @@ boxMaxWidth parent (LayoutGrid val self cells childs) = LayoutGrid val self cell
     size2box x y = zeroBox { B.min = Size x y, B.max = Size x y, B.size = Size x y }
 boxMaxWidth parent self@(LayoutInline _ _ _) = self
 boxMaxWidth parent self@(LayoutInline' _ _ _) = self
+boxMaxWidth _ (LayoutConst val self' childs) = LayoutConst val self' $
+    map (boxMaxWidth $ mapY' toDouble $ mapX' toDouble self') childs
 boxMaxWidth parent self@(LayoutSpan _) = self
 -- | Update a (sub)tree to compute & cache final width.
 boxWidth :: (Zero y, CastDouble y) => PaddedBox b Double -> LayoutItem y Length x ->
@@ -182,6 +193,9 @@ boxWidth parent (LayoutInline val (Paragraph a b c d) paging) =
     LayoutInline val (Paragraph a b c d { paragraphMaxWidth = round width }) paging
   where width = B.inline $ B.size parent
 boxWidth _ (LayoutInline' a b c) = LayoutInline' a b c
+boxWidth p (LayoutConst val self childs) = LayoutConst val (mapX' cb self) $
+    map (boxWidth $ mapY' toDouble $ mapX' cb self) childs
+  where cb = lowerLength $ width p
 boxWidth parent (LayoutSpan self') = LayoutSpan self'
 
 -- | Update a (sub)tree to compute & cache ideal legible height.
@@ -201,6 +215,8 @@ boxNatHeight parent (LayoutGrid val self cells childs) = LayoutGrid val self' ce
     width = trackNat id $ inline self
 boxNatHeight parent self@(LayoutInline _ _ _) = self
 boxNatHeight parent self@(LayoutInline' _ _ _) = self
+boxNatHeight p (LayoutConst val self' childs) = LayoutConst val self' $
+    map (boxNatHeight $ width $ mapY' (lowerLength p) self') childs
 boxNatHeight parent self@(LayoutSpan _) = self
 -- | Update a (sub)tree to compute & cache minimum legible height.
 boxMinHeight :: Double -> LayoutItem Length Double x -> LayoutItem Length Double x
@@ -221,6 +237,8 @@ boxMinHeight parent (LayoutGrid val self cells childs) = LayoutGrid val self' ce
     width = trackNat id $ inline self
 boxMinHeight parent self@(LayoutInline _ _ _) = self
 boxMinHeight _ self@(LayoutInline' _ _ _) = self
+boxMinHeight p (LayoutConst val self' childs) = LayoutConst val self' $
+    map (boxMinHeight $ width $ mapY' (lowerLength p) self') childs
 boxMinHeight parent self@(LayoutSpan _) = self
 -- | Update a subtree to compute & cache maximum legible height.
 boxMaxHeight :: PaddedBox Double Double -> LayoutItem Length Double x ->
@@ -242,6 +260,8 @@ boxMaxHeight parent (LayoutGrid val self cells childs) = LayoutGrid val self cel
     width = inline $ size parent
 boxMaxHeight _ (LayoutInline val self' paging) = LayoutInline val self' paging
 boxMaxHeight _ (LayoutInline' val self' paging) = LayoutInline' val self' paging
+boxMaxHeight p (LayoutConst val self' childs) = LayoutConst val self' $
+    map (boxMaxHeight $ mapY' (lowerLength $ width p) self') childs
 boxMaxHeight parent (LayoutSpan self') = LayoutSpan self'
 -- | Update a (sub)tree to compute & cache final height.
 boxHeight :: PaddedBox Double Double -> LayoutItem Length Double x -> LayoutItem Double Double x
@@ -271,6 +291,9 @@ boxHeight parent (LayoutGrid val self cells0 childs) = LayoutGrid val self' cell
     width = inline $ size parent
 boxHeight _ (LayoutInline val self' paging) = LayoutInline val self' paging
 boxHeight _ (LayoutInline' val self' paging) = LayoutInline' val self' paging
+boxHeight p (LayoutConst val self childs) =
+    let self' = mapY' (lowerLength $ width p) self
+    in LayoutConst val self' $ map (boxHeight self') childs
 boxHeight _ (LayoutSpan self') = LayoutSpan self'
 
 -- | Split a (sub)tree to fit within max-height.
@@ -298,6 +321,7 @@ boxSplit maxheight pageheight (LayoutFlow val self childs)
     inner start (child:childs) = (start', child):inner start' childs -- TODO margin collapse?
         where start' = start + height (layoutGetBox child)
     inner _ [] = []
+boxSplit _ _ self@(LayoutConst _ _ _) = (self, Nothing) -- Doesn't split.
 boxSplit _ _ self@(LayoutGrid _ _ _ _) = (self, Nothing) -- TODO
 boxSplit maxheight pageheight (LayoutInline a self b) =
     boxSplit maxheight pageheight $ LayoutInline' a (layoutRich self) b
@@ -318,8 +342,8 @@ boxPaginate pageheight node
     | otherwise = [node]
 
 -- | Compute position of all nodes in the (sub)tree relative to a base coordinate.
-boxPosition :: PropertyParser x => (Double, Double) -> LayoutItem Double Double x ->
-    LayoutItem Double Double ((Double, Double), x)
+boxPosition :: (PropertyParser x, Eq x) => (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
@@ -332,12 +356,15 @@ boxPosition pos@(x, y) (LayoutGrid val self cells childs) = LayoutGrid (pos, val
     pos' = gridPosition self cells
 boxPosition pos@(x, y) (LayoutInline val self paging) =
     boxPosition pos $ LayoutInline' val (layoutRich self) paging
-boxPosition pos@(x, y) (LayoutInline' val self paging) =
-    LayoutInline' (pos, val) (positionChildren pos self) paging
+boxPosition pos@(x, y) self@(LayoutInline' val _ _) =
+    boxPosition pos $ LayoutConst val (layoutGetBox self) $ layoutGetChilds self
+boxPosition pos (LayoutConst val self childs) =
+    LayoutConst (pos, val) self $ map (boxPosition pos) childs
 boxPosition pos (LayoutSpan self) = LayoutSpan $ positionSubtree pos self
 -- | Compute sizes & position information for all nodes in the (sub)tree.
-boxLayout :: PropertyParser x => PaddedBox Double Double -> LayoutItem Length Length x ->
-        Bool -> [LayoutItem Double Double ((Double, Double), x)]
+boxLayout :: (PropertyParser x, Eq x) => PaddedBox Double Double ->
+        LayoutItem Length Length x -> Bool -> 
+        [LayoutItem Double Double ((Double, Double), x)]
 boxLayout parent self paginate = self9
   where
     self0 = boxMinWidth Nothing self
diff --git a/Graphics/Layout/Inline.hs b/Graphics/Layout/Inline.hs
index 61d0cb9..49fc39b 100644
--- a/Graphics/Layout/Inline.hs
+++ b/Graphics/Layout/Inline.hs
@@ -16,7 +16,7 @@ import qualified Data.Text as Txt
 import Data.Char (isSpace)
 import Data.Int (Int32)
 
-import Graphics.Layout.Box (Size(..), CastDouble(..), fromDouble)
+import Graphics.Layout.Box (PaddedBox, Length, Size(..), CastDouble(..), fromDouble)
 import Graphics.Layout.CSS.Font (Font', hbUnit)
 
 -- | Convert from Harfbuzz units to device pixels as a Double
@@ -62,11 +62,13 @@ layoutRich' (Paragraph a b c d) width =
     paragraphRect $ layoutRich $ Paragraph a b c d { paragraphMaxWidth = width }
 
 -- | Retrieve the rect for a fragment & convert to CatTrap types.
-fragmentSize :: (CastDouble x, CastDouble y) => FragmentTree a -> Size x y
+fragmentSize :: (CastDouble x, CastDouble y) =>
+        FragmentTree (a, PaddedBox Length Length, c) -> Size x y
 fragmentSize self = Size (c $ width r) (c $ height r)
     where r = treeRect self
 -- | Compute the unioned rect for a subtree.
-treeRect :: FragmentTree a -> Rect Int32
+treeRect :: (CastDouble m, CastDouble n) =>
+        FragmentTree (a, PaddedBox m n, c) -> Rect Int32
 treeRect (Branch _ childs) = foldr unionRect (Rect 0 0 0 0) $ map treeRect childs
     where unionRect a b = Rect (x_min a `min` x_min b) (y_min a `min` y_min b)
             ((x_max a `max` x_max b) - (x_min a `min` x_min b))
@@ -75,7 +77,7 @@ treeRect (Leaf self) = fragmentRect self
 
 -- | Variant of `fragmentSize` asserting to the typesystem that both fields
 -- of the resulting `Size` are of the same type.
-fragmentSize' :: CastDouble x => FragmentTree a -> Size x x
+fragmentSize' :: CastDouble x => FragmentTree (a, PaddedBox Length Length, c) -> Size x x
 fragmentSize' = fragmentSize -- Work around for typesystem.
 -- | Retrieve the position of a fragment.
 fragmentPos :: (Double, Double) -> Fragment a -> (Double, Double)
@@ -124,13 +126,20 @@ reconstructTree' frags@(Fragment {
     sameBranch Fragment { fragmentAncestorBoxes = [] } = False
 reconstructTree' [] = []
 
-positionSubtree :: (Double, Double) -> FragmentTree (a, b, c) ->
-        FragmentTree (a, b, ((Double, Double), c))
-positionSubtree pos (Branch (AncestorBox (a, b, c) d e f g) childs) =
+positionSubtree :: (Double, Double) ->
+        FragmentTree (a, PaddedBox Length Length, c) ->
+        FragmentTree (a, PaddedBox Length Length, ((Double, Double), c))
+positionSubtree (x, y) self@(Branch (AncestorBox (a, b, c) d e f g) childs) =
     Branch (AncestorBox (a, b, (pos, c)) d e f g) $
         map (positionSubtree pos) childs
-positionSubtree pos (Leaf (Fragment (a, b, c) d _ f g h)) =
+  where
+    pos = (x + hbScale (x_min rect), y + hbScale (y_min rect))
+    rect = treeRect self
+positionSubtree (x, y) self@(Leaf (Fragment (a, b, c) d _ f g h)) =
     Leaf (Fragment (a, b, (pos, c)) d [] f g h)
+  where
+    pos = (x + hbScale (x_min rect), y + hbScale (y_min rect))
+    rect = treeRect self
 subtreeInner :: FragmentTree (a, b, c) -> c
 subtreeInner (Branch AncestorBox { boxUserData = (_, _, ret) } _) = ret
 subtreeInner (Leaf Fragment { fragmentUserData = (_, _, ret) }) = ret
-- 
2.30.2