Add Fixed32 numeric instances

lib/Graphics/Fountainhead/Dumper.hs

@@ -198,7 +198,7 @@ dumpFixed32 :: Fixed32 -> Text.Builder.Builder
 dumpFixed32 (Fixed32 word)
     = Text.Builder.decimal (shiftR word 16)
     <> Text.Builder.singleton '.'
-    <> Text.Builder.decimal (word .&. 0xff00)
+    <> Text.Builder.decimal (word .&. 0xffff)
 
 dumpHmtx :: HmtxTable -> Text.Builder.Builder
 dumpHmtx HmtxTable{..} =
@@ -435,7 +435,7 @@ dumpPost :: PostTable -> Text.Builder.Builder
 dumpPost PostTable{ postHeader = PostHeader{..}, postSubtable }
     = dumpCaption "'post' Table - PostScript" <> newlineBuilder
     <> "         'post' format:          " <> dumpFixed32 format <> newlineBuilder
-    <> "         italicAngle:            " <> dumpFixed32 format <> newlineBuilder
+    <> "         italicAngle:            " <> dumpFixed32 italicAngle <> newlineBuilder
     <> "         underlinePosition:      " <> Text.Builder.decimal underlinePosition <> newlineBuilder
     <> "         underlineThichness:     " <> Text.Builder.decimal underlineThickness <> newlineBuilder
     <> "         isFixedPitch:           " <> dNumber isFixedPitch <> newlineBuilder

lib/Graphics/Fountainhead/Metrics.hs

@@ -2,7 +2,9 @@
    v. 2.0. If a copy of the MPL was not distributed with this file, You can
    obtain one at https://mozilla.org/MPL/2.0/. -}
 
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DuplicateRecordFields #-}
 
 module Graphics.Fountainhead.Metrics
     ( FontBBox(..)
@@ -14,17 +16,35 @@ module Graphics.Fountainhead.Metrics
     ) where
 
 import Data.ByteString (ByteString)
+import Data.List (findIndex)
 import Data.Text (Text)
-import Graphics.Fountainhead.TrueType (findTableByTag)
+import qualified Data.Text.Encoding as Text
+import Graphics.Fountainhead.TrueType
+    ( HeadTable(..)
+    , HheaTable(..)
+    , NameRecord(..)
+    , NameTable(..)
+    , PostHeader(..)
+    , PostTable(..)
+    , findTableByTag
+    )
 import Graphics.Fountainhead.Parser
     ( ParseErrorBundle
     , nameTableP
     , parseFontDirectory
     , parseTable
+    , headTableP
+    , hheaTableP
+    , postTableP
     )
 import qualified Text.Megaparsec as Megaparsec
+import Data.Bifunctor (Bifunctor(..))
+import Data.Int (Int16, Int32)
+import Data.Word (Word16)
+import GHC.Records (HasField(..))
+import Graphics.Fountainhead.Type (Fixed32(..))
 
-type Number = Double
+type Number = Float
 
 data FontDescriptorFlag
     = FixedPitch
@@ -66,14 +86,11 @@ data FontBBox = FontBBox Number Number Number Number
 data FontDescriptor = FontDescriptor
     { fontName :: Text
     , flags :: [FontDescriptorFlag]
-    , fullName :: Text
+    , stemV :: Number
-    , familyName :: Text
+    , missingWidth :: Number
-    , weight :: Text
     , fontBBox :: FontBBox
-    , version :: Text
+    , italicAngle :: Number
-    , notice :: Text
+    , capHeight :: Number
-    , encodingScheme :: Text
-    , isFixedPitch :: Bool
     , ascender :: Number
     , descender :: Number
     } deriving (Eq, Show)
@@ -81,6 +98,7 @@ data FontDescriptor = FontDescriptor
 data MetricsError
     = MetricsParseError ParseErrorBundle
     | MetricsRequiredTableMissingError String
+    | MetricsNameRecordNotFound Word16
     deriving Eq
 
 instance Show MetricsError
@@ -88,16 +106,63 @@ instance Show MetricsError
     show (MetricsParseError errorBundle) = Megaparsec.errorBundlePretty errorBundle
     show (MetricsRequiredTableMissingError tableName) =
         "Required table " <> tableName <> " is missing."
+    show (MetricsNameRecordNotFound nameId) =
+        "Name record with ID " <> show nameId <> " was not found."
 
 collectMetrics :: FilePath -> ByteString -> Either MetricsError FontDescriptor
 collectMetrics fontFile ttfContents =
     case parseFontDirectory fontFile ttfContents of
         (_processedState, Left initialResult) -> Left
             $ MetricsParseError initialResult
-        (processedState, Right initialResult)
+        (processedState, Right initialResult) -> do
-            | Just tableEntry <- findTableByTag "name" initialResult
+            nameEntry <- maybeMetricsError (MetricsRequiredTableMissingError "name")
-            , Right parsedNameTable <- parseTable tableEntry nameTableP processedState ->
+                $ findTableByTag "name" initialResult
-                pure $ FontDescriptor
+            NameTable{ nameRecord, variable } <- first MetricsParseError
-                    {
+                $ parseTable nameEntry nameTableP processedState
-                    }
+            psNameIndex <- maybeMetricsError (MetricsNameRecordNotFound 6)
-            | otherwise -> Left $ MetricsRequiredTableMissingError "name"
+                $ findIndex ((6 ==) . getField @"nameID") nameRecord
+
+            headEntry <- maybeMetricsError (MetricsRequiredTableMissingError "head")
+                $ findTableByTag "head" initialResult
+            headTable@HeadTable{ unitsPerEm } <- first MetricsParseError
+                $ parseTable headEntry headTableP processedState
+            let scale = (1000.0 :: Float) / fromIntegral unitsPerEm
+
+            hheaEntry <- maybeMetricsError (MetricsRequiredTableMissingError "hhea")
+                $ findTableByTag "hhea" initialResult
+            HheaTable{ ascent, descent } <- first MetricsParseError
+                $ parseTable hheaEntry hheaTableP processedState
+
+            postEntry <- maybeMetricsError (MetricsRequiredTableMissingError "post")
+                $ findTableByTag "post" initialResult
+            PostTable{ postHeader } <- first MetricsParseError
+                $ parseTable postEntry postTableP processedState
+
+            pure $ FontDescriptor
+                { fontName = variableText nameRecord variable psNameIndex
+                , flags = []
+                , stemV = 1
+                , missingWidth = 0
+                , fontBBox =  calculateBoundingBox scale headTable
+                , italicAngle = realToFrac $ getField @"italicAngle" postHeader
+                , capHeight = 0
+                , ascender = fromIntegral $ scalePs scale ascent
+                , descender = fromIntegral $ scalePs scale descent
+                }
+  where
+    calculateBoundingBox scale HeadTable{ xMin, xMax, yMin, yMax } =
+        let xMin' = fromIntegral $ scalePs scale xMin
+            yMin' = fromIntegral $ scalePs scale yMin
+            xMax' = fromIntegral $ scalePs scale xMax
+            yMax' = fromIntegral $ scalePs scale yMax
+         in FontBBox xMin' yMin' xMax' yMax'
+    scalePs :: Float -> Int16 -> Int16
+    scalePs scale value = truncate $ fromIntegral value * scale
+    variableText records variables recordIndex =
+        let NameRecord{ platformID } = records !! recordIndex
+            variable = variables !! recordIndex
+         in if platformID == 1
+            then Text.decodeUtf8 variable
+            else Text.decodeUtf16BE variable
+    maybeMetricsError metricsError Nothing = Left metricsError
+    maybeMetricsError _ (Just result) = Right result

lib/Graphics/Fountainhead/Type.hs

@@ -14,14 +14,40 @@ module Graphics.Fountainhead.Type
     ) where
 
 import Data.Bits ((.>>.), (.&.))
-import Data.Int (Int16)
+import Data.Int (Int16, Int32)
 import Data.Word (Word16, Word32)
 import Data.Time (Day(..))
 import Data.Time.Calendar.OrdinalDate (fromOrdinalDate)
+import Data.Fixed (HasResolution(..))
 
 newtype Fixed32 = Fixed32 Word32
     deriving (Eq, Show)
 
+instance Num Fixed32
+  where
+    (Fixed32 x) + (Fixed32 y) = Fixed32 $ x + y
+    (Fixed32 x) - (Fixed32 y) = Fixed32 $ x - y
+    (Fixed32 x) * (Fixed32 y) = Fixed32 $ div (x * y) 65536
+    abs (Fixed32 x) = Fixed32 $ fromIntegral $ abs (fromIntegral x :: Int32)
+    signum (Fixed32 x)
+        | x == 0 = Fixed32 0
+        | (fromIntegral x :: Int32) < 0 = Fixed32 0xffff0000
+        | otherwise = Fixed32 0x10000
+    fromInteger x = Fixed32 $ fromInteger $ x * 65536
+
+instance Ord Fixed32
+  where
+    compare (Fixed32 x) (Fixed32 y) =
+        compare (fromIntegral x :: Int32) (fromIntegral y)
+
+instance Real Fixed32
+  where
+    toRational (Fixed32 x) = toRational (fromIntegral x :: Int32) / 65536.0
+
+instance HasResolution Fixed32
+  where
+    resolution = const 65536
+
 newtype F2Dot14 = F2Dot14 Int16
     deriving (Eq, Show)
 

test/Graphics/Fountainhead/MetricsSpec.hs

@@ -10,23 +10,23 @@ module Graphics.Fountainhead.MetricsSpec
 
 import Graphics.Fountainhead.Metrics
 import Test.Hspec (Spec, describe, it, shouldBe)
+import qualified Data.ByteString as ByteString
 
 spec :: Spec
 spec =
     describe "collectMetrics" $
         it "collects information from the name table" $ do
-            let expected = FontDescriptor
+            let fontPath = "./fonts/OpenSans-Bold.ttf"
-                    { fontName = "fontName"
+                expected = FontDescriptor
-                    , flags = []
+                    { fontName = "OpenSans−Bold"
-                    , fullName = "fullName"
+                    , flags = [] -- 4
-                    , familyName = "familyName"
+                    , ascender = 1068
-                    , weight = "weight"
+                    , descender = -292
-                    , fontBBox =  FontBBox 0 0 0 0
+                    , fontBBox =  FontBBox (-548) (-271) 1201 1047
-                    , version = "1.0.0"
+                    , italicAngle = 0
-                    , notice = "Notice"
+                    , capHeight = 714
-                    , encodingScheme = "encodingScheme"
+                    , stemV = 105
-                    , isFixedPitch = False
+                    , missingWidth = 600
-                    , ascender = 0
-                    , descender = 0
                     }
-             in collectMetrics `shouldBe` expected
+            openSansBoldItalic <- ByteString.readFile fontPath
+            collectMetrics fontPath openSansBoldItalic `shouldBe` Right expected