module Opentype.Fileformat.FontInfo (FontInfo(..), Weight(..),
Width(..), Slant(..), Decoration(..),
EmbedLicence(..), infoToTables)
where
import Opentype.Fileformat
import Opentype.Fileformat.Types
import Data.Maybe
import Data.Word
import Data.Time
import Data.Char
import Data.Bits
import Data.Binary.Put
import Data.Foldable
import Text.Printf
import Lens.Micro
import Lens.Micro.Extras
import qualified Data.ByteString.Lazy as Lazy
import qualified Data.ByteString as Strict
data Weight = Thin | ExtraLight | Light | NormalWeight | MediumWeight
| SemiBold | Bold | ExtraBold | Heavy
deriving (Eq, Ord)
instance Show Weight where
show Thin = "Thin"
show ExtraLight = "Extra Light"
show Light = "Light"
show NormalWeight = "Regular"
show MediumWeight = "Medium"
show SemiBold = "Semibold"
show Bold = "Bold"
show ExtraBold = "Extra Bold"
show Heavy = "Heavy"
data Width = UltraCondensed | ExtraCondensed | Condensed | SemiCondensed
| MediumWidth | SemiExpanded | Expanded | ExtraExpanded | UltraExpanded
deriving (Eq, Ord)
instance Show Width where
show UltraCondensed = "Ultra Condensed"
show ExtraCondensed = "Extra Condensed"
show Condensed = "Condensed"
show SemiCondensed = "Semi Condensed"
show MediumWidth = "Regular"
show SemiExpanded = "Semi Expanded"
show Expanded = "Expanded"
show ExtraExpanded = "Extra Expanded"
show UltraExpanded = "Ultra Expanded"
data Slant = Italic | Oblique | NoSlant
deriving Eq
instance Show Slant where
show Italic = "Italic"
show Oblique = "Oblique"
show NoSlant = "Regular"
data Decoration = Underscore | Negative | Outlined | StrikeOut | Shadow
deriving Eq
data EmbedLicence =
RestrictedEmbedding |
PrintPreview |
EditEmbed |
NoSubsetEmbed |
OnlyBitmapEmbed
licenceBit :: EmbedLicence -> Int
licenceBit RestrictedEmbedding = 0x0002
licenceBit PrintPreview = 0x0004
licenceBit EditEmbed = 0x0008
licenceBit NoSubsetEmbed = 0x0100
licenceBit OnlyBitmapEmbed = 0x0200
embeddedBits :: [EmbedLicence] -> Word16
embeddedBits = fromIntegral . sum . map licenceBit
data FontInfo = FontInfo {
fontFamily :: String,
fontVersion :: Int,
fontUnitsPerEm :: FWord,
fontEmBase :: FWord,
fontLineGap :: FWord,
fontWeight :: Weight,
fontWidth :: Width,
fontSlant :: Slant,
fontMonospaced :: Maybe Bool,
fontLowestRecPPEM :: Maybe Int,
fontItalicAngle :: Maybe Double,
fontCaretOffset :: Maybe FWord,
fontSubScriptSize :: Maybe (FWord, FWord),
fontSubScriptOffset :: Maybe (FWord, FWord),
fontSuperScriptSize :: Maybe (FWord, FWord),
fontSuperScriptOffset :: Maybe (FWord, FWord),
fontEmbeddingLicence :: [EmbedLicence],
fontStrikoutSize :: Maybe FWord,
fontStrikeoutPosition :: Maybe FWord,
fontFamilyClass :: Maybe (Int, Int),
fontVendorID :: Maybe (Char, Char, Char, Char),
fontPanose :: Maybe (Int, Int, Int, Int, Int, Int, Int, Int, Int, Int),
fontUnicodeRanges :: Maybe (Word32, Word32, Word32, Word32),
fontCodepageRanges :: Maybe (Word32, Word32),
fontXHeight :: Maybe FWord,
fontCapHeight :: Maybe FWord,
fontLowerOpticalPointSize :: Maybe Int,
fontUpperOpticalPointSize :: Maybe Int,
fontUnderlinePosition :: Maybe FWord,
fontUnderlineThickness :: Maybe FWord,
fontSubFamilyExtra :: String,
fontDecoration :: [Decoration],
fontCopyright :: String,
fontID :: String,
fontPsName :: String,
fontTrademark :: String,
fontManufacturer :: String,
fontDesigner :: String,
fontLicence :: String,
fontDescription :: String,
fontLicenceUrl :: String,
fontDesignerUrl :: String,
fontVendorUrl :: String,
fontSampleText :: String,
fontLightPalette :: String,
fontDarkPalette :: String,
fontCreated :: UTCTime,
fontModified :: Maybe UTCTime
}
weightClass :: Weight -> Word16
weightClass Thin = 100
weightClass ExtraLight = 200
weightClass Light = 300
weightClass NormalWeight = 400
weightClass MediumWeight = 500
weightClass SemiBold = 600
weightClass Bold = 700
weightClass ExtraBold = 800
weightClass Heavy = 900
widthClass :: Width -> Word16
widthClass UltraCondensed = 1
widthClass ExtraCondensed = 2
widthClass Condensed = 3
widthClass SemiCondensed = 4
widthClass MediumWidth = 5
widthClass SemiExpanded = 6
widthClass Expanded = 7
widthClass ExtraExpanded = 8
widthClass UltraExpanded = 9
(+++) :: String -> String -> String
s +++ "" = s
s +++ t = s ++ " " ++ t
notRegular :: (Show a, Eq a) => a -> a -> String
notRegular reg sub =
if reg == sub then "" else show sub
(///) :: Maybe c -> c -> c
(///) = flip fromMaybe
infoToTables :: FontInfo -> (HeadTable, HheaTable, NameTable, PostTable, OS2Table)
infoToTables fi = (headTbl, hheaTbl, nameTbl, postTbl, os2Tbl)
where
headTbl = HeadTable {
headVersion = 0x00010000,
fontRevision = fromIntegral $
fromIntegral (fontVersion fi) * 0x00010000 `quot`
(1000 :: Integer),
baselineYZero = True,
sidebearingXZero = True,
pointsizeDepend = False,
integerScaling = False,
alterAdvanceWidth = False,
verticalFont = False,
linguisticRenderingLayout = False,
metamorphosisEffects = False,
rightToLeftGlyphs = False,
indicRearrangements = False,
losslessFontData = False,
convertedFont = False,
clearTypeOptimized = False,
lastResortFont = False,
unitsPerEm = fromIntegral $ fontUnitsPerEm fi,
created = fontCreated fi,
modified = fontModified fi /// fontCreated fi,
xMin = 0,
yMin = 0,
xMax = 0,
yMax = 0,
boldStyle = fontWeight fi > NormalWeight,
italicStyle = fontSlant fi == Italic,
underlineStyle = Underscore `elem` fontDecoration fi,
outlineStyle = Outlined `elem` fontDecoration fi,
shadowStyle = Shadow `elem` fontDecoration fi,
condensedStyle = fontWidth fi < MediumWidth,
extendedStyle = fontWidth fi > MediumWidth,
lowerRecPPEM = (fromIntegral <$> fontLowestRecPPEM fi) /// 6,
fontDirectionHint = 2,
longLocIndices = False,
glyphDataFormat = 0}
hheaTbl = HheaTable {
version = 0x00010000,
ascent = 0,
descent = 0,
lineGap = 0,
advanceWidthMax = 0,
minLeftSideBearing = 0,
minRightSideBearing = 0,
xMaxExtent = 0,
caretSlopeRise = case fontItalicAngle fi /// 0 of
0 -> 1
90 -> 0
a -> round $ cos (pi*a/180 + pi/2) * 2048,
caretSlopeRun = case fontItalicAngle fi /// 0 of
0 -> 0
90 -> 1
a -> round $ sin (pi*a/180 + pi/2) * 2048,
caretOffset = fontCaretOffset fi /// 0,
numOfLongHorMetrics = 0}
mkNameRecords _ "" = []
mkNameRecords nid ns =
[NameRecord MacintoshPlatform 0 0 nid $
Strict.pack $ map (fromIntegral . (.&.0xff) . ord) ns,
NameRecord MicrosoftPlatform 1 0x0409 nid $
Lazy.toStrict $ runPut (traverse_ (putWord16be . fromIntegral . ord) ns)]
(versionMajor, versionMinor) = fontVersion fi `quotRem` 1000
fullName = fontFamily fi +++ subFamily
subFamily = fontSubFamilyExtra fi +++
notRegular NormalWeight (fontWeight fi) +++
notRegular MediumWidth (fontWidth fi) +++
notRegular NoSlant (fontSlant fi)
wsSubFamily
| fontWeight fi == NormalWeight && fontSlant fi == NoSlant
= "Regular"
| otherwise = weightName +++ notRegular NoSlant (fontSlant fi)
where
weightName
| fontWeight fi < NormalWeight = "Thin"
| fontWeight fi > NormalWeight = "Bold"
| otherwise = ""
nameTbl = NameTable $
concat [
mkNameRecords 0 $ fontCopyright fi,
mkNameRecords 1 $ fontFamily fi +++ fontSubFamilyExtra fi +++
notRegular MediumWidth (fontWidth fi),
mkNameRecords 2 wsSubFamily,
mkNameRecords 3 $ fontID fi,
mkNameRecords 4 fullName,
mkNameRecords 5 $ printf "Version %d.%03d" versionMajor versionMinor,
mkNameRecords 6 $ if null (fontPsName fi)
then take 63 $ map (\c -> if c == ' ' then '-' else c) fullName
else fontPsName fi,
mkNameRecords 7 $ fontTrademark fi,
mkNameRecords 8 $ fontManufacturer fi,
mkNameRecords 9 $ fontDesigner fi,
mkNameRecords 10 $ fontDescription fi,
mkNameRecords 11 $ fontVendorUrl fi,
mkNameRecords 12 $ fontDesignerUrl fi,
mkNameRecords 13 $ fontLicence fi,
mkNameRecords 14 $ fontLicenceUrl fi,
mkNameRecords 16 $ fontFamily fi,
mkNameRecords 17 subFamily,
mkNameRecords 19 $ fontSampleText fi,
mkNameRecords 21 $
if null (fontSubFamilyExtra fi) then ""
else fontFamily fi +++ fontSubFamilyExtra fi,
mkNameRecords 22 $
if null (fontSubFamilyExtra fi) then ""
else notRegular NormalWeight (fontWeight fi) +++
notRegular MediumWidth (fontWidth fi) +++
notRegular NoSlant (fontSlant fi),
mkNameRecords 23 $ fontLightPalette fi,
mkNameRecords 24 $ fontDarkPalette fi]
postTbl = PostTable {
postVersion = PostTable2,
italicAngle = round $ (fontItalicAngle fi /// 0)
* 0x00010000,
underlinePosition = fontUnderlinePosition fi ///
( fromIntegral (fontUnitsPerEm fi `quot` 8)),
underlineThickness = fontUnderlineThickness fi ///
fromIntegral (fontUnitsPerEm fi `quot` 10),
isFixedPitch = fromIntegral $ fromEnum $
fontMonospaced fi /// False,
minMemType42 = 0,
maxMemType42 = 0,
minMemType1 = 0,
maxMemType1 = 0,
glyphNameIndex = [],
postStrings = []}
(panose1, panose2, panose3, panose4, panose5,
panose6, panose7, panose8, panose9, panose10) =
fontPanose fi /// (0, 0, 0, 0, 0, 0, 0, 0, 0, 0)
vendorID = case fontVendorID fi of
Nothing -> 0x20202020
Just (a, b, c, d) -> fromIntegral $
ord a `shift` 24 .|. ord b `shift` 16 .|.
ord c `shift` 8 .|. ord d
selectionFlags = makeFlag
[fontSlant fi == Italic,
Underscore `elem` fontDecoration fi,
Negative `elem` fontDecoration fi,
Outlined `elem` fontDecoration fi,
StrikeOut `elem` fontDecoration fi,
fontWeight fi > NormalWeight,
fontWeight fi == NormalWeight &&
fontWidth fi == MediumWidth &&
fontSlant fi == NoSlant &&
null (fontSubFamilyExtra fi),
True,
null (fontSubFamilyExtra fi),
fontSlant fi == Oblique]
os2Tbl = OS2Table {
os2version = 5,
xAvgCharWidth = 0,
usWeightClass = weightClass $ fontWeight fi,
usWidthClass = widthClass $ fontWidth fi,
fsType = embeddedBits $ fontEmbeddingLicence fi,
ySubscriptXSize = (fst <$> fontSubScriptSize fi) ///
(fontUnitsPerEm fi `quot` 2),
ySubscriptYSize = (snd <$> fontSubScriptSize fi) ///
(fontUnitsPerEm fi `quot` 2),
ySubscriptXOffset = (fst <$> fontSubScriptOffset fi) /// 0,
ySubscriptYOffset = (snd <$> fontSubScriptOffset fi) ///
( (fontUnitsPerEm fi `quot` 4)),
ySuperscriptXSize = (fst <$> fontSuperScriptSize fi) ///
(fontUnitsPerEm fi `quot` 2),
ySuperscriptYSize = (snd <$> fontSuperScriptSize fi) ///
(fontUnitsPerEm fi `quot` 2),
ySuperscriptXOffset = (fst <$> fontSuperScriptOffset fi) ///
round (realToFrac (ySubscriptYOffset os2Tbl) *
cos (pi/180*((fontItalicAngle fi /// 0) + pi/2))),
ySuperscriptYOffset = (snd <$> fontSuperScriptOffset fi) ///
((fontUnitsPerEm fi fontEmBase fi) `quot` 2),
yStrikeoutSize = fontStrikoutSize fi ///
fromIntegral (fontUnitsPerEm fi `quot` 20),
yStrikeoutPosition = fontStrikeoutPosition fi ///
fromIntegral (fontUnitsPerEm fi*10 `quot` 55),
bFamilyClass = fromIntegral $
((\(x,y) -> (x `shift` 8 .|. y)) <$> fontFamilyClass fi)
/// 0,
bFamilyType = fromIntegral panose1,
bSerifStyle = fromIntegral panose2,
bWeight = fromIntegral panose3,
bProportion = fromIntegral panose4,
bContrast = fromIntegral panose5,
bStrokeVariation = fromIntegral panose6,
bArmStyle = fromIntegral panose7,
bLetterform = fromIntegral panose8,
bMidline = fromIntegral panose9,
bXHeight = fromIntegral panose10,
ulUnicodeRange1 = (view _1 <$> fontUnicodeRanges fi) /// 3,
ulUnicodeRange2 = (view _2 <$> fontUnicodeRanges fi) /// 0,
ulUnicodeRange3 = (view _3 <$> fontUnicodeRanges fi) /// 0,
ulUnicodeRange4 = (view _4 <$> fontUnicodeRanges fi) /// 0,
achVendID = vendorID,
fsSelection = selectionFlags,
usFirstCharIndex = 0,
usLastCharIndex = 0,
sTypoAscender = fontUnitsPerEm fi fontEmBase fi,
sTypoDescender = fromIntegral $ fontEmBase fi,
sTypoLineGap = fontLineGap fi,
usWinAscent = 0,
usWinDescent = 0,
ulCodePageRange1 = (fst <$> fontCodepageRanges fi) /// 1,
ulCodePageRange2 = (snd <$> fontCodepageRanges fi) /// 0,
sxHeight = 0,
sCapHeight = fontCapHeight fi /// 0,
usDefaultChar = 0,
usBreakChar = 0,
usMaxContext = 1,
usLowerOpticalPointSize = fromIntegral $
fontLowerOpticalPointSize fi /// 0,
usUpperOpticalPointSize = fromIntegral $
fontUpperOpticalPointSize fi /// 0xffff}