From e8a4642ae31d8fe00225961e96817c5538972e41 Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Mon, 29 May 2023 16:33:55 +1200
Subject: [PATCH] Reconstruct inline tree.

---
 Graphics/Layout.hs            |  9 +++----
 Graphics/Layout/Box.hs        |  4 +--
 Graphics/Layout/CSS.hs        | 17 ++++++------
 Graphics/Layout/CSS/Length.hs |  3 +++
 Graphics/Layout/Inline.hs     | 51 +++++++++++++++++++++++++++++------
 app/Main.hs                   |  5 ++--
 6 files changed, 64 insertions(+), 25 deletions(-)

diff --git a/Graphics/Layout.hs b/Graphics/Layout.hs
index f79d205..d0cfa6a 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', PaddedBox Length Length, x)
+type UserData x = ((Font', Int), PaddedBox Length Length, x)
 
 -- | A tree of different layout algorithms.
 -- More to come...
@@ -45,7 +45,7 @@ data LayoutItem m n x =
     -- Generated from `LayoutInline` for the sake of pagination.
     | LayoutInline' x (ParagraphLayout (UserData x)) PageOptions
     -- | Children of a `LayoutInline` or `LayoutInline'`.
-    | LayoutSpan (Fragment (UserData x))
+    | LayoutSpan (FragmentTree (UserData x))
 -- | An empty box.
 nullLayout :: (PropertyParser x, Zero m, Zero n) => LayoutItem m n x
 nullLayout = LayoutFlow temp zero []
@@ -82,7 +82,7 @@ layoutGetInner (LayoutFlow ret _ _) = ret
 layoutGetInner (LayoutGrid ret _ _ _) = ret
 layoutGetInner (LayoutInline ret _ _) = ret
 layoutGetInner (LayoutInline' ret _ _) = ret
-layoutGetInner (LayoutSpan Fragment { fragmentUserData = (_, _, ret) }) = ret
+layoutGetInner (LayoutSpan x) = subtreeInner x
 
 -- | map-ready wrapper around `setCellBox` sourcing from a child node.
 setCellBox' (child, cell) = setCellBox cell $ layoutGetBox child
@@ -334,8 +334,7 @@ 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 (LayoutSpan self@(Fragment (a, b, c) d _ f g h)) =
-    LayoutSpan $ Fragment (a, b, (pos, c)) d [] f g h -- No children...
+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)]
diff --git a/Graphics/Layout/Box.hs b/Graphics/Layout/Box.hs
index bdd0dbe..ca624fb 100644
--- a/Graphics/Layout/Box.hs
+++ b/Graphics/Layout/Box.hs
@@ -10,7 +10,7 @@ module Graphics.Layout.Box(Border(..), mapX, mapY,
 -- | Amount of space surrounding the box.
 data Border m n = Border {
     top :: m, bottom :: m, left :: n, right :: n
-}
+} deriving Eq
 -- | Convert horizontal spacing via given callback.
 mapX :: (n -> nn) -> Border m n -> Border m nn
 -- | Convert vertical spacing via given callback.
@@ -44,7 +44,7 @@ data PaddedBox m n = PaddedBox {
     border :: Border m n,
     -- | The amount of space between the border & anything else.
     margin :: Border m n
-}
+} deriving Eq
 -- | An empty box, takes up nospace onscreen.
 zeroBox :: PaddedBox Double Double
 zeroBox = PaddedBox {
diff --git a/Graphics/Layout/CSS.hs b/Graphics/Layout/CSS.hs
index c9249cb..4a1e504 100644
--- a/Graphics/Layout/CSS.hs
+++ b/Graphics/Layout/CSS.hs
@@ -475,17 +475,17 @@ finalizeChilds root parent style' childs@(child:childs')
           }:blocks)) -> let (inlines', blocks') = spanInlines tail
             in (inlines ++ inlines', blocks' ++ blocks)
         ret -> ret
-    flattenTree0 childs = RootBox $ Box (map (flattenTree parent) childs) $
-        flip applyFontInline parent $ txtOpts style'
-    flattenTree p StyleTree { children = child@(_:_), style = self } =
-        InlineBox (f, finalizeBox self f, inner self)
-            (Box (map (flattenTree f) child)
+    flattenTree0 childs = RootBox $ Box (map (flattenTree parent) $
+        enumerate childs) $ flip applyFontInline parent $ txtOpts style'
+    flattenTree p (i, StyleTree { children = child@(_:_), style = self }) =
+        InlineBox ((f, i), finalizeBox self f, inner self)
+            (Box (map (flattenTree f) $ enumerate child)
                 $ flip applyFontInline f $ txtOpts self)
             defaultBoxOptions -- Fill in during layout.
           where f = pattern2font (font self) (font' self) p root
-    flattenTree f StyleTree {style=self@CSSBox {inlineStyles=CSSInline txt _}} =
-        InlineBox (f, finalizeBox self f, inner self)
-            (Box [TextSequence (f, zero, inherit $ inner self) txt] $
+    flattenTree f (i,StyleTree {style=self@CSSBox {inlineStyles=CSSInline txt _}})
+        = InlineBox ((f, i), finalizeBox self f, inner self)
+            (Box [TextSequence ((f, 0), zero, inherit $ inner self) txt] $
                 flip applyFontInline f $ txtOpts self)
             defaultBoxOptions -- Fill in during layout.
     finalizeParagraph (RootBox (Box [TextSequence _ txt] _))
@@ -495,6 +495,7 @@ finalizeChilds root parent style' childs@(child:childs')
             paragraphLineHeight = Absolute $ toEnum $ fromEnum
                     (lineheight parent * hbUnit)
           }
+    enumerate = zip $ enumFrom 0
 finalizeChilds _ _ _ [] = []
 
 -- | Desugar most units, possibly in reference to given font.
diff --git a/Graphics/Layout/CSS/Length.hs b/Graphics/Layout/CSS/Length.hs
index cf735c1..4517040 100644
--- a/Graphics/Layout/CSS/Length.hs
+++ b/Graphics/Layout/CSS/Length.hs
@@ -106,3 +106,6 @@ data Font' = Font' {
     -- | How many device pixels in a CSS px?
     scale :: Double
 }
+
+instance Eq Font' where
+    a == b = pattern a == pattern b
diff --git a/Graphics/Layout/Inline.hs b/Graphics/Layout/Inline.hs
index 472f86d..e1c8121 100644
--- a/Graphics/Layout/Inline.hs
+++ b/Graphics/Layout/Inline.hs
@@ -3,10 +3,12 @@
 -- wraps Balkón for the actual logic.
 module Graphics.Layout.Inline(inlineMinWidth, inlineMin, inlineNatWidth, inlineHeight,
     inlineSize, inlineChildren, layoutSize, layoutChildren, positionChildren,
-    fragmentSize, fragmentSize', fragmentPos) where
+    fragmentSize, fragmentSize', fragmentPos, FragmentTree(..),
+    positionSubtree, subtreeInner) where
 
 import Data.Text.ParagraphLayout.Rich (Paragraph(..), ParagraphOptions(..),
-                                Fragment(..), ParagraphLayout(..), layoutRich)
+                                Fragment(..), ParagraphLayout(..), AncestorBox(..),
+                                layoutRich)
 import Data.Text.ParagraphLayout.Rect (Rect(..), width, height, x_min, y_min)
 import Data.Text.Internal (Text(..))
 import qualified Data.Text as Txt
@@ -42,7 +44,7 @@ inlineSize :: (CastDouble x, CastDouble y) => Paragraph a -> Size x y
 inlineSize self = layoutSize $ layoutRich self
 -- | Retrieve children out of some richtext,
 -- associating given userdata with them.
-inlineChildren :: Paragraph a -> [Fragment a]
+inlineChildren :: Eq a => Paragraph a -> [FragmentTree a]
 inlineChildren self = layoutChildren $ layoutRich self
 
 -- | Retrieve a laid-out paragraph's rect & convert to CatTrap types.
@@ -50,8 +52,8 @@ layoutSize :: (CastDouble x, CastDouble y) => ParagraphLayout a -> Size x y
 layoutSize self = Size (c $ width r) (c $ height r)
   where r = paragraphRect self
 -- | Retrieve a laid-out paragraph's children & associate with given userdata.
-layoutChildren :: ParagraphLayout a -> [Fragment a]
-layoutChildren self = paragraphFragments self -- TODO: Extract tree...
+layoutChildren :: Eq a => ParagraphLayout a -> [FragmentTree a]
+layoutChildren self = reconstructTree self
 
 -- | Layout a paragraph at given width & retrieve resulting rect.
 layoutRich' :: Paragraph a -> Int32 -> Rect Int32
@@ -59,12 +61,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) => Fragment a -> Size x y
-fragmentSize self = Size (c $ width r) (c $ height r)
+fragmentSize :: (CastDouble x, CastDouble y) => FragmentTree a -> Size x y
+fragmentSize (Branch _ _) = Size (c 0) (c 0) -- FIXME
+fragmentSize (Leaf self) = Size (c $ width r) (c $ height r)
     where r = fragmentRect self
 -- | Variant of `fragmentSize` asserting to the typesystem that both fields
 -- of the resulting `Size` are of the same type.
-fragmentSize' :: CastDouble x => Fragment a -> Size x x
+fragmentSize' :: CastDouble x => FragmentTree a -> Size x x
 fragmentSize' = fragmentSize -- Work around for typesystem.
 -- | Retrieve the position of a fragment.
 fragmentPos :: (Double, Double) -> Fragment a -> (Double, Double)
@@ -79,3 +82,35 @@ positionChildren pos self = self {
     paragraphFragments = [Fragment (a, b, (fragmentPos pos frag, c)) d [] f g h
             | frag@(Fragment (a, b, c) d _ f g h) <- paragraphFragments self]
   }
+
+data FragmentTree x = Branch (AncestorBox x) [FragmentTree x]
+    | Leaf (Fragment x)
+
+reconstructTree :: Eq x => ParagraphLayout x -> [FragmentTree x]
+reconstructTree ParagraphLayout { paragraphFragments = frags } =
+    reconstructTree' [frag {
+            fragmentAncestorBoxes = reverse $ fragmentAncestorBoxes frag
+        } | frag <- frags]
+reconstructTree' :: Eq x => [Fragment x] -> [FragmentTree x]
+reconstructTree' (self@Fragment { fragmentAncestorBoxes = [] }:frags) =
+    Leaf self:reconstructTree' frags
+reconstructTree' frags@(Fragment { fragmentAncestorBoxes = branch:_ }:_) =
+    Branch branch (reconstructTree' [ child { fragmentAncestorBoxes = ancestors }
+            | child@Fragment { fragmentAncestorBoxes = _:ancestors } <- childs])
+        :reconstructTree' sibs
+  where
+    (childs, sibs) = span sameBranch frags
+    sameBranch Fragment { fragmentAncestorBoxes = branch':_ } = branch == branch'
+    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) =
+    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)) =
+    Leaf (Fragment (a, b, (pos, c)) d [] f g h)
+subtreeInner :: FragmentTree (a, b, c) -> c
+subtreeInner (Branch AncestorBox { boxUserData = (_, _, ret) } _) = ret
+subtreeInner (Leaf Fragment { fragmentUserData = (_, _, ret) }) = ret
diff --git a/app/Main.hs b/app/Main.hs
index 330c722..bcb3e30 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -72,13 +72,14 @@ applyStyle parent style (X.Attr (X.QName name _ _) val) =
     fromMaybe style $ longhand parent style (Txt.pack name) $
         filter (/= Whitespace) $ tokenize $ Txt.pack val
 
-data Nil = Nil
+data Nil = Nil deriving Eq
 instance PropertyParser Nil where
     temp = Nil
     inherit _ = Nil
     longhand _ _ _ _ = Nothing
 
-renderDisplay :: GLuint -> LayoutItem Double Double ((Double, Double), a) -> IO ()
+renderDisplay :: Eq a => GLuint -> LayoutItem Double Double ((Double, Double), a)
+        -> IO ()
 renderDisplay shader display = do
     let ((x, y), _) = layoutGetInner display
     let box = layoutGetBox display
-- 
2.30.2