Dump compound glyph info

src/Graphics/Fountainhead/Dumper.hs

@@ -14,6 +14,7 @@
 module Graphics.Fountainhead.Dumper
     ( DumpError(..)
     , dumpCmap
+    , dumpGlyf
     , dumpHead
     , dumpHmtx
     , dumpHhea
@@ -38,16 +39,20 @@ import qualified Data.Text.Encoding as Text
 import qualified Data.Text.Lazy as Text.Lazy
 import qualified Data.Text.Lazy.Builder as Text.Builder
 import qualified Data.Text.Lazy.Builder.Int as Text.Builder
+import qualified Data.Text.Lazy.Builder.RealFloat as Text.Builder
 import Data.Vector (Vector)
 import qualified Data.Vector as Vector
 import Data.Void
 import GHC.Records (HasField(..))
 import Graphics.Fountainhead.TrueType
     ( CmapTable(..)
+    , CompoundGlyphDefinition(..)
+    , ComponentGlyphPartDescription(..)
     , FontDirectory(..)
     , FontDirectionHint(..)
     , GASPRange(..)
     , GASPTable(..)
+    , GlyphArgument(..)
     , HeadTable(..)
     , HheaTable(..)
     , HmtxTable(..)
@@ -61,6 +66,7 @@ import Graphics.Fountainhead.TrueType
     , CmapSubtable(..)
     , CmapFormat4Table(..)
     , FontStyle(..)
+    , GlyphArgument(..)
     , GlyphCoordinate(..)
     , GlyphDefinition(..)
     , GlyphDescription(..)
@@ -83,7 +89,9 @@ import Graphics.Fountainhead.TrueType
     , Panose(..)
     , SimpleGlyphDefinition(..)
     , CVTable(..)
-    , OutlineFlag (..)
+    , OutlineFlag(..)
+    , ComponentGlyphFlags(..)
+    , GlyphTransformationOption(..)
     )
 import qualified Text.Megaparsec as Megaparsec
 import Graphics.Fountainhead.Parser
@@ -102,9 +110,14 @@ import Graphics.Fountainhead.Parser
     , cvTableP
     , glyfTableP
     )
-import Graphics.Fountainhead.Type (Fixed32(..), succIntegral, ttfEpoch)
+import Graphics.Fountainhead.Type
+    ( Fixed32(..)
+    , succIntegral
+    , ttfEpoch
+    , fixed2Double
+    )
 import Data.Foldable (Foldable(..), find)
-import Data.Maybe (fromMaybe)
+import Data.Maybe (fromMaybe, catMaybes)
 import Data.Time (LocalTime(..), NominalDiffTime, diffLocalTime, midnight)
 import Data.Bits (Bits(..), (.>>.))
 import Data.Bifunctor (Bifunctor(first))
@@ -670,7 +683,69 @@ dumpGlyf (GlyfTable glyfDescriptions) = dumpCaption "'glyf' Table - Glyf data"
         <> "         Coordinates" <> newlineBuilder
         <> "         -----------" <> newlineBuilder
         <> fst (Vector.ifoldl' foldCoordinate mempty coordinates)
-    dumpGlyphDefinition _ = "" -- TODO
+    dumpGlyphDefinition (CompoundGlyph CompoundGlyphDefinition{..})
+        = foldMap (dumpCompoundGlyph $ Vector.length components) (Vector.indexed components)
+        <> newlineBuilder <> "         Length of Instructions: "
+        <> Text.Builder.decimal (Vector.length instructions) <> newlineBuilder
+    dumpCompoundGlyph :: Int -> (Int, ComponentGlyphPartDescription) -> Text.Builder.Builder
+    dumpCompoundGlyph componentsLength (componentIndex, description) =
+        let moreComponents = succ componentIndex < componentsLength
+            compoundFlags = dumpCompoundFlags moreComponents description
+            ComponentGlyphPartDescription{..} = description
+         in "         " <> Text.Builder.decimal componentIndex
+            <> ": Flags:       0x" <> compoundFlags <> newlineBuilder
+            <> "            Glyf Index:  " <> Text.Builder.decimal glyphIndex <> newlineBuilder
+            <> "            X" <> dumpArgument argument1 <> newlineBuilder
+            <> "            Y" <> dumpArgument argument2 <> newlineBuilder
+            <> dumpTransformationOption transformationOption
+            <> "            Others:      " <> dumpOtherFlags flags <> newlineBuilder
+            <> newlineBuilder -- TODO
+    dumpTransformationOption GlyphNoScale = ""
+    dumpTransformationOption (GlyphScale scale) =
+        "            X,Y Scale:   " <> Text.Builder.realFloat (fixed2Double scale) <> newlineBuilder
+    dumpTransformationOption (GlyphXyScale xScale yScale)
+        = "            X Scale:     " <> Text.Builder.realFloat (fixed2Double xScale) <> newlineBuilder
+        <> "            Y Scale:     " <> Text.Builder.realFloat (fixed2Double yScale) <> newlineBuilder
+    dumpTransformationOption (Glyph2By2Scale xScale scale01 scale10 yScale)
+        = "            X Scale:     " <> Text.Builder.realFloat (fixed2Double xScale) <> newlineBuilder
+        <> "            X,Y Scale:   " <> Text.Builder.realFloat (fixed2Double scale01) <> newlineBuilder
+        <> "            Y,X Scale:   " <> Text.Builder.realFloat (fixed2Double scale10) <> newlineBuilder
+        <> "            Y Scale:     " <> Text.Builder.realFloat (fixed2Double yScale) <> newlineBuilder
+    dumpOtherFlags ComponentGlyphFlags{..} =
+        let roundXyToGridText = if roundXyToGrid then "Round X,Y to Grid   " else "                    "
+            useMyMetricsText = if useMyMetrics then "Use My Metrics   " else "                 "
+            overlapCompoundText = if overlapCompound then "Overlap      " else "             "
+         in roundXyToGridText <> overlapCompoundText <> useMyMetricsText
+    dumpCompoundFlags :: Bool -> ComponentGlyphPartDescription -> Text.Builder.Builder
+    dumpCompoundFlags moreComponents ComponentGlyphPartDescription{..} =
+        let setBits = glyphArgumentBits argument1
+                <> componentFlagBits flags
+                <> transformationOptionBits transformationOption
+            setBits' = if moreComponents then 5 : setBits else setBits
+         in Text.Builder.hexadecimal
+            $ foldr (flip setBit) (zeroBits :: Word16) setBits'
+    dumpArgument (GlyphInt8Argument argument) =
+        " BOffset:   " <> Text.Builder.decimal argument
+    dumpArgument (GlyphInt16Argument argument) =
+        " WOffset:   " <> Text.Builder.decimal argument
+    dumpArgument (GlyphWord8Argument argument) =
+        " BPoint:    " <> Text.Builder.decimal argument
+    dumpArgument (GlyphWord16Argument argument) =
+        " WPoint:    " <> Text.Builder.decimal argument
+    glyphArgumentBits (GlyphInt16Argument _) = [0, 1]
+    glyphArgumentBits (GlyphWord16Argument _) = [0]
+    glyphArgumentBits (GlyphInt8Argument _) = [1]
+    glyphArgumentBits (GlyphWord8Argument _) = []
+    componentFlagBits ComponentGlyphFlags{..} = catMaybes
+        [ if roundXyToGrid then Just 2 else Nothing
+        , if weHaveInstructions then Just 8 else Nothing
+        , if useMyMetrics then Just 9 else Nothing
+        , if overlapCompound then Just 10 else Nothing
+        ]
+    transformationOptionBits GlyphScale{} = [3]
+    transformationOptionBits GlyphXyScale{} = [6]
+    transformationOptionBits Glyph2By2Scale{} = [7]
+    transformationOptionBits GlyphNoScale = []
     dumpFlag lineValue coordinateIndex
         = "         " <> justifyNumber 2 coordinateIndex <> lineValue
     foldFlag :: (Text.Builder.Builder, Int) -> OutlineFlag -> (Text.Builder.Builder, Int)

src/Graphics/Fountainhead/Parser.hs

@@ -524,6 +524,8 @@ componentGlyphPartDescriptionP accumulator = do
     -- MORE_COMPONENTS.
     if testBit flags' 5 then componentGlyphPartDescriptionP updated else pure updated
 
+-- | Arguments are: WE_HAVE_A_SCALE, WE_HAVE_AN_X_AND_Y_SCALE and
+-- WE_HAVE_A_TWO_BY_TWO.
 transformationOptionP :: Bool -> Bool -> Bool -> Parser GlyphTransformationOption
 transformationOptionP True _ _ = GlyphScale <$> f2Dot14P <?> "scale"
 transformationOptionP _ True _ = GlyphXyScale
@@ -538,6 +540,7 @@ transformationOptionP _ _ True = Glyph2By2Scale
     <?> "2 by 2 transformation"
 transformationOptionP _ _ _ = pure GlyphNoScale
 
+-- | Arguments are: ARG_1_AND_2_ARE_WORDS and ARGS_ARE_XY_VALUES.
 glyphArgumentP :: Bool -> Bool -> Parser GlyphArgument
 glyphArgumentP True True = GlyphInt16Argument
     <$> Megaparsec.Binary.int16be

src/Graphics/Fountainhead/Type.hs

@@ -8,10 +8,12 @@ module Graphics.Fountainhead.Type
     , Fixed32(..)
     , FWord
     , UFWord
+    , fixed2Double
     , succIntegral
     , ttfEpoch
     ) where
 
+import Data.Bits ((.>>.), (.&.))
 import Data.Int (Int16)
 import Data.Word (Word16, Word32)
 import Data.Time (Day(..))
@@ -31,3 +33,9 @@ ttfEpoch = fromOrdinalDate 1904 1
 
 succIntegral :: Integral a => a -> Int
 succIntegral = succ . fromIntegral
+
+fixed2Double :: F2Dot14 -> Double
+fixed2Double (F2Dot14 fixed) =
+    let mantissa = realToFrac (fixed .>>. 14)
+        fraction = realToFrac (fixed .&. 0x3fff) / 16384.0
+     in mantissa + fraction