From 48ed1b32e4690e0b26a769be2cb5da5792ddc10a Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Wed, 25 Oct 2023 17:47:59 +1300 Subject: [PATCH] Improve concurrency, release 0.3, & (not in 0.3) better expose text info --- Graphics/Layout.hs | 16 ++++++++++------ Graphics/Layout/Grid.hs | 10 +++++++--- Graphics/Layout/Inline.hs | 14 +++++++++++++- cattrap.cabal | 2 +- 4 files changed, 31 insertions(+), 11 deletions(-) diff --git a/Graphics/Layout.hs b/Graphics/Layout.hs index 1d646f0..e37866a 100644 --- a/Graphics/Layout.hs +++ b/Graphics/Layout.hs @@ -94,11 +94,13 @@ layoutGetInner (LayoutInline' ret _ _) = ret layoutGetInner (LayoutConst ret _ _) = ret layoutGetInner (LayoutSpan x) = treeInner x +fragmentFont x = let (ret, _, _) = treeInner' x in ret + -- | map-ready wrapper around `setCellBox` sourcing from a child node. setCellBox' (child, cell) = setCellBox cell $ layoutGetBox child -- | Update a (sub)tree to compute & cache minimum legible sizes. -boxMinWidth :: (Zero y, CastDouble y) => +boxMinWidth :: (Zero y, CastDouble y, NFData y) => Maybe Double -> LayoutItem y Length x -> LayoutItem y Length x boxMinWidth parent (LayoutFlow val self childs) = LayoutFlow val self' childs' where @@ -125,7 +127,7 @@ 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) => +boxNatWidth :: (Zero y, CastDouble y, NFData y) => Maybe Double -> LayoutItem y Length x -> LayoutItem y Length x boxNatWidth parent (LayoutFlow val self childs) = LayoutFlow val self' childs' where @@ -152,7 +154,8 @@ 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 +boxMaxWidth :: (CastDouble y, Zero y, NFData y) => + PaddedBox a Double -> LayoutItem y Length x -> LayoutItem y Length x boxMaxWidth parent (LayoutFlow val self childs) = LayoutFlow val self' childs' where childs' = parMap' (boxMaxWidth self'') childs @@ -171,8 +174,8 @@ 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 -> - LayoutItem y Double x +boxWidth :: (Zero y, CastDouble y, NFData y) => + PaddedBox b Double -> LayoutItem y Length x -> LayoutItem y Double x boxWidth parent (LayoutFlow val self childs) = LayoutFlow val self' childs' where childs' = parMap' (boxWidth self') childs @@ -399,4 +402,5 @@ glyphsPerFont (LayoutSpan _ font self) = where glyphs = map fromEnum $ map Hb.codepoint $ map fst $ fragmentGlyphs self glyphsPerFont node = M.unionsWith IS.union $ map glyphsPerFont $ layoutGetChilds node -} -parMap' = parMap rseq +parMap' :: NFData b => (a -> b) -> [a] -> [b] +parMap' = parMap rdeepseq diff --git a/Graphics/Layout/Grid.hs b/Graphics/Layout/Grid.hs index 04efdcf..024d561 100644 --- a/Graphics/Layout/Grid.hs +++ b/Graphics/Layout/Grid.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RecordWildCards, OverloadedStrings #-} +{-# LANGUAGE RecordWildCards, OverloadedStrings, DeriveGeneric #-} -- | Sizes grid cells & positions elements to them. module Graphics.Layout.Grid(Grid(..), Track(..), GridItem(..), GridItem'(..), Alignment(..), buildTrack, buildGrid, setCellBox, enumerate, gridItemBox, cellSize, @@ -11,6 +11,8 @@ import Data.List (intersperse) import Graphics.Layout.Box as B import Debug.Trace (trace) +import GHC.Generics (Generic) +import Control.DeepSeq (NFData) -- | An element which positions it's children within a grid. type Grid m n = Size (Track m) (Track n) @@ -40,9 +42,11 @@ data GridItem' = GridItem { minSize :: Double, -- | The maximum aount of space to allocate to this child. natSize :: Double -} +} deriving (Read, Show, Ord, Eq, Generic) +instance NFData GridItem' -- | How to redistribute excess space. -data Alignment = Start | Mid | End +data Alignment = Start | Mid | End deriving (Read, Show, Enum, Ord, Eq, Generic) +instance NFData Alignment -- | Constructs a track with default (to-be-computed) values & given cell sizes. buildTrack :: CastDouble x => [Either x Double] -> Track x diff --git a/Graphics/Layout/Inline.hs b/Graphics/Layout/Inline.hs index 36e5716..d04da46 100644 --- a/Graphics/Layout/Inline.hs +++ b/Graphics/Layout/Inline.hs @@ -3,7 +3,8 @@ -- wraps Balkón for the actual logic. module Graphics.Layout.Inline(paragraphMap, layoutMap, treeMap, inlineMin, inlineSize, inlineChildren, layoutSize, layoutChildren, - treeBox, positionTree, treeInner, FragmentTree(..)) where + treeBox, positionTree, treeInner, treeInner', glyphs, codepoints, + FragmentTree(..)) where import Data.Text.ParagraphLayout.Rich (Paragraph(..), ParagraphOptions(..), Fragment(..), ParagraphLayout(..), AncestorBox(..), @@ -12,7 +13,9 @@ import Data.Text.ParagraphLayout.Rich (Paragraph(..), ParagraphOptions(..), activateBoxSpacing, paragraphSafeWidth) import Data.Text.ParagraphLayout.Rect (Rect(..), width, height, x_max, x_min, y_min, y_max) +import qualified Data.Text.Glyphize as HB import Data.Int (Int32) +import Data.Word (Word32) import Debug.Trace (trace) -- To warn about unexpected branches! import Graphics.Layout.Box hiding (min, max, width, height) @@ -191,6 +194,15 @@ positionTree (x, y) self@(Leaf (Fragment (a, b, c) d _ f g h i)) = treeInner :: FragmentTree (a, b, c) -> c treeInner (Branch AncestorBox { boxUserData = (_, _, ret) } _) = ret treeInner (Leaf Fragment { fragmentUserData = (_, _, ret) }) = ret +treeInner' :: FragmentTree a -> a +treeInner' (Branch self _) = boxUserData self +treeInner' (Leaf self) = fragmentUserData self + +glyphs :: FragmentTree x -> [(HB.GlyphInfo, HB.GlyphPos)] +glyphs (Branch _ _) = [] +glyphs (Leaf self) = fragmentGlyphs self +codepoints :: FragmentTree x -> [Word32] +codepoints self = map HB.codepoint $ map fst $ glyphs self ------ --- Taken from Balkón diff --git a/cattrap.cabal b/cattrap.cabal index 760c408..12e19f7 100644 --- a/cattrap.cabal +++ b/cattrap.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: cattrap -version: 0.2.0.0 +version: 0.3.0.0 synopsis: Lays out boxes according to the CSS Box Model. description: Computes where to place e.g. images, paragraphs, containers, tables, etc onscreen given desired amounts of whitespace. homepage: https://argonaut-constellation.org/ -- 2.30.2