From 1bcff4c5191cc6c016b8dce77e27ffa8ad46f40c Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Tue, 30 Jan 2024 09:38:03 +0100 Subject: [PATCH] Modify the parser to save less outline flags MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit … than coordinates if the repeated value is given. --- src/Graphics/Fountainhead/Dumper.hs | 41 ++++++++++------- src/Graphics/Fountainhead/Parser.hs | 65 +++++++++++++++------------ src/Graphics/Fountainhead/TrueType.hs | 15 ++++++- src/Graphics/Fountainhead/Type.hs | 4 ++ 4 files changed, 78 insertions(+), 47 deletions(-) diff --git a/src/Graphics/Fountainhead/Dumper.hs b/src/Graphics/Fountainhead/Dumper.hs index 84d8661..06756cb 100644 --- a/src/Graphics/Fountainhead/Dumper.hs +++ b/src/Graphics/Fountainhead/Dumper.hs @@ -83,6 +83,7 @@ import Graphics.Fountainhead.TrueType , Panose(..) , SimpleGlyphDefinition(..) , CVTable(..) + , OutlineFlag (..) ) import qualified Text.Megaparsec as Megaparsec import Graphics.Fountainhead.Parser @@ -101,13 +102,14 @@ import Graphics.Fountainhead.Parser , cvTableP , glyfTableP ) -import Graphics.Fountainhead.Type (Fixed32(..), ttfEpoch) +import Graphics.Fountainhead.Type (Fixed32(..), succIntegral, ttfEpoch) import Data.Foldable (Foldable(..), find) import Data.Maybe (fromMaybe) import Data.Time (LocalTime(..), NominalDiffTime, diffLocalTime, midnight) import Data.Bits (Bits(..), (.>>.)) import Data.Bifunctor (Bifunctor(first)) import Data.List (intersperse) +import Prelude hiding (repeat) data DumpError = DumpParseError (Megaparsec.ParseErrorBundle ByteString Void) @@ -664,36 +666,41 @@ dumpGlyf (GlyfTable glyfDescriptions) = dumpCaption "'glyf' Table - Glyf data" <> Text.Builder.decimal (Vector.length instructions) <> newlineBuilder <> newlineBuilder <> " Flags" <> newlineBuilder <> " -----" <> newlineBuilder - <> foldMap dumpFlag (Vector.indexed coordinates) <> newlineBuilder + <> fst (Vector.foldl' foldFlag ("", 0) flags) <> newlineBuilder <> " Coordinates" <> newlineBuilder <> " -----------" <> newlineBuilder - <> dumpCoordinates coordinates + <> fst (Vector.ifoldl' foldCoordinate mempty coordinates) dumpGlyphDefinition _ = "" -- TODO - dumpFlag (coordinateIndex, GlyphCoordinate{..}) -- TODO - = " " <> justifyNumber 2 coordinateIndex <> ": " - <> (if onCurve then "On" else "Off") - <> newlineBuilder - dumpCoordinates coordinates = - let initial = ("", GlyphCoordinate 0 0 True) - in fst $ Vector.ifoldl' foldCoordinate initial coordinates + dumpFlag lineValue coordinateIndex + = " " <> justifyNumber 2 coordinateIndex <> lineValue + foldFlag :: (Text.Builder.Builder, Int) -> OutlineFlag -> (Text.Builder.Builder, Int) + foldFlag (accumulator, coordinateIndex) OutlineFlag{..} = + let lineValue = ": " + <> (if thisYIsSame then "YDual " else " ") + <> (if thisXIsSame then "XDual " else " ") + <> (if repeat > 0 then "Repeat " else " ") + <> (if yShortVector then "Y-Short " else " ") + <> (if xShortVector then "X-Short " else " ") + <> (if onCurve then "On" else "Off") + <> newlineBuilder + repeatN = succIntegral repeat + repeatedLines = fold + $ Vector.cons accumulator + $ dumpFlag lineValue + <$> Vector.enumFromN coordinateIndex repeatN + in (repeatedLines, coordinateIndex + repeatN) foldCoordinate :: (Text.Builder.Builder, GlyphCoordinate) -> Int -> GlyphCoordinate -> (Text.Builder.Builder, GlyphCoordinate) foldCoordinate (accumulator, absCoordinate) coordinateIndex relCoordinate = - let nextAbs = GlyphCoordinate - { coordinateX = sumCoordinate (getField @"coordinateX") relCoordinate absCoordinate - , coordinateY = sumCoordinate (getField @"coordinateY") relCoordinate absCoordinate - , onCurve = getField @"onCurve" relCoordinate -- Not used. - } + let nextAbs = relCoordinate <> absCoordinate newLine = " " <> justifyNumber 2 coordinateIndex <> " Rel " <> dumpCoordinate relCoordinate <> " -> Abs " <> dumpCoordinate nextAbs <> newlineBuilder in (accumulator <> newLine, nextAbs) - sumCoordinate getAxis relCoordinate absCoordinate = - getAxis relCoordinate + getAxis absCoordinate dumpCoordinate GlyphCoordinate{..} = "(" <> justifyNumber 7 coordinateX <> ", " <> justifyNumber 7 coordinateY <> ")" diff --git a/src/Graphics/Fountainhead/Parser.hs b/src/Graphics/Fountainhead/Parser.hs index bb74ea7..72ea36d 100644 --- a/src/Graphics/Fountainhead/Parser.hs +++ b/src/Graphics/Fountainhead/Parser.hs @@ -142,7 +142,12 @@ import Graphics.Fountainhead.TrueType , VariationSelectorMap , unLocaTable ) -import Graphics.Fountainhead.Type (F2Dot14(..), Fixed32(..), ttfEpoch) +import Graphics.Fountainhead.Type + ( F2Dot14(..) + , Fixed32(..) + , succIntegral + , ttfEpoch + ) import Text.Megaparsec (()) import qualified Text.Megaparsec as Megaparsec import qualified Text.Megaparsec.Byte.Binary as Megaparsec.Binary @@ -561,60 +566,62 @@ simpleGlyphDefinitionP numberOfContours' = do instructions' <- vectorNP instructionLength (Megaparsec.Binary.word8 "simple glyph instruction") flags' <- flagsP numberOfPoints mempty "flags" - xs <- Vector.foldM (coordinateP xFlagPair) mempty flags' - ys <- Vector.foldM (coordinateP yFlagPair) mempty flags' + xs <- Vector.foldM (coordinatesP xFlagPair) mempty flags' + ys <- Vector.foldM (coordinatesP yFlagPair) mempty flags' pure $ SimpleGlyphDefinition { endPtsOfContours = endPtsOfContours' , instructions = instructions' - , coordinates = mkCoordinate <$> Vector.zip3 xs ys flags' + , flags = flags' + , coordinates = mkCoordinate <$> Vector.zip xs ys } where - mkCoordinate (x, y, OutlineFlag{ onCurve }) = GlyphCoordinate x y onCurve + mkCoordinate (x, y) = GlyphCoordinate x y xFlagPair :: OutlineFlag -> (Bool, Bool) xFlagPair OutlineFlag{ xShortVector, thisXIsSame } = (xShortVector, thisXIsSame) yFlagPair :: OutlineFlag -> (Bool, Bool) yFlagPair OutlineFlag{ yShortVector, thisYIsSame } = (yShortVector, thisYIsSame) - coordinateP + coordinateP :: Bool -> Bool -> Parser Int16 + coordinateP True True = fromIntegral + <$> Megaparsec.Binary.word8 + "1 byte long positive coordinate" + coordinateP True False = negate . fromIntegral + <$> Megaparsec.Binary.word8 + "1 byte long negative coordinate" + coordinateP False False = Megaparsec.Binary.int16be + "2 bytes long coordinate" + coordinateP False True = pure 0 + coordinatesP :: (OutlineFlag -> (Bool, Bool)) -> Vector Int16 -> OutlineFlag -> Parser (Vector Int16) - coordinateP get accumulator first = - case get first of - (True, True) -> Vector.snoc accumulator . fromIntegral - <$> Megaparsec.Binary.word8 - "1 byte long positive coordinate" - (True, False) - -> Vector.snoc accumulator . negate . fromIntegral - <$> Megaparsec.Binary.word8 - "1 byte long negative coordinate" - (False, False) -> Vector.snoc accumulator - <$> Megaparsec.Binary.int16be - "2 bytes long coordinate" - (False, True) -> pure $ Vector.snoc accumulator 0 + coordinatesP get accumulator first = + let parser = uncurry coordinateP $ get first + repeatN = succIntegral $ getField @"repeat" first + in (accumulator <>) <$> vectorNP repeatN parser flagsP :: Int -> Vector OutlineFlag -> Parser (Vector OutlineFlag) flagsP remaining accumulator | remaining < 0 = pure accumulator | otherwise = do flag <- Megaparsec.Binary.word8 "outline flags" + repeatN <- + if testBit flag 3 + then fromIntegral + <$> Megaparsec.Binary.word8 + "flag repeat count" + else pure 0 let flag' = OutlineFlag { onCurve = testBit flag 0 , xShortVector = testBit flag 1 , yShortVector = testBit flag 2 + , repeat = fromIntegral repeatN , thisXIsSame = testBit flag 4 , thisYIsSame = testBit flag 5 } - repeatN <- - if testBit flag 3 - then (1 +) - . fromIntegral - <$> Megaparsec.Binary.word8 - "flag repeat count" - else pure 1 - flagsP (remaining - repeatN) - $ accumulator <> Vector.replicate repeatN flag' + flagsP (remaining - repeatN - 1) + $ Vector.snoc accumulator flag' glyfTableP :: LocaTable -> Parser GlyfTable glyfTableP locaTable @@ -871,7 +878,7 @@ cmapFormat2TableP = do length' <- fromIntegral <$> Megaparsec.Binary.word16be language' <- Megaparsec.Binary.word16be subHeaderKeys' <- vectorNP 256 Megaparsec.Binary.word16be - let maxIndex = succ $ fromIntegral $ Vector.maximum $ fmap (`div` 8) subHeaderKeys' + let maxIndex = succIntegral $ Vector.maximum $ fmap (`div` 8) subHeaderKeys' subHeaders' <- vectorNP maxIndex cmapFormat2SubheaderP let glyphIndexLength = div (length' - 518 - maxIndex * 8) 2 glyphIndexArray' <- vectorNP glyphIndexLength Megaparsec.Binary.word16be diff --git a/src/Graphics/Fountainhead/TrueType.hs b/src/Graphics/Fountainhead/TrueType.hs index 3828f38..0c15081 100644 --- a/src/Graphics/Fountainhead/TrueType.hs +++ b/src/Graphics/Fountainhead/TrueType.hs @@ -341,6 +341,8 @@ data SimpleGlyphDefinition = SimpleGlyphDefinition { endPtsOfContours :: Vector Word16 -- | Array of instructions for this glyph. , instructions :: Vector Word8 + -- Array of flags. + , flags :: Vector OutlineFlag -- | Array of coordinates; the first is relative to (0,0), others are -- relative to previous point. , coordinates :: Vector GlyphCoordinate @@ -366,9 +368,19 @@ data ComponentGlyphFlags = ComponentGlyphFlags data GlyphCoordinate = GlyphCoordinate { coordinateX :: Int16 , coordinateY :: Int16 - , onCurve :: Bool } deriving (Eq, Show) +instance Semigroup GlyphCoordinate + where + lhs <> rhs = + let GlyphCoordinate{ coordinateX = lhX, coordinateY = lhY } = lhs + GlyphCoordinate{ coordinateX = rhX, coordinateY = rhY } = rhs + in GlyphCoordinate{ coordinateX = lhX + rhX, coordinateY = lhY + rhY } + +instance Monoid GlyphCoordinate + where + mempty = GlyphCoordinate 0 0 + data ComponentGlyphPartDescription = ComponentGlyphPartDescription { flags :: ComponentGlyphFlags , glyphIndex :: Word16 @@ -383,6 +395,7 @@ data OutlineFlag = OutlineFlag { onCurve :: Bool , xShortVector :: Bool , yShortVector :: Bool + , repeat :: Word8 , thisXIsSame :: Bool , thisYIsSame :: Bool } deriving (Eq, Show) diff --git a/src/Graphics/Fountainhead/Type.hs b/src/Graphics/Fountainhead/Type.hs index 06274dc..07031e4 100644 --- a/src/Graphics/Fountainhead/Type.hs +++ b/src/Graphics/Fountainhead/Type.hs @@ -8,6 +8,7 @@ module Graphics.Fountainhead.Type , Fixed32(..) , FWord , UFWord + , succIntegral , ttfEpoch ) where @@ -27,3 +28,6 @@ type UFWord = Word16 ttfEpoch :: Day ttfEpoch = fromOrdinalDate 1904 1 + +succIntegral :: Integral a => a -> Int +succIntegral = succ . fromIntegral