diff options
Diffstat (limited to 'lib/Graphics/Fountainhead')
| -rw-r--r-- | lib/Graphics/Fountainhead/Metrics.hs | 102 | ||||
| -rw-r--r-- | lib/Graphics/Fountainhead/TrueType.hs | 5 |
2 files changed, 74 insertions, 33 deletions
diff --git a/lib/Graphics/Fountainhead/Metrics.hs b/lib/Graphics/Fountainhead/Metrics.hs index ca02c0d..d298775 100644 --- a/lib/Graphics/Fountainhead/Metrics.hs +++ b/lib/Graphics/Fountainhead/Metrics.hs @@ -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 + + (capHeight, os2BaseFields) <- getCapHeight processedState initialResult + let Os2BaseFields{ usWeightClass, panose } = os2BaseFields - postEntry <- maybeMetricsError (MetricsRequiredTableMissingError "post") - $ findTableByTag "post" initialResult - PostTable{ postHeader } <- first MetricsParseError - $ parseTable postEntry postTableP processedState + HmtxTable{ hMetrics } <- parseForMetrics' "hmtx" + $ hmtxTableP numOfLongHorMetrics - (capHeight, weightClass) <- getCapHeight processedState initialResult + 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 diff --git a/lib/Graphics/Fountainhead/TrueType.hs b/lib/Graphics/Fountainhead/TrueType.hs index 03852b5..ec8bb59 100644 --- a/lib/Graphics/Fountainhead/TrueType.hs +++ b/lib/Graphics/Fountainhead/TrueType.hs @@ -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 |