Add Fixed32 numeric instances

2024-02-11 18:50:25 +01:00
parent c5f715ac7c
commit 41b5c14e2f
4 changed files with 124 additions and 33 deletions
--- a/lib/Graphics/Fountainhead/Dumper.hs
+++ b/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
--- a/lib/Graphics/Fountainhead/Metrics.hs
+++ b/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
-    , familyName :: Text
-    , weight :: Text
+    , stemV :: Number
+    , missingWidth :: Number
    , fontBBox :: FontBBox
-    , version :: Text
-    , notice :: Text
-    , encodingScheme :: Text
-    , isFixedPitch :: Bool
+    , italicAngle :: Number
+    , capHeight :: Number
    , 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)
-            | Just tableEntry <- findTableByTag "name" initialResult
-            , Right parsedNameTable <- parseTable tableEntry nameTableP processedState ->
-                pure $ FontDescriptor
-                    {
-                    }
-            | otherwise -> Left $ MetricsRequiredTableMissingError "name"
+        (processedState, Right initialResult) -> do
+            nameEntry <- maybeMetricsError (MetricsRequiredTableMissingError "name")
+                $ findTableByTag "name" initialResult
+            NameTable{ nameRecord, variable } <- first MetricsParseError
+                $ parseTable nameEntry nameTableP processedState
+            psNameIndex <- maybeMetricsError (MetricsNameRecordNotFound 6)
+                $ 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
--- a/lib/Graphics/Fountainhead/Type.hs
+++ b/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)

--- a/test/Graphics/Fountainhead/MetricsSpec.hs
+++ b/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
-                    { fontName = "fontName"
-                    , flags = []
-                    , fullName = "fullName"
-                    , familyName = "familyName"
-                    , weight = "weight"
-                    , fontBBox =  FontBBox 0 0 0 0
-                    , version = "1.0.0"
-                    , notice = "Notice"
-                    , encodingScheme = "encodingScheme"
-                    , isFixedPitch = False
-                    , ascender = 0
-                    , descender = 0
+            let fontPath = "./fonts/OpenSans-Bold.ttf"
+                expected = FontDescriptor
+                    { fontName = "OpenSans−Bold"
+                    , flags = [] -- 4
+                    , ascender = 1068
+                    , descender = -292
+                    , fontBBox =  FontBBox (-548) (-271) 1201 1047
+                    , italicAngle = 0
+                    , capHeight = 714
+                    , stemV = 105
+                    , missingWidth = 600
                    }
-             in collectMetrics `shouldBe` expected
+            openSansBoldItalic <- ByteString.readFile fontPath
+            collectMetrics fontPath openSansBoldItalic `shouldBe` Right expected