Modify the parser to save less outline flags

… than coordinates if the repeated value is given.

src/Graphics/Fountainhead/Dumper.hs

@@ -61,6 +61,10 @@ import Graphics.Fountainhead.TrueType
     , CmapSubtable(..)
     , CmapFormat4Table(..)
     , FontStyle(..)
+    , GlyphCoordinate(..)
+    , GlyphDefinition(..)
+    , GlyphDescription(..)
+    , GlyfTable(..)
     , LongHorMetric(..)
     , LocaTable(..)
     , NameRecord (..)
@@ -77,7 +81,9 @@ import Graphics.Fountainhead.TrueType
     , Os2Version5Fields(..)
     , Os2Table(..)
     , Panose(..)
+    , SimpleGlyphDefinition(..)
     , CVTable(..)
+    , OutlineFlag (..)
     )
 import qualified Text.Megaparsec as Megaparsec
 import Graphics.Fountainhead.Parser
@@ -94,14 +100,16 @@ import Graphics.Fountainhead.Parser
     , os2TableP
     , postTableP
     , 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)
@@ -110,6 +118,7 @@ data DumpError
 data RequiredTables = RequiredTables
     { hheaTable :: HheaTable
     , headTable :: HeadTable
+    , locaTable :: LocaTable
     } deriving (Eq, Show)
 
 paddedHexadecimal :: Integral a => a -> Text.Builder.Builder
@@ -634,6 +643,68 @@ dumpGASP GASPTable{..} = dumpCaption "'gasp' Table - Grid-fitting And Scan-conve
         <> "         rangeMaxPPEM:   " <> Text.Builder.decimal rangeMaxPPEM <> newlineBuilder
         <> "         rangeGaspBehavior:      0x" <> halfPaddedHexadecimal rangeGaspBehavior <> newlineBuilder
 
+dumpGlyf :: GlyfTable -> Text.Builder.Builder
+dumpGlyf (GlyfTable glyfDescriptions) = dumpCaption "'glyf' Table - Glyf data"
+    <> foldMap go (Vector.indexed glyfDescriptions)
+  where
+    go (glyphIndex, GlyphDescription{..})
+        = "Glyph " <> justifyNumber 6 glyphIndex <> Text.Builder.singleton '.' <> newlineBuilder
+        <> "         numberOfContours:       " <> Text.Builder.decimal numberOfContours <> newlineBuilder
+        <> "         xMin:                   " <> Text.Builder.decimal xMin <> newlineBuilder
+        <> "         yMin:                   " <> Text.Builder.decimal yMin <> newlineBuilder
+        <> "         xMax:                   " <> Text.Builder.decimal xMax <> newlineBuilder
+        <> "         yMax:                   " <> Text.Builder.decimal yMax <> newlineBuilder
+        <> newlineBuilder <> dumpGlyphDefinition definition <> newlineBuilder
+    dumpEndPoint (endPointIndex, endPoint)
+        = "         " <> justifyNumber 2 endPointIndex
+        <> ":  " <> Text.Builder.decimal endPoint <> newlineBuilder
+    dumpGlyphDefinition (SimpleGlyph SimpleGlyphDefinition{..})
+        = "         EndPoints" <> newlineBuilder
+        <> "         ---------" <> newlineBuilder
+        <> foldMap dumpEndPoint (Vector.indexed endPtsOfContours) <> newlineBuilder
+        <> "         Length of Instructions: "
+        <> Text.Builder.decimal (Vector.length instructions) <> newlineBuilder
+        <> newlineBuilder <> "         Flags" <> newlineBuilder
+        <> "         -----" <> newlineBuilder
+        <> fst (Vector.foldl' foldFlag ("", 0) flags) <>  newlineBuilder
+        <> "         Coordinates" <> newlineBuilder
+        <> "         -----------" <> newlineBuilder
+        <> fst (Vector.ifoldl' foldCoordinate mempty coordinates)
+    dumpGlyphDefinition _ = "" -- TODO
+    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 = relCoordinate <> absCoordinate
+            newLine = "         " <> justifyNumber 2 coordinateIndex
+                <> " Rel " <> dumpCoordinate relCoordinate
+                <> " -> Abs " <> dumpCoordinate nextAbs
+                <> newlineBuilder
+         in (accumulator <> newLine, nextAbs)
+    dumpCoordinate GlyphCoordinate{..}
+        = "(" <> justifyNumber 7 coordinateX <> ", "
+        <> justifyNumber 7 coordinateY <> ")"
+
 dumpTables
     :: Megaparsec.State ByteString Void
     -> FontDirectory
@@ -644,9 +715,16 @@ dumpTables processedState directory@FontDirectory{..}
     traverseDirectory parsedRequired =
         let initial = Right $ dumpOffsetTable directory
          in foldl' (go parsedRequired) initial tableDirectory
-    parseRequired = RequiredTables
+    parseRequired = do
-        <$> findRequired "hhea" hheaTableP
+        requiredHhea <- findRequired "hhea" hheaTableP
-        <*> findRequired "head" headTableP
+        requiredHead@HeadTable{ indexToLocFormat } <-
+            findRequired "head" headTableP
+        requiredLoca <- findRequired "loca" (locaTableP indexToLocFormat)
+        pure $ RequiredTables
+            { hheaTable = requiredHhea
+            , headTable = requiredHead 
+            , locaTable = requiredLoca
+            } 
     findRequired tableName parser = 
         let missingError = Left $ DumpRequiredTableMissingError tableName
             parseFound tableEntry = parseTable tableEntry parser processedState
@@ -665,14 +743,14 @@ dumpTables processedState directory@FontDirectory{..}
             "hhea" -> Just $ Right $ dumpHhea hheaTable
             "hmtx" -> Just $ dumpHmtx
                 <$> parseTable tableEntry (hmtxTableP $ getField @"numOfLongHorMetrics" hheaTable) processedState
-            "loca" -> Just $ dumpLoca
+            "loca" -> Just $ Right $ dumpLoca locaTable
-                <$> parseTable tableEntry (locaTableP $ getField @"indexToLocFormat" headTable) processedState
             "maxp" -> Just $ dumpMaxp <$> parseTable tableEntry maxpTableP processedState
             "name" -> Just $ dumpName <$> parseTable tableEntry nameTableP processedState
             "post" -> Just $ dumpPost <$> parseTable tableEntry postTableP processedState
             "OS/2" -> Just $ dumpOs2 <$> parseTable tableEntry os2TableP processedState
             "cvt " -> Just $ dumpCVTable <$> parseTable tableEntry cvTableP processedState
             "gasp" -> Just $ dumpGASP <$> parseTable tableEntry gaspTableP processedState
+            "glyf" -> Just $ dumpGlyf <$> parseTable tableEntry (glyfTableP locaTable) processedState
             _ -> Nothing
 
 dumpTrueType :: ByteString -> FilePath -> Either DumpError Text.Builder.Builder

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