From 44b621fd4ac3e7b372ff0fc7254b524718ace1fd Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Mon, 13 Mar 2023 11:02:11 +1300 Subject: [PATCH] Ensure units are converted correctly between CatTrap & Balkon. --- Graphics/Layout.hs | 74 +++++++++++++++++---------------- Graphics/Layout/Box.hs | 2 - Graphics/Layout/CSS.hs | 5 ++- Graphics/Layout/CSS/Internal.hs | 15 +++---- 4 files changed, 50 insertions(+), 46 deletions(-) diff --git a/Graphics/Layout.hs b/Graphics/Layout.hs index ebb625b..1f1dc15 100644 --- a/Graphics/Layout.hs +++ b/Graphics/Layout.hs @@ -7,14 +7,15 @@ import Graphics.Layout.Box as B import Graphics.Layout.Grid as G import Graphics.Layout.Flow as F import Graphics.Layout.Inline as I +import Graphics.Layout.CSS.Internal (Font') import Data.Maybe (fromMaybe) data LayoutItem m n x = LayoutFlow x (PaddedBox m n) [LayoutItem m n x] | LayoutGrid x (Grid m n) [(GridItem m n, LayoutItem m n x)] - | LayoutInline x Paragraph [x] -- Balkon holds children. - | LayoutSpan x Fragment + | LayoutInline x Font' Paragraph [x] -- Balkon holds children. + | LayoutSpan x Font' Fragment -- More to come... layoutGetBox :: (Zero m, Zero n, CastDouble m, CastDouble n) => @@ -25,21 +26,21 @@ layoutGetBox (LayoutGrid _ self _) = zero { B.size = containerSize self, B.max = containerMax self } -layoutGetBox (LayoutInline _ self _) = zero { - B.min = inlineSize self, B.size = inlineSize self, B.max = inlineSize self +layoutGetBox (LayoutInline _ f self _) = zero { + B.min = inlineSize f self, B.size = inlineSize f self, B.max = inlineSize f self } -layoutGetBox (LayoutSpan _ self) = zero { - B.min = fragmentSize self, B.size = fragmentSize self, B.max = fragmentSize self +layoutGetBox (LayoutSpan _ f self) = zero { + B.min = fragmentSize f self, B.size = fragmentSize f self, B.max = fragmentSize f self } layoutGetChilds (LayoutFlow _ _ ret) = ret layoutGetChilds (LayoutGrid _ _ ret) = map snd ret -layoutGetChilds (LayoutSpan _ _) = [] -layoutGetChilds (LayoutInline _ self vals) = - map (uncurry LayoutSpan) $ inlineChildren vals self +layoutGetChilds (LayoutSpan _ _ _) = [] +layoutGetChilds (LayoutInline _ font self vals) = map inner $ inlineChildren vals self + where inner (val, fragment) = LayoutSpan val font fragment layoutGetInner (LayoutFlow ret _ _) = ret layoutGetInner (LayoutGrid ret _ _) = ret -layoutGetInner (LayoutInline ret _ _) = ret -layoutGetInner (LayoutSpan ret _) = ret +layoutGetInner (LayoutInline ret _ _ _) = ret +layoutGetInner (LayoutSpan ret _ _) = ret setCellBox' (child, cell) = cell { gridItemBox = layoutGetBox child } @@ -72,8 +73,8 @@ boxMinWidth parent (LayoutGrid val self childs) = (GridItem {..}, _) <- childs]) parent zeroBox :: PaddedBox Double Double zeroBox = zero -boxMinWidth _ self@(LayoutInline _ self' _) = (inlineMinWidth self', self) -boxMinWidth _ self@(LayoutSpan _ self') = (B.inline $ fragmentSize' self', self) +boxMinWidth _ self@(LayoutInline _ font self' _) = (inlineMinWidth font self', self) +boxMinWidth _ self@(LayoutSpan _ f self') = (B.inline $ fragmentSize' f self', self) boxNatWidth :: (Zero y, CastDouble y) => Maybe Double -> LayoutItem y Length x -> (Double, LayoutItem y Length x) boxNatWidth parent (LayoutFlow val self childs) = (size', LayoutFlow val self childs') @@ -107,8 +108,8 @@ boxNatWidth parent (LayoutGrid val self childs) = (GridItem {..}, _) <- childs]) parent zeroBox :: PaddedBox Double Double zeroBox = zero -boxNatWidth _ self@(LayoutInline _ self' _) = (inlineNatWidth self', self) -boxNatWidth _ self@(LayoutSpan _ self') = (B.inline $ fragmentSize' self', self) +boxNatWidth _ self@(LayoutInline _ font self' _) = (inlineNatWidth font self', self) +boxNatWidth _ self@(LayoutSpan _ f self') = (B.inline $ fragmentSize' f self', self) boxMaxWidth :: PaddedBox a Double -> LayoutItem y Length x -> (Double, LayoutItem y Length x) boxMaxWidth parent (LayoutFlow val self childs) = (max', LayoutFlow val self' childs) where @@ -119,8 +120,8 @@ boxMaxWidth parent (LayoutGrid val self childs) = where self' = self { containerMax = Size (Pixels max') (block $ containerMax self) } (max', _) = gridMaxWidths parent self $ colBounds self -boxMaxWidth parent self@(LayoutInline _ _ _) = (B.inline $ B.max parent, self) -boxMaxWidth parent self@(LayoutSpan _ self') = (B.inline $ fragmentSize' self', self) +boxMaxWidth parent self@(LayoutInline _ _ _ _) = (B.inline $ B.max parent, self) +boxMaxWidth parent self@(LayoutSpan _ f self') = (B.inline $ fragmentSize' f self', self) boxWidth :: (Zero y, CastDouble y) => PaddedBox b Double -> LayoutItem y Length x -> (Double, LayoutItem y Double x) boxWidth parent (LayoutFlow val self childs) = (size', LayoutFlow val self' childs') @@ -156,11 +157,11 @@ boxWidth parent (LayoutGrid val self childs) = (size', LayoutGrid val self' chil } outerwidth = inline $ size parent (size', widths) = gridWidths parent self $ colBounds self -boxWidth parent (LayoutInline val (Paragraph a b c d) vals) = - (width, LayoutInline val (Paragraph a b c d { paragraphMaxWidth = round width }) vals) +boxWidth parent (LayoutInline val font (Paragraph a b c d) vals) = + (width, LayoutInline val font (Paragraph a b c d { paragraphMaxWidth = round width }) vals) where width = B.inline $ B.size parent -boxWidth parent (LayoutSpan val self') = - (B.inline $ fragmentSize' self', LayoutSpan val self') +boxWidth parent (LayoutSpan val font self') = + (B.inline $ fragmentSize' font self', LayoutSpan val font self') boxNatHeight :: Double -> LayoutItem Length Double x -> (Double, LayoutItem Length Double x) boxNatHeight parent (LayoutFlow val self childs) = (size', LayoutFlow val self' childs') @@ -185,8 +186,8 @@ boxNatHeight parent (LayoutGrid val self childs) = cells = map setCellBox' $ zip childs' $ map fst childs childs' = map snd $ map (boxNatHeight width) $ map snd childs width = inline $ containerSize self -boxNatHeight parent self@(LayoutInline _ self' _) = (inlineHeight parent self', self) -boxNatHeight parent self@(LayoutSpan _ self') = (B.block $ fragmentSize' self', self) +boxNatHeight parent self@(LayoutInline _ font self' _) = (inlineHeight font parent self', self) +boxNatHeight parent self@(LayoutSpan _ font self') = (B.block $ fragmentSize' font self', self) boxMinHeight :: Double -> LayoutItem Length Double x -> (Double, LayoutItem Length Double x) boxMinHeight parent (LayoutFlow val self childs) = (min', LayoutFlow val self' childs') where @@ -213,8 +214,8 @@ boxMinHeight parent (LayoutGrid val self childs) = (min', LayoutGrid val self' c startCol = startCol cell, endCol = endCol cell, alignment = alignment cell } | (cell, _) <- childs] width = inline $ containerSize self -boxMinHeight parent self@(LayoutInline _ self' _) = (inlineHeight parent self', self) -boxMinHeight parent self@(LayoutSpan _ self') = (B.block $ fragmentSize' self', self) +boxMinHeight parent self@(LayoutInline _ font self' _) = (inlineHeight font parent self', self) +boxMinHeight parent self@(LayoutSpan _ font self') = (B.block $ fragmentSize' font self', self) boxMaxHeight :: PaddedBox Double Double -> LayoutItem Length Double x -> (Double, LayoutItem Length Double x) boxMaxHeight parent (LayoutFlow val self childs) = (max', LayoutFlow val self' childs') @@ -243,10 +244,11 @@ boxMaxHeight parent (LayoutGrid val self childs) = (max', LayoutGrid val self' c } (max', heights) = gridMaxHeights parent self $ rowBounds self width = inline $ size parent -boxMaxHeight parent (LayoutInline val self' vals) = - (inlineHeight (B.inline $ B.size parent) self', LayoutInline val self' vals) -boxMaxHeight parent (LayoutSpan val self') = - (B.block $ fragmentSize' self', LayoutSpan val self') +boxMaxHeight parent (LayoutInline val font self' vals) = + (inlineHeight font (B.inline $ B.size parent) self', + LayoutInline val font self' vals) +boxMaxHeight parent (LayoutSpan val font self') = + (B.block $ fragmentSize' font self', LayoutSpan val font self') boxHeight :: PaddedBox Double Double -> LayoutItem Length Double x -> (Double, LayoutItem Double Double x) boxHeight parent (LayoutFlow val self childs) = (size', LayoutFlow val self' childs') @@ -278,9 +280,11 @@ boxHeight parent (LayoutGrid val self childs) = (size', LayoutGrid val self' chi lowerSize (Left x) = Left $ lowerLength width x lowerSize (Right x) = Right x width = inline $ size parent -boxHeight parent (LayoutInline val self' vals) = - (inlineHeight (B.inline $ B.size parent) self', LayoutInline val self' vals) -boxHeight _ (LayoutSpan val self') = (B.block $ fragmentSize' self', LayoutSpan val self') +boxHeight parent (LayoutInline val font self' vals) = + (inlineHeight font (B.inline $ B.size parent) self', + LayoutInline val font self' vals) +boxHeight _ (LayoutSpan val font self') = + (B.block $ fragmentSize' font self', LayoutSpan val font self') boxPosition :: (Double, Double) -> LayoutItem Double Double x -> LayoutItem Double Double ((Double, Double), x) @@ -294,10 +298,10 @@ boxPosition pos@(x, y) (LayoutGrid val self childs) = LayoutGrid (pos, val) self childs' = map recurse $ zip pos' childs recurse ((Size x' y'), (cell, child)) = (cell, boxPosition (x + x', y + y') child) pos' = gridPosition self $ map fst childs -boxPosition pos@(x, y) (LayoutInline val self vals) = - LayoutInline (pos, val) self $ map (\(x, y) -> (fragmentPos pos y, x)) $ +boxPosition pos@(x, y) (LayoutInline val font self vals) = + LayoutInline (pos, val) font self $ map (\(x, y) -> (fragmentPos font pos y, x)) $ inlineChildren vals self -boxPosition pos (LayoutSpan val self) = LayoutSpan (pos, val) self -- No children... +boxPosition pos (LayoutSpan val f self) = LayoutSpan (pos, val) f self -- No children... boxLayout :: PaddedBox Double Double -> LayoutItem Length Length x -> Bool -> LayoutItem Double Double ((Double, Double), x) boxLayout parent self paginate = self8 diff --git a/Graphics/Layout/Box.hs b/Graphics/Layout/Box.hs index 42bd22c..478740c 100644 --- a/Graphics/Layout/Box.hs +++ b/Graphics/Layout/Box.hs @@ -95,8 +95,6 @@ instance (Zero m, Zero n) => Zero (PaddedBox m n) where class CastDouble a where fromDouble :: Double -> a -fromIntegral' :: (Integral a, CastDouble b) => a -> b -fromIntegral' = fromDouble . fromIntegral instance CastDouble Double where fromDouble = id instance CastDouble Length where fromDouble = Pixels diff --git a/Graphics/Layout/CSS.hs b/Graphics/Layout/CSS.hs index fc6d4c4..40b43b0 100644 --- a/Graphics/Layout/CSS.hs +++ b/Graphics/Layout/CSS.hs @@ -193,9 +193,10 @@ finalizeChilds :: PropertyParser x => Font' -> Font' -> [StyleTree (CSSBox x)] - finalizeChilds root parent childs@(child:childs') | isInlineTree childs = -- FIXME propagate display properties, how to handle the hierarchy. - [LayoutInline temp (finalizeParagraph (flattenTree childs) parent) (repeat temp)] + [LayoutInline temp parent (finalizeParagraph (flattenTree childs) parent) + (repeat temp)] | (inlines@(_:_), blocks) <- spanInlines childs = - LayoutInline temp (finalizeParagraph (flattenTree childs) parent) [] + LayoutInline temp parent (finalizeParagraph (flattenTree childs) parent) [] :finalizeChilds root parent blocks | otherwise = finalizeCSS root parent child : finalizeChilds root parent childs' where diff --git a/Graphics/Layout/CSS/Internal.hs b/Graphics/Layout/CSS/Internal.hs index 8c5c438..2beda12 100644 --- a/Graphics/Layout/CSS/Internal.hs +++ b/Graphics/Layout/CSS/Internal.hs @@ -78,14 +78,15 @@ data Font' = Font' { scale :: Double } placeholderFont = Font' Nothing (const 0) (const 0) 0 0 0 0 0 0 0 0 1 -ppem f = fontSize f/scale f +hbScale f = fontSize f*hbUnit +hbUnit = 64 -pattern2hbfont :: Pattern -> Word -> [Variation] -> Font -pattern2hbfont pat ppem variations = createFontWithOptions options face +pattern2hbfont :: Pattern -> Int -> [Variation] -> Font +pattern2hbfont pat scale variations = createFontWithOptions options face where bytes = unsafePerformIO $ B.readFile $ getValue0 "file" pat face = createFace bytes $ toEnum $ fromMaybe 0 $ getValue' "index" pat - options = foldl value2opt defaultFontOptions { optionPPEm = Just (ppem, ppem) } $ + options = foldl value2opt defaultFontOptions { optionScale = Just (scale, scale) } $ normalizePattern pat value2opt opts ("slant", (_, ValueInt x):_) = opts { @@ -113,13 +114,13 @@ pattern2font pat styles parent root = Font' { height' (Just x) = fromIntegral $ HB.height x height' Nothing = fontSize' lineheight' | snd (cssLineheight styles) == "normal", - Just extents <- fontHExtents font' = (fromIntegral $ lineGap extents)/ppem + Just extents <- fontHExtents font' = (fromIntegral $ lineGap extents)/scale' | otherwise = lowerLength' (cssLineheight styles) parent fontSize' = lowerLength' (cssFontSize styles) parent lowerLength' a = lowerLength (fontSize parent) . finalizeLength a fontGlyph' ch = fromMaybe 0 $ fontGlyph font' ch Nothing - font' = pattern2hbfont pat (round ppem) $ variations' fontSize' styles - ppem = fontSize'/scale root + font' = pattern2hbfont pat (round scale') $ variations' fontSize' styles + scale' = fontSize'*hbUnit data CSSFont = CSSFont { cssFontSize :: Unitted, -- 2.30.2