src/Graphics/Fountainhead/Dumper.hs

@@ -61,10 +61,6 @@ import Graphics.Fountainhead.TrueType
     , CmapSubtable(..)
     , CmapFormat4Table(..)
     , FontStyle(..)
-    , GlyphCoordinate(..)
-    , GlyphDefinition(..)
-    , GlyphDescription(..)
-    , GlyfTable(..)
     , LongHorMetric(..)
     , LocaTable(..)
     , NameRecord (..)
@@ -81,9 +77,7 @@ import Graphics.Fountainhead.TrueType
     , Os2Version5Fields(..)
     , Os2Table(..)
     , Panose(..)
-    , SimpleGlyphDefinition(..)
     , CVTable(..)
-    , OutlineFlag (..)
     )
 import qualified Text.Megaparsec as Megaparsec
 import Graphics.Fountainhead.Parser
@@ -100,16 +94,14 @@ import Graphics.Fountainhead.Parser
     , os2TableP
     , postTableP
     , cvTableP
-    , glyfTableP
     )
-import Graphics.Fountainhead.Type (Fixed32(..), succIntegral, ttfEpoch)
+import Graphics.Fountainhead.Type (Fixed32(..), 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)
@@ -118,7 +110,6 @@ data DumpError
 data RequiredTables = RequiredTables
     { hheaTable :: HheaTable
     , headTable :: HeadTable
-    , locaTable :: LocaTable
     } deriving (Eq, Show)
 
 paddedHexadecimal :: Integral a => a -> Text.Builder.Builder
@@ -643,68 +634,6 @@ 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
@@ -715,16 +644,9 @@ dumpTables processedState directory@FontDirectory{..}
     traverseDirectory parsedRequired =
         let initial = Right $ dumpOffsetTable directory
          in foldl' (go parsedRequired) initial tableDirectory
-    parseRequired = do
-        requiredHhea <- findRequired "hhea" hheaTableP
-        requiredHead@HeadTable{ indexToLocFormat } <-
-            findRequired "head" headTableP
-        requiredLoca <- findRequired "loca" (locaTableP indexToLocFormat)
-        pure $ RequiredTables
-            { hheaTable = requiredHhea
-            , headTable = requiredHead 
-            , locaTable = requiredLoca
-            } 
+    parseRequired = RequiredTables
+        <$> findRequired "hhea" hheaTableP
+        <*> findRequired "head" headTableP
     findRequired tableName parser = 
         let missingError = Left $ DumpRequiredTableMissingError tableName
             parseFound tableEntry = parseTable tableEntry parser processedState
@@ -743,14 +665,14 @@ dumpTables processedState directory@FontDirectory{..}
             "hhea" -> Just $ Right $ dumpHhea hheaTable
             "hmtx" -> Just $ dumpHmtx
                 <$> parseTable tableEntry (hmtxTableP $ getField @"numOfLongHorMetrics" hheaTable) processedState
-            "loca" -> Just $ Right $ dumpLoca locaTable
+            "loca" -> Just $ dumpLoca
+                <$> 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,12 +142,7 @@ import Graphics.Fountainhead.TrueType
     , VariationSelectorMap
     , unLocaTable
     )
-import Graphics.Fountainhead.Type
-    ( F2Dot14(..)
-    , Fixed32(..)
-    , succIntegral
-    , ttfEpoch
-    )
+import Graphics.Fountainhead.Type (F2Dot14(..), Fixed32(..), ttfEpoch)
 import Text.Megaparsec ((<?>))
 import qualified Text.Megaparsec as Megaparsec
 import qualified Text.Megaparsec.Byte.Binary as Megaparsec.Binary
@@ -566,62 +561,60 @@ simpleGlyphDefinitionP numberOfContours' = do
     instructions' <- vectorNP instructionLength
             (Megaparsec.Binary.word8 <?> "simple glyph instruction")
     flags' <- flagsP numberOfPoints mempty <?> "flags"
-    xs <- Vector.foldM (coordinatesP xFlagPair) mempty flags'
-    ys <- Vector.foldM (coordinatesP yFlagPair) mempty flags'
+    xs <- Vector.foldM (coordinateP xFlagPair) mempty flags'
+    ys <- Vector.foldM (coordinateP yFlagPair) mempty flags'
     pure $ SimpleGlyphDefinition
         { endPtsOfContours = endPtsOfContours'
         , instructions = instructions'
-        , flags = flags'
-        , coordinates = mkCoordinate <$> Vector.zip xs ys
+        , coordinates = mkCoordinate <$> Vector.zip3 xs ys flags'
         }
   where
-    mkCoordinate (x, y) = GlyphCoordinate x y
+    mkCoordinate (x, y, OutlineFlag{ onCurve }) = GlyphCoordinate x y onCurve
     xFlagPair :: OutlineFlag -> (Bool, Bool)
     xFlagPair OutlineFlag{ xShortVector, thisXIsSame } =
         (xShortVector, thisXIsSame)
     yFlagPair :: OutlineFlag -> (Bool, Bool)
     yFlagPair OutlineFlag{ yShortVector, thisYIsSame } =
         (yShortVector, thisYIsSame)
-    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
+    coordinateP
         :: (OutlineFlag -> (Bool, Bool))
         -> Vector Int16
         -> OutlineFlag
         -> Parser (Vector Int16)
-    coordinatesP get accumulator first =
-        let parser = uncurry coordinateP $ get first
-            repeatN = succIntegral $ getField @"repeat" first
-         in (accumulator <>) <$> vectorNP repeatN parser
+    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
     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
                     }
-            flagsP (remaining - repeatN - 1)
-                $ Vector.snoc accumulator flag'
+            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'
 
 glyfTableP :: LocaTable -> Parser GlyfTable
 glyfTableP locaTable
@@ -878,7 +871,7 @@ cmapFormat2TableP = do
     length' <- fromIntegral <$> Megaparsec.Binary.word16be
     language' <- Megaparsec.Binary.word16be
     subHeaderKeys' <- vectorNP 256 Megaparsec.Binary.word16be
-    let maxIndex = succIntegral $ Vector.maximum $ fmap (`div` 8) subHeaderKeys'
+    let maxIndex = succ $ fromIntegral $ 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,8 +341,6 @@ 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
@@ -368,19 +366,9 @@ 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
@@ -395,7 +383,6 @@ data OutlineFlag = OutlineFlag
     { onCurve :: Bool
     , xShortVector :: Bool
     , yShortVector :: Bool
-    , repeat :: Word8
     , thisXIsSame :: Bool
     , thisYIsSame :: Bool
     } deriving (Eq, Show)

src/Graphics/Fountainhead/Type.hs

@@ -8,7 +8,6 @@ module Graphics.Fountainhead.Type
     , Fixed32(..)
     , FWord
     , UFWord
-    , succIntegral
     , ttfEpoch
     ) where
 
@@ -28,6 +27,3 @@ type UFWord = Word16
 
 ttfEpoch :: Day
 ttfEpoch = fromOrdinalDate 1904 1
-
-succIntegral :: Integral a => a -> Int
-succIntegral = succ . fromIntegral