From 59a70cdb71a71e7ec2e2a20be7d272f66e917a54 Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Thu, 1 Jun 2023 13:49:08 +1200
Subject: [PATCH] Incorporate CSS Box Model into positioning inline ancestors.

---
 Graphics/Layout.hs        | 29 ++++++++++-------
 Graphics/Layout/Box.hs    |  8 +++++
 Graphics/Layout/Inline.hs | 65 +++++++++++++++++++++++++++++++--------
 3 files changed, 79 insertions(+), 23 deletions(-)

diff --git a/Graphics/Layout.hs b/Graphics/Layout.hs
index 09b740c..29e1a0c 100644
--- a/Graphics/Layout.hs
+++ b/Graphics/Layout.hs
@@ -30,7 +30,7 @@ import qualified Data.Text.Glyphize as Hb
 import Graphics.Text.Font.Choose (Pattern)
 
 -- | Additional data routed through Balkon.
-type UserData x = ((Font', Int), PaddedBox Length Length, x)
+type UserData m n x = ((Font', Int), PaddedBox m n, x)
 
 -- | A tree of different layout algorithms.
 -- More to come...
@@ -39,15 +39,16 @@ data LayoutItem m n x =
     LayoutFlow x (PaddedBox m n) [LayoutItem m n x]
     -- | A grid or table element.
     | LayoutGrid x (Grid m n) [GridItem] [LayoutItem m n x]
-    -- | Some richtext.
-    | LayoutInline x (Paragraph (UserData x)) PageOptions -- Balkon holds children.
+    -- | Some richtext. (Balkón holds children)
+    | LayoutInline x (Paragraph (UserData m n x)) PageOptions
     -- | Results laying out richtext, has fixed width.
     -- Generated from `LayoutInline` for the sake of pagination.
-    | LayoutInline' x (ParagraphLayout (UserData x)) PageOptions
+    | LayoutInline' x (ParagraphLayout (UserData m n x)) PageOptions
     -- | A branch with constant bounding box.
+    -- Generated from `LayoutInline` when attaching position info.
     | LayoutConst x (PaddedBox m n) [LayoutItem m n x]
     -- | Children of a `LayoutInline` or `LayoutInline'`.
-    | LayoutSpan (FragmentTree (UserData x))
+    | LayoutSpan (FragmentTree (UserData m n x))
 -- | An empty box.
 nullLayout :: (PropertyParser x, Zero m, Zero n) => LayoutItem m n x
 nullLayout = LayoutFlow temp zero []
@@ -190,13 +191,16 @@ boxWidth parent (LayoutGrid val self cells childs) = LayoutGrid val self' cells'
     outerwidth = inline $ size parent
     widths = sizeTrackMaxs (inline $ size parent) $ inline self
 boxWidth parent (LayoutInline val (Paragraph a b c d) paging) =
-    LayoutInline val (Paragraph a b c d { paragraphMaxWidth = round width }) paging
+    LayoutInline val (paragraphMap (mapX' $ lowerLength width) $
+        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 (LayoutInline' a b c) =
+    LayoutInline' a (layoutMap (mapX' $ lowerLength $ B.inline $ B.size p) 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'
+boxWidth parent (LayoutSpan self') =
+    LayoutSpan $ treeMap (mapX' $ lowerLength $ width parent) self'
 
 -- | Update a (sub)tree to compute & cache ideal legible height.
 boxNatHeight :: Double -> LayoutItem Length Double x -> LayoutItem Length Double x
@@ -289,12 +293,15 @@ boxHeight parent (LayoutGrid val self cells0 childs) = LayoutGrid val self' cell
     lowerSize (Left x) = Left $ lowerLength width x
     lowerSize (Right x) = Right x
     width = inline $ size parent
-boxHeight _ (LayoutInline val self' paging) = LayoutInline val self' paging
-boxHeight _ (LayoutInline' val self' paging) = LayoutInline' val self' paging
+boxHeight p (LayoutInline val self' paging) =
+    LayoutInline val (paragraphMap (mapY' $ lowerLength $ width p) self') paging
+boxHeight p (LayoutInline' val self' paging) =
+    LayoutInline' val (layoutMap (mapY' $ lowerLength $ width p) 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'
+boxHeight p (LayoutSpan self') =
+    LayoutSpan $ treeMap (mapY' $ lowerLength $ width p) self'
 
 -- | Split a (sub)tree to fit within max-height.
 -- May take full page height into account.
diff --git a/Graphics/Layout/Box.hs b/Graphics/Layout/Box.hs
index ca624fb..f7aaaa6 100644
--- a/Graphics/Layout/Box.hs
+++ b/Graphics/Layout/Box.hs
@@ -5,6 +5,7 @@ module Graphics.Layout.Box(Border(..), mapX, mapY,
         Size(..), mapSizeX, mapSizeY,
         PaddedBox(..), zeroBox, lengthBox, mapX', mapY',
         width, height, minWidth, minHeight, maxWidth, maxHeight,
+        leftSpace, rightSpace, topSpace, bottomSpace, hSpace, vSpace,
         Length(..), mapAuto, lowerLength, Zero(..), CastDouble(..)) where
 
 -- | Amount of space surrounding the box.
@@ -110,6 +111,13 @@ maxWidth PaddedBox {..} = left margin + left border + left padding +
 maxHeight PaddedBox {..} = top margin + top border + top padding +
     block max + bottom padding + bottom border + bottom margin
 
+leftSpace PaddedBox {..} = left margin + left border + left padding
+rightSpace PaddedBox {..} = right margin + right border + right padding
+topSpace PaddedBox {..} = top margin + top border + top padding
+bottomSpace PaddedBox {..} = bottom margin + bottom border + bottom padding
+hSpace self = leftSpace self + rightSpace self
+vSpace self = topSpace self + bottomSpace self
+
 -- | A partially-computed length value.
 data Length = Pixels Double -- ^ Absolute number of device pixels.
         | Percent Double -- ^ Multiplier by container width.
diff --git a/Graphics/Layout/Inline.hs b/Graphics/Layout/Inline.hs
index 49fc39b..b27aec4 100644
--- a/Graphics/Layout/Inline.hs
+++ b/Graphics/Layout/Inline.hs
@@ -4,11 +4,11 @@
 module Graphics.Layout.Inline(inlineMinWidth, inlineMin, inlineNatWidth, inlineHeight,
     inlineSize, inlineChildren, layoutSize, layoutChildren, positionChildren,
     fragmentSize, fragmentSize', fragmentPos, FragmentTree(..),
-    positionSubtree, subtreeInner) where
+    positionSubtree, subtreeInner, paragraphMap, layoutMap, treeMap) where
 
 import Data.Text.ParagraphLayout.Rich (Paragraph(..), ParagraphOptions(..),
                                 Fragment(..), ParagraphLayout(..), AncestorBox(..),
-                                layoutRich)
+                                layoutRich, InnerNode(..), Box(..), RootNode(..))
 import Data.Text.ParagraphLayout.Rect (Rect(..),
                                        width, height, x_max, x_min, y_min, y_max)
 import Data.Text.Internal (Text(..))
@@ -16,10 +16,11 @@ import qualified Data.Text as Txt
 import Data.Char (isSpace)
 import Data.Int (Int32)
 
-import Graphics.Layout.Box (PaddedBox, Length, Size(..), CastDouble(..), fromDouble)
+import Graphics.Layout.Box hiding (min, max, width, height)
 import Graphics.Layout.CSS.Font (Font', hbUnit)
 
 -- | Convert from Harfbuzz units to device pixels as a Double
+hbScale :: Int32 -> Double
 hbScale = (/hbUnit) . fromIntegral
 -- | Convert from Harfbuzz units to device pixels as a Double or Length.
 c :: CastDouble a => Int32 -> a
@@ -61,23 +62,63 @@ layoutRich' :: Paragraph a -> Int32 -> Rect Int32
 layoutRich' (Paragraph a b c d) width =
     paragraphRect $ layoutRich $ Paragraph a b c d { paragraphMaxWidth = width }
 
+-- | Apply an operation to the 2nd field of the paragraph's userdata,
+-- for it's entire subtree.
+paragraphMap :: (b -> b') -> Paragraph (a, b, c) -> Paragraph (a, b', c)
+paragraphMap cb (Paragraph a b (RootBox c) d) =
+    Paragraph a b (RootBox $ inner c) d
+  where
+    inner (Box childs opts) = flip Box opts $ map inner' childs
+    inner' (InlineBox (e, f, g) child opts) =
+        InlineBox (e, cb f, g) (inner child) opts
+    inner' (TextSequence (e, f, g) leaf) = TextSequence (e, cb f, g) leaf
+
+-- | Apply an operation to the 2nd field of a laid-out paragraph's userdata,
+-- for it's entire subtree.
+layoutMap :: (b -> b') -> ParagraphLayout (a, b, c) -> ParagraphLayout (a, b', c)
+layoutMap cb (ParagraphLayout a b) = ParagraphLayout a $ map inner b
+  where
+    inner self@Fragment { fragmentUserData = (a, b, c) } = self {
+        fragmentUserData = (a, cb b, c),
+        fragmentAncestorBoxes = map inner' $ fragmentAncestorBoxes self
+      }
+    inner' self@AncestorBox { boxUserData = (a, b, c) } = self {
+        boxUserData = (a, cb b, c)
+      }
+
+-- | Apply an operation to the 2nd field of the tree extracted from a laid-out
+-- paragraph, for all nodes.
+treeMap :: (b -> b') -> FragmentTree (a, b, c) -> FragmentTree (a, b', c)
+treeMap cb (Branch self@AncestorBox { boxUserData = (a, b, c) } childs) =
+    Branch self { boxUserData = (a, cb b, c) } $ map (treeMap cb) childs
+treeMap cb (Leaf self@Fragment { fragmentUserData = (a, b, c) }) =
+    Leaf self { fragmentUserData = (a, cb b, c), fragmentAncestorBoxes = [] }
+
 -- | Retrieve the rect for a fragment & convert to CatTrap types.
 fragmentSize :: (CastDouble x, CastDouble y) =>
-        FragmentTree (a, PaddedBox Length Length, c) -> Size x y
+        FragmentTree (a, PaddedBox x y, 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 :: (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))
-            ((y_max a `max` y_max b) - (y_min a `min` x_min b))
+treeRect (Branch AncestorBox { boxUserData = (_, box', _)} childs) =
+        foldr unionRect (Rect 0 0 0 0) $ map treeRect childs
+    where
+        unionRect a b = Rect
+            (x_min a `min` x_min b - leftSpace box)
+            (y_min a `min` y_min b - topSpace box)
+            (x_max a `max` x_max b - x_min a `min` x_min b + hSpace box)
+            (y_max a `max` y_max b - y_min a `min` x_min b + vSpace box)
+        box :: PaddedBox Int32 Int32
+        box = mapX' unscale $ mapY' unscale box'
+        unscale :: CastDouble x => x -> Int32
+        unscale = floor . (*hbUnit) . toDouble
 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, PaddedBox Length Length, c) -> Size x x
+fragmentSize' :: CastDouble x => FragmentTree (a, PaddedBox x x, c) -> Size x x
 fragmentSize' = fragmentSize -- Work around for typesystem.
 -- | Retrieve the position of a fragment.
 fragmentPos :: (Double, Double) -> Fragment a -> (Double, Double)
@@ -126,9 +167,9 @@ reconstructTree' frags@(Fragment {
     sameBranch Fragment { fragmentAncestorBoxes = [] } = False
 reconstructTree' [] = []
 
-positionSubtree :: (Double, Double) ->
-        FragmentTree (a, PaddedBox Length Length, c) ->
-        FragmentTree (a, PaddedBox Length Length, ((Double, Double), c))
+positionSubtree :: (CastDouble m, CastDouble n) => (Double, Double) ->
+        FragmentTree (a, PaddedBox m n, c) ->
+        FragmentTree (a, PaddedBox m n, ((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
-- 
2.30.2