summaryrefslogtreecommitdiff
path: root/lib/Graphics/Fountainhead
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Graphics/Fountainhead')
-rw-r--r--lib/Graphics/Fountainhead/Dumper.hs4
-rw-r--r--lib/Graphics/Fountainhead/Metrics.hs97
-rw-r--r--lib/Graphics/Fountainhead/Type.hs28
3 files changed, 110 insertions, 19 deletions
diff --git a/lib/Graphics/Fountainhead/Dumper.hs b/lib/Graphics/Fountainhead/Dumper.hs
index 2a90db5..1e1491c 100644
--- a/lib/Graphics/Fountainhead/Dumper.hs
+++ b/lib/Graphics/Fountainhead/Dumper.hs
@@ -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
diff --git a/lib/Graphics/Fountainhead/Metrics.hs b/lib/Graphics/Fountainhead/Metrics.hs
index ddebf85..e9b3c39 100644
--- a/lib/Graphics/Fountainhead/Metrics.hs
+++ b/lib/Graphics/Fountainhead/Metrics.hs
@@ -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 ->
- pure $ FontDescriptor
- {
- }
- | otherwise -> Left $ MetricsRequiredTableMissingError "name"
+ (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
+ }
+ 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
diff --git a/lib/Graphics/Fountainhead/Type.hs b/lib/Graphics/Fountainhead/Type.hs
index e809d9c..c412b74 100644
--- a/lib/Graphics/Fountainhead/Type.hs
+++ b/lib/Graphics/Fountainhead/Type.hs
@@ -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)
generated by cgit v1.2.3 (git 2.26.2) at 2026-06-26 21:48:54 +0000