Add Fixed32 numeric instances

This commit is contained in:
Eugen Wissner 2024-02-11 18:50:25 +01:00
parent c5f715ac7c
commit 41b5c14e2f
Signed by: belka
GPG Key ID: A27FDC1E8EE902C0
4 changed files with 124 additions and 33 deletions

View File

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

View File

@ -2,7 +2,9 @@
v. 2.0. If a copy of the MPL was not distributed with this file, You can 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/. -} obtain one at https://mozilla.org/MPL/2.0/. -}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
module Graphics.Fountainhead.Metrics module Graphics.Fountainhead.Metrics
( FontBBox(..) ( FontBBox(..)
@ -14,17 +16,35 @@ module Graphics.Fountainhead.Metrics
) where ) where
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Data.List (findIndex)
import Data.Text (Text) 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 import Graphics.Fountainhead.Parser
( ParseErrorBundle ( ParseErrorBundle
, nameTableP , nameTableP
, parseFontDirectory , parseFontDirectory
, parseTable , parseTable
, headTableP
, hheaTableP
, postTableP
) )
import qualified Text.Megaparsec as Megaparsec 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 data FontDescriptorFlag
= FixedPitch = FixedPitch
@ -66,14 +86,11 @@ data FontBBox = FontBBox Number Number Number Number
data FontDescriptor = FontDescriptor data FontDescriptor = FontDescriptor
{ fontName :: Text { fontName :: Text
, flags :: [FontDescriptorFlag] , flags :: [FontDescriptorFlag]
, fullName :: Text , stemV :: Number
, familyName :: Text , missingWidth :: Number
, weight :: Text
, fontBBox :: FontBBox , fontBBox :: FontBBox
, version :: Text , italicAngle :: Number
, notice :: Text , capHeight :: Number
, encodingScheme :: Text
, isFixedPitch :: Bool
, ascender :: Number , ascender :: Number
, descender :: Number , descender :: Number
} deriving (Eq, Show) } deriving (Eq, Show)
@ -81,6 +98,7 @@ data FontDescriptor = FontDescriptor
data MetricsError data MetricsError
= MetricsParseError ParseErrorBundle = MetricsParseError ParseErrorBundle
| MetricsRequiredTableMissingError String | MetricsRequiredTableMissingError String
| MetricsNameRecordNotFound Word16
deriving Eq deriving Eq
instance Show MetricsError instance Show MetricsError
@ -88,16 +106,63 @@ instance Show MetricsError
show (MetricsParseError errorBundle) = Megaparsec.errorBundlePretty errorBundle show (MetricsParseError errorBundle) = Megaparsec.errorBundlePretty errorBundle
show (MetricsRequiredTableMissingError tableName) = show (MetricsRequiredTableMissingError tableName) =
"Required table " <> tableName <> " is missing." "Required table " <> tableName <> " is missing."
show (MetricsNameRecordNotFound nameId) =
"Name record with ID " <> show nameId <> " was not found."
collectMetrics :: FilePath -> ByteString -> Either MetricsError FontDescriptor collectMetrics :: FilePath -> ByteString -> Either MetricsError FontDescriptor
collectMetrics fontFile ttfContents = collectMetrics fontFile ttfContents =
case parseFontDirectory fontFile ttfContents of case parseFontDirectory fontFile ttfContents of
(_processedState, Left initialResult) -> Left (_processedState, Left initialResult) -> Left
$ MetricsParseError initialResult $ 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

View File

@ -14,14 +14,40 @@ module Graphics.Fountainhead.Type
) where ) where
import Data.Bits ((.>>.), (.&.)) import Data.Bits ((.>>.), (.&.))
import Data.Int (Int16) import Data.Int (Int16, Int32)
import Data.Word (Word16, Word32) import Data.Word (Word16, Word32)
import Data.Time (Day(..)) import Data.Time (Day(..))
import Data.Time.Calendar.OrdinalDate (fromOrdinalDate) import Data.Time.Calendar.OrdinalDate (fromOrdinalDate)
import Data.Fixed (HasResolution(..))
newtype Fixed32 = Fixed32 Word32 newtype Fixed32 = Fixed32 Word32
deriving (Eq, Show) 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 newtype F2Dot14 = F2Dot14 Int16
deriving (Eq, Show) deriving (Eq, Show)

View File

@ -10,23 +10,23 @@ module Graphics.Fountainhead.MetricsSpec
import Graphics.Fountainhead.Metrics import Graphics.Fountainhead.Metrics
import Test.Hspec (Spec, describe, it, shouldBe) import Test.Hspec (Spec, describe, it, shouldBe)
import qualified Data.ByteString as ByteString
spec :: Spec spec :: Spec
spec = spec =
describe "collectMetrics" $ describe "collectMetrics" $
it "collects information from the name table" $ do it "collects information from the name table" $ do
let expected = FontDescriptor let fontPath = "./fonts/OpenSans-Bold.ttf"
{ fontName = "fontName" expected = FontDescriptor
, flags = [] { fontName = "OpenSansBold"
, 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