Modify the parser to save less outline flags

… than coordinates if the repeated value is given.

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
+    dumpFlag lineValue coordinateIndex
-        = "         " <> justifyNumber 2 coordinateIndex <> ": "
+        = "         " <> justifyNumber 2 coordinateIndex <> lineValue
-        <> (if onCurve then "On" else "Off")
+    foldFlag :: (Text.Builder.Builder, Int) -> OutlineFlag -> (Text.Builder.Builder, Int)
-        <> newlineBuilder
+    foldFlag (accumulator, coordinateIndex) OutlineFlag{..} =
-    dumpCoordinates coordinates =
+        let lineValue = ": "
-        let initial = ("", GlyphCoordinate 0 0 True)
+                <> (if thisYIsSame then "YDual  " else "       ")
-         in fst $ Vector.ifoldl' foldCoordinate initial coordinates
+                <> (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
+        let nextAbs = relCoordinate <> absCoordinate
-                { coordinateX = sumCoordinate (getField @"coordinateX") relCoordinate absCoordinate
-                , coordinateY = sumCoordinate (getField @"coordinateY") relCoordinate absCoordinate
-                , onCurve = getField @"onCurve" relCoordinate -- Not used.
-                }
             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 <> ")"

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'
+    xs <- Vector.foldM (coordinatesP xFlagPair) mempty flags'
-    ys <- Vector.foldM (coordinateP yFlagPair) 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 =
+    coordinatesP get accumulator first =
-        case get first of
+        let parser = uncurry coordinateP $ get first
-            (True, True) -> Vector.snoc accumulator . fromIntegral
+            repeatN = succIntegral $ getField @"repeat" first
-                <$> Megaparsec.Binary.word8
+         in (accumulator <>) <$> vectorNP repeatN parser
-                <?> "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
     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 <- 
+            flagsP (remaining - repeatN - 1)
-                if testBit flag 3
+                $ Vector.snoc accumulator flag'
-                then (1 +)
-                    . fromIntegral
-                    <$> Megaparsec.Binary.word8
-                    <?> "flag repeat count"
-                else pure 1
-            flagsP (remaining - repeatN)
-                $ accumulator <> Vector.replicate repeatN 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

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)

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