From 547bbaac70f5801bf106ec771019a3672404efe3 Mon Sep 17 00:00:00 2001 From: Jaro Date: Tue, 9 May 2023 18:32:32 +0200 Subject: [PATCH] Implement finding box edges. --- balkon.cabal | 2 + .../ParagraphLayout/Internal/ApplyBoxes.hs | 147 ++++++++++++++ .../Internal/ApplyBoxesSpec.hs | 181 ++++++++++++++++++ 3 files changed, 330 insertions(+) create mode 100644 src/Data/Text/ParagraphLayout/Internal/ApplyBoxes.hs create mode 100644 test/Data/Text/ParagraphLayout/Internal/ApplyBoxesSpec.hs diff --git a/balkon.cabal b/balkon.cabal index 72d5e69..41fb4ad 100644 --- a/balkon.cabal +++ b/balkon.cabal @@ -104,6 +104,7 @@ library balkon-internal -- Modules exported to tests and to the public part of the library. exposed-modules: + Data.Text.ParagraphLayout.Internal.ApplyBoxes, Data.Text.ParagraphLayout.Internal.BiDiReorder, Data.Text.ParagraphLayout.Internal.BoxOptions, Data.Text.ParagraphLayout.Internal.Break, @@ -179,6 +180,7 @@ test-suite balkon-test other-modules: Data.Text.ParagraphLayout.FontLoader, + Data.Text.ParagraphLayout.Internal.ApplyBoxesSpec, Data.Text.ParagraphLayout.Internal.BiDiReorderSpec, Data.Text.ParagraphLayout.Internal.BreakSpec, Data.Text.ParagraphLayout.Internal.LinePaginationSpec, diff --git a/src/Data/Text/ParagraphLayout/Internal/ApplyBoxes.hs b/src/Data/Text/ParagraphLayout/Internal/ApplyBoxes.hs new file mode 100644 index 0000000..5b90659 --- /dev/null +++ b/src/Data/Text/ParagraphLayout/Internal/ApplyBoxes.hs @@ -0,0 +1,147 @@ +-- | Algorithm for finding box edges. +module Data.Text.ParagraphLayout.Internal.ApplyBoxes + ( WithBoxes (..) + , applyBoxes + ) +where + +import Data.List.NonEmpty (NonEmpty ((:|)), (<|)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Text.Glyphize (Direction (DirLTR, DirRTL)) + +import Data.Text.ParagraphLayout.Internal.ResolvedBox +import Data.Text.ParagraphLayout.Internal.ResolvedSpan +import Data.Text.ParagraphLayout.Internal.WithSpan + +-- | Wrapper containing the original input value, +-- with added information about the box edges that it touches. +data WithBoxes d a = WithBoxes + + { leftInBoxes :: [ResolvedBox d] + -- ^ Boxes whose left edge this item touches. + + , unwrap :: a + -- ^ The original wrapped value. + + , rightInBoxes :: [ResolvedBox d] + -- ^ Boxes whose right edge this item touches. + + } + +type Boxed d a = WithBoxes d (WithSpan d a) + +-- | Determine which horizontal items are the leftmost and which are the +-- rightmost within their ancestor boxes. +applyBoxes + :: [ResolvedBox d] + -- ^ Boxes open on a preceding line. Their start edge will be omitted. + -> [ResolvedBox d] + -- ^ Boxes open on a following line. Their end edge will be omitted. + -> NonEmpty (WithSpan d a) + -- ^ Box items on a given line. Must be ordered from left to right. + -> NonEmpty (Boxed d a) + -- ^ Box items with added information about box edges. +applyBoxes prevOpen nextOpen pfs = + foldr (applyBox prevOpen nextOpen) items boxes + where + boxes = allBoxes pfs + items = fmap initBoxes pfs + +-- | Wrap an item in a minimal structure to be filled by the algorithm. +initBoxes :: WithSpan d a -> Boxed d a +initBoxes (WithSpan rs pf) = WithBoxes + { leftInBoxes = [] + , unwrap = WithSpan rs pf + , rightInBoxes = [] + } + +-- | Determine which horizontal item is the leftmost and which is the +-- rightmost within the given ancestor box. +applyBox + :: [ResolvedBox d] + -- ^ Boxes open on a preceding line. Their start edge will be omitted. + -> [ResolvedBox d] + -- ^ Boxes open on a following line. Their end edge will be omitted. + -> ResolvedBox d + -- ^ The box whose edges are to be determined. + -> NonEmpty (Boxed d a) + -- ^ Box items with partial information about box edges. + -> NonEmpty (Boxed d a) + -- ^ Box items with added information about edges of the given box. +applyBox prevOpen nextOpen box = + applyBoxEnd nextOpen box . applyBoxStart prevOpen box + +-- | Determine which horizontal item, if any, is the startmost +-- within the given ancestor box. +applyBoxStart + :: [ResolvedBox d] + -- ^ Boxes open on a preceding line. Their start edge will be omitted. + -> ResolvedBox d + -- ^ Box whose start edge should be found. + -> NonEmpty (Boxed d a) + -- ^ Box items with partial information about box edges. + -> NonEmpty (Boxed d a) + -- ^ Box items with added information about the start edge of the given box. +applyBoxStart prevOpen box items + | box `elem` prevOpen = items + | otherwise = case boxDirection box of + DirLTR -> pickBoxLeft box items + DirRTL -> pickBoxRight box items + _ -> items + +-- | Determine which horizontal item, if any, is the endmost +-- within the given ancestor box. +applyBoxEnd + :: [ResolvedBox d] + -- ^ Boxes open on a following line. Their end edge will be omitted. + -> ResolvedBox d + -- ^ Box whose end edge should be found. + -> NonEmpty (Boxed d a) + -- ^ Box items with partial information about box edges. + -> NonEmpty (Boxed d a) + -- ^ Box items with added information about the end edge of the given box. +applyBoxEnd nextOpen box items + | box `elem` nextOpen = items + | otherwise = case boxDirection box of + DirLTR -> pickBoxRight box items + DirRTL -> pickBoxLeft box items + _ -> items + +-- | Pick the leftmost item on the line and apply the left edge +-- of the given box to it. This assumes that the box does not have +-- a left edge on any other line. +pickBoxLeft :: ResolvedBox d -> NonEmpty (Boxed d a) -> NonEmpty (Boxed d a) +pickBoxLeft box items = updateFirst (inBox box) (addBoxLeft box) items + +-- | Pick the rightmost item on the line and apply the right edge +-- of the given box to it. This assumes that the box does not have +-- a right edge on any other line. +pickBoxRight :: ResolvedBox d -> NonEmpty (Boxed d a) -> NonEmpty (Boxed d a) +pickBoxRight box items = updateLast (inBox box) (addBoxRight box) items + +-- | Determine if the given item is contained by the given box. +inBox :: ResolvedBox d -> Boxed d a -> Bool +inBox box item = box `elem` boxesOf item + where + boxesOf (WithBoxes _ (WithSpan rs _) _) = spanBoxes rs + +-- | Apply the left edge of the given box to the given item. +addBoxLeft :: ResolvedBox d -> Boxed d a -> Boxed d a +addBoxLeft box item = item { leftInBoxes = leftInBoxes item `union` [box] } + +-- | Apply the right edge of the given box to the given item. +addBoxRight :: ResolvedBox d -> Boxed d a -> Boxed d a +addBoxRight box item = item { rightInBoxes = rightInBoxes item `union` [box] } + +-- | Update the first item matching the given predicate, +-- or fail if none is found. +updateFirst :: (a -> Bool) -> (a -> a) -> NonEmpty a -> NonEmpty a +updateFirst predicate updateFunc (x :| xs) + | predicate x = (updateFunc x) :| xs + | otherwise = x <| updateFirst predicate updateFunc (NonEmpty.fromList xs) + +-- | Update the last item matching the given predicate, +-- or fail if none is found. +updateLast :: (a -> Bool) -> (a -> a) -> NonEmpty a -> NonEmpty a +updateLast predicate updateFunc list = + NonEmpty.reverse $ updateFirst predicate updateFunc $ NonEmpty.reverse list diff --git a/test/Data/Text/ParagraphLayout/Internal/ApplyBoxesSpec.hs b/test/Data/Text/ParagraphLayout/Internal/ApplyBoxesSpec.hs new file mode 100644 index 0000000..c20c49c --- /dev/null +++ b/test/Data/Text/ParagraphLayout/Internal/ApplyBoxesSpec.hs @@ -0,0 +1,181 @@ +module Data.Text.ParagraphLayout.Internal.ApplyBoxesSpec (spec) where + +import Data.List.NonEmpty (NonEmpty, fromList, toList) +import Data.Text (empty) +import Data.Text.Glyphize (Direction (DirLTR, DirRTL)) + +import Test.Hspec +import Data.Text.ParagraphLayout.Internal.ApplyBoxes +import Data.Text.ParagraphLayout.Internal.BoxOptions +import Data.Text.ParagraphLayout.Internal.ResolvedBox +import Data.Text.ParagraphLayout.Internal.ResolvedSpan +import Data.Text.ParagraphLayout.Internal.TextOptions +import Data.Text.ParagraphLayout.Internal.WithSpan + +trivialBox :: d -> Int -> Direction -> ResolvedBox d +trivialBox d i dir = ResolvedBox d i defaultBoxOptions dir + +trivialSpan :: d -> Int -> Direction -> [ResolvedBox d] -> ResolvedSpan d +trivialSpan d i dir bs = ResolvedSpan + { spanUserData = d + , spanIndex = i + , spanOffsetInParagraph = 0 + , spanText = empty + , spanTextOptions = defaultTextOptions dir + , spanBoxes = bs + , spanLineBreaks = [] + , spanCharacterBreaks = [] + } + +-- | Wrap nothing with the given span, since the algorithm expects `WithSpan`. +wrapNothing :: ResolvedSpan d -> WithSpan d () +wrapNothing rs = WithSpan rs () + +buildFrags :: [ResolvedSpan d] -> NonEmpty (WithSpan d ()) +buildFrags spans = fmap wrapNothing $ fromList spans + +-- | Record for easy comparison of test output. +data OutputFragment = OutputFragment + { spanData :: String + , leftBoxesData :: [String] + , rightBoxesData :: [String] + } + deriving (Show, Eq) + +toOutput :: WithBoxes String (WithSpan String ()) -> OutputFragment +toOutput a = OutputFragment + { spanData = case unwrap a of + WithSpan rs _ -> spanUserData rs + , leftBoxesData = map boxUserData $ leftInBoxes a + , rightBoxesData = map boxUserData $ rightInBoxes a + } + +runTest + :: [ResolvedBox String] + -> [ResolvedSpan String] + -> [ResolvedBox String] + -> [OutputFragment] +runTest prevOpen spans nextOpen = + map toOutput $ toList $ applyBoxes prevOpen nextOpen (buildFrags spans) + +spec :: Spec +spec = do + + describe "applyBoxes" $ do + + it "handles case without boxes" $ do + let + spans = + [ trivialSpan "A" 0 DirLTR [] + , trivialSpan "B" 1 DirLTR [] + ] + + runTest [] spans [] `shouldBe` + [ OutputFragment "A" [] [] + , OutputFragment "B" [] [] + ] + + it "handles discrete boxes" $ do + let + box1 = trivialBox "box1" 0 DirRTL + box2 = trivialBox "box2" 1 DirRTL + spans = + [ trivialSpan "Z" 0 DirRTL [box2] + , trivialSpan "Y" 1 DirRTL [box1] + , trivialSpan "X" 2 DirRTL [box1] + , trivialSpan "W" 3 DirRTL [] + ] + + runTest [] spans [] `shouldBe` + [ OutputFragment "Z" ["box2"] ["box2"] + , OutputFragment "Y" ["box1"] [] + , OutputFragment "X" [] ["box1"] + , OutputFragment "W" [] [] + ] + + it "handles deeply nested boxes" $ do + let + box1 = trivialBox "box1" 0 DirLTR + box2 = trivialBox "box2" 1 DirRTL + box3 = trivialBox "box3" 2 DirRTL + box4 = trivialBox "box4" 3 DirLTR + box5 = trivialBox "box5" 4 DirRTL + spans = + [ trivialSpan "A" 0 DirRTL [box3, box2, box1] + , trivialSpan "B" 1 DirRTL [box5, box4, box3, box2, box1] + ] + + runTest [] spans [] `shouldBe` + [ OutputFragment "A" + ["box3", "box2", "box1"] + [] + , OutputFragment "B" + ["box5", "box4"] + ["box5", "box4", "box3", "box2", "box1"] + ] + + it "omits left edge of LTR box crossing previous line" $ do + let + box = trivialBox "box" 0 DirLTR + spans = [trivialSpan "." 0 DirLTR [box]] + + runTest [box] spans [] `shouldBe` [OutputFragment "." [] ["box"]] + + it "omits right edge of RTL box crossing previous line" $ do + let + box = trivialBox "box" 0 DirRTL + spans = [trivialSpan "." 0 DirRTL [box]] + + runTest [box] spans [] `shouldBe` [OutputFragment "." ["box"] []] + + it "omits right edge of LTR box crossing next line" $ do + let + box = trivialBox "box" 0 DirLTR + spans = [trivialSpan "." 0 DirLTR [box]] + + runTest [] spans [box] `shouldBe` [OutputFragment "." ["box"] []] + + it "omits left edge of RTL box crossing next line" $ do + let + box = trivialBox "box" 0 DirRTL + spans = [trivialSpan "." 0 DirRTL [box]] + + runTest [] spans [box] `shouldBe` [OutputFragment "." [] ["box"]] + + it "omits both edges of LTR box crossing previous and next line" $ do + let + box = trivialBox "box" 0 DirLTR + spans = [trivialSpan "." 0 DirLTR [box]] + + runTest [box] spans [box] `shouldBe` [OutputFragment "." [] []] + + it "omits both edges of RTL box crossing previous and next line" $ do + let + box = trivialBox "box" 0 DirRTL + spans = [trivialSpan "." 0 DirRTL [box]] + + runTest [box] spans [box] `shouldBe` [OutputFragment "." [] []] + + it "handles complex example" $ do + let + box1 = trivialBox "box1" 0 DirRTL + box2 = trivialBox "box2" 1 DirLTR + box3 = trivialBox "box3" 2 DirLTR + box4 = trivialBox "box4" 3 DirRTL + spans = + [ trivialSpan "A" 0 DirRTL [box1] + , trivialSpan "B" 1 DirLTR [box2, box1] + , trivialSpan "C" 2 DirLTR [box2, box1] + , trivialSpan "D" 3 DirRTL [box3, box2, box1] + , trivialSpan "E" 4 DirLTR [box2, box1] + , trivialSpan "F" 5 DirRTL [box4, box1] + ] + + runTest [box1] spans [box4, box1] `shouldBe` + [ OutputFragment "A" [] [] + , OutputFragment "B" ["box2"] [] + , OutputFragment "C" [] [] + , OutputFragment "D" ["box3"] ["box3"] + , OutputFragment "E" [] ["box2"] + , OutputFragment "F" [] ["box4"] + ] -- 2.30.2