Add Fixed32 numeric instances
This commit is contained in:
parent
c5f715ac7c
commit
41b5c14e2f
GPG Key ID:
A27FDC1E8EE902C0
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user