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)
= 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

View File

@ -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 ->
(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
}
| otherwise -> Left $ MetricsRequiredTableMissingError "name"
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
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)

View File

@ -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 = "OpenSansBold"
, 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