diff --git a/lib/Graphics/Fountainhead/Dumper.hs b/lib/Graphics/Fountainhead/Dumper.hs index 2a90db5..1e1491c 100644 --- 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 diff --git a/lib/Graphics/Fountainhead/Metrics.hs b/lib/Graphics/Fountainhead/Metrics.hs index ddebf85..e9b3c39 100644 --- 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 diff --git a/lib/Graphics/Fountainhead/Type.hs b/lib/Graphics/Fountainhead/Type.hs index e809d9c..c412b74 100644 --- 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) diff --git a/test/Graphics/Fountainhead/MetricsSpec.hs b/test/Graphics/Fountainhead/MetricsSpec.hs index d122579..63f03cd 100644 --- 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