@@ 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,
@@ 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
@@ 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"]
+ ]