Get missing width for the font metrics
This commit is contained in:
@ -18,29 +18,38 @@ module Graphics.Fountainhead.Metrics
|
||||
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.List (findIndex)
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text.Encoding as Text
|
||||
import Graphics.Fountainhead.TrueType
|
||||
( HeadTable(..)
|
||||
( BSerifStyle(..)
|
||||
, FontDirectory(..)
|
||||
, HeadTable(..)
|
||||
, HheaTable(..)
|
||||
, HmtxTable(..)
|
||||
, LongHorMetric(..)
|
||||
, NameRecord(..)
|
||||
, NameTable(..)
|
||||
, Os2BaseFields(..)
|
||||
, Os2Version4Fields(..)
|
||||
, Os2Version5Fields(..)
|
||||
, Os2Table(..)
|
||||
, Panose(..)
|
||||
, PostHeader(..)
|
||||
, PostTable(..)
|
||||
, findTableByTag
|
||||
, pattern Os2Version4CommonFields
|
||||
)
|
||||
import Graphics.Fountainhead.Parser
|
||||
( ParseErrorBundle
|
||||
( Parser
|
||||
, ParseErrorBundle
|
||||
, ParseState
|
||||
, nameTableP
|
||||
, parseFontDirectory
|
||||
, parseTable
|
||||
, headTableP
|
||||
, hheaTableP
|
||||
, hmtxTableP
|
||||
, os2TableP
|
||||
, postTableP
|
||||
)
|
||||
@ -124,36 +133,34 @@ collectMetrics fontFile ttfContents =
|
||||
(_processedState, Left initialResult) -> Left
|
||||
$ MetricsParseError initialResult
|
||||
(processedState, Right initialResult) -> do
|
||||
nameEntry <- maybeMetricsError (MetricsRequiredTableMissingError "name")
|
||||
$ findTableByTag "name" initialResult
|
||||
NameTable{ nameRecord, variable } <- first MetricsParseError
|
||||
$ parseTable nameEntry nameTableP processedState
|
||||
let parseForMetrics' = parseForMetrics processedState initialResult
|
||||
|
||||
NameTable{ nameRecord, variable } <- parseForMetrics' "name" nameTableP
|
||||
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
|
||||
headTable@HeadTable{ unitsPerEm } <- parseForMetrics' "head" headTableP
|
||||
let scale = (1000.0 :: Float) / fromIntegral unitsPerEm
|
||||
|
||||
hheaEntry <- maybeMetricsError (MetricsRequiredTableMissingError "hhea")
|
||||
$ findTableByTag "hhea" initialResult
|
||||
HheaTable{ ascent, descent } <- first MetricsParseError
|
||||
$ parseTable hheaEntry hheaTableP processedState
|
||||
HheaTable{ ascent, descent, numOfLongHorMetrics } <-
|
||||
parseForMetrics' "hhea" hheaTableP
|
||||
PostTable{ postHeader } <- parseForMetrics' "post" postTableP
|
||||
|
||||
postEntry <- maybeMetricsError (MetricsRequiredTableMissingError "post")
|
||||
$ findTableByTag "post" initialResult
|
||||
PostTable{ postHeader } <- first MetricsParseError
|
||||
$ parseTable postEntry postTableP processedState
|
||||
(capHeight, os2BaseFields) <- getCapHeight processedState initialResult
|
||||
let Os2BaseFields{ usWeightClass, panose } = os2BaseFields
|
||||
|
||||
(capHeight, weightClass) <- getCapHeight processedState initialResult
|
||||
HmtxTable{ hMetrics } <- parseForMetrics' "hmtx"
|
||||
$ hmtxTableP numOfLongHorMetrics
|
||||
|
||||
let fixedPitchFlag = if getField @"isFixedPitch" postHeader > 0 then Just FixedPitch else Nothing
|
||||
isSerifFlag = if isSerif $ getField @"bSerifStyle" panose then Just Serif else Nothing
|
||||
|
||||
pure $ FontDescriptor
|
||||
{ fontName = variableText nameRecord variable psNameIndex
|
||||
, flags = []
|
||||
, stemV = calculateStemV $ fromIntegral weightClass
|
||||
, missingWidth = 0
|
||||
, stemV = calculateStemV $ fromIntegral usWeightClass
|
||||
, missingWidth = fromIntegral $ scalePs scale
|
||||
$ getField @"advanceWidth" $ NonEmpty.head hMetrics
|
||||
, fontBBox = calculateBoundingBox scale headTable
|
||||
, italicAngle = realToFrac $ getField @"italicAngle" postHeader
|
||||
, capHeight = fromIntegral $ scalePs scale capHeight
|
||||
@ -163,15 +170,12 @@ collectMetrics fontFile ttfContents =
|
||||
where
|
||||
calculateStemV weightClass = 10 + 220 * (weightClass - 50) / 900
|
||||
getCapHeight processedState initialResult = do
|
||||
os2Entry <- maybeMetricsError (MetricsRequiredTableMissingError "OS/2")
|
||||
$ findTableByTag "OS/2" initialResult
|
||||
os2Table <- first MetricsParseError
|
||||
$ parseTable os2Entry os2TableP processedState
|
||||
os2Table <- parseForMetrics processedState initialResult "OS/2" os2TableP
|
||||
case os2Table of
|
||||
Os2Version4CommonFields Os2BaseFields{ usWeightClass } Os2Version4Fields{ sCapHeight } ->
|
||||
Right (sCapHeight, usWeightClass)
|
||||
Os2Version5 Os2BaseFields{ usWeightClass } _ Os2Version5Fields{ sCapHeight } ->
|
||||
Right (sCapHeight, usWeightClass)
|
||||
Os2Version4CommonFields os2BaseFields Os2Version4Fields{ sCapHeight } ->
|
||||
Right (sCapHeight, os2BaseFields)
|
||||
Os2Version5 os2BaseFields _ Os2Version5Fields{ sCapHeight } ->
|
||||
Right (sCapHeight, os2BaseFields)
|
||||
_ -> Left UnsupportedOs2VersionError
|
||||
calculateBoundingBox scale HeadTable{ xMin, xMax, yMin, yMax } =
|
||||
let xMin' = fromIntegral $ scalePs scale xMin
|
||||
@ -179,7 +183,7 @@ collectMetrics fontFile ttfContents =
|
||||
xMax' = fromIntegral $ scalePs scale xMax
|
||||
yMax' = fromIntegral $ scalePs scale yMax
|
||||
in FontBBox xMin' yMin' xMax' yMax'
|
||||
scalePs :: Float -> Int16 -> Int16
|
||||
scalePs :: Integral a => Float -> a -> Int16
|
||||
scalePs scale value = truncate $ fromIntegral value * scale
|
||||
variableText records variables recordIndex =
|
||||
let NameRecord{ platformID } = records !! recordIndex
|
||||
@ -187,5 +191,39 @@ collectMetrics fontFile ttfContents =
|
||||
in if platformID == 1
|
||||
then Text.decodeUtf8 variable
|
||||
else Text.decodeUtf16BE variable
|
||||
maybeMetricsError metricsError Nothing = Left metricsError
|
||||
maybeMetricsError _ (Just result) = Right result
|
||||
|
||||
parseForMetrics
|
||||
:: forall a
|
||||
. ParseState
|
||||
-> FontDirectory
|
||||
-> String
|
||||
-> Parser a
|
||||
-> Either MetricsError a
|
||||
parseForMetrics processedState fontDirectory tableName tableParser =
|
||||
let foundTable = findTableByTag tableName fontDirectory
|
||||
missingError = MetricsRequiredTableMissingError tableName
|
||||
parseTable' rawTable = parseTable rawTable tableParser processedState
|
||||
in maybeMetricsError missingError foundTable
|
||||
>>= first MetricsParseError . parseTable'
|
||||
|
||||
maybeMetricsError :: forall a. MetricsError -> Maybe a -> Either MetricsError a
|
||||
maybeMetricsError metricsError Nothing = Left metricsError
|
||||
maybeMetricsError _ (Just result) = Right result
|
||||
|
||||
isSerif :: BSerifStyle -> Bool
|
||||
isSerif AnySerifStyle = False
|
||||
isSerif NoFitSerifStyle = False
|
||||
isSerif CoveSerifStyle = True
|
||||
isSerif ObtuseCoveSerifStyle = True
|
||||
isSerif SquareCoveSerifStyle = True
|
||||
isSerif ObtuseSquareCoveSerifStyle = True
|
||||
isSerif SquareSerifStyle = True
|
||||
isSerif ThinSerifStyle = True
|
||||
isSerif BoneSerifStyle = True
|
||||
isSerif ExaggeratedSerifStyle =True
|
||||
isSerif TriangleSerifStyle = True
|
||||
isSerif NormalSansSerifStyle = False
|
||||
isSerif ObtuseSansSerifStyle = False
|
||||
isSerif PerpSansSerifStyle = False
|
||||
isSerif FlaredSerifStyle = True
|
||||
isSerif RoundedSerifStyle = True
|
||||
|
||||
@ -276,7 +276,10 @@ data PostHeader = PostHeader
|
||||
, italicAngle :: Fixed32 -- ^ Italic angle in degrees
|
||||
, underlinePosition :: Int16 -- ^ Underline position
|
||||
, underlineThickness :: Int16 -- ^ Underline thickness
|
||||
, isFixedPitch :: Word32 -- ^ Font is monospaced; set to 1 if the font is monospaced and 0 otherwise (N.B., to maintain compatibility with older versions of the TrueType spec, accept any non-zero value as meaning that the font is monospaced)
|
||||
-- | Font is monospaced; set to 1 if the font is monospaced and 0 otherwise
|
||||
-- (N.B., to maintain compatibility with older versions of the TrueType
|
||||
-- spec, accept any non-zero value as meaning that the font is monospaced)
|
||||
, isFixedPitch :: Word32
|
||||
, minMemType42 :: Word32 -- ^ Minimum memory usage when a TrueType font is downloaded as a Type 42 font
|
||||
, maxMemType42 :: Word32 -- ^ Maximum memory usage when a TrueType font is downloaded as a Type 42 font
|
||||
, minMemType1 :: Word32 -- ^ Minimum memory usage when a TrueType font is downloaded as a Type 1 font
|
||||
|
||||
Reference in New Issue
Block a user