webify-0.1.9.0: src/TTF.hs
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
{-# LANGUAGE RecordWildCards #-}
module TTF(
TTF(..)
, Hhea(..)
, Cmap(..)
, CmapEncodingDirectory(..)
, Glyf(..)
, CompositeGlyfElement(..)
, CmapTable(..)
, KernPair(..)
, Kern(..)
, UFWord
, UShort
, ULong
, Byte
, parse
, glyphId
, cmapStart
, cmapEnd
, cmapTableFind
, kernPairs
) where
import Control.Monad
import Data.Binary.Strict.Get
import Data.Bits
import qualified Data.ByteString as B
import Data.List
import Data.Map hiding (findIndex, map)
import Data.Maybe
import qualified Data.Vector as V
import Font
import Utils
instance Font TTF where
version = TTF.version
numTables = TTF.numTables
tableDirectories = TTF.tableDirectories
os2panose = panose . os2
os2fsSelection = fsSelection . os2
os2usWeightClass = usWeightClass . os2
os2ulUnicodeRange1 = ulUnicodeRange1 . os2
os2ulUnicodeRange2 = ulUnicodeRange2 . os2
os2ulUnicodeRange3 = ulUnicodeRange3 . os2
os2ulUnicodeRange4 = ulUnicodeRange4 . os2
os2ulCodePageRange1 = ulCodePageRange1 . os2
os2ulCodePageRange2 = ulCodePageRange2 . os2
headCheckSumAdjusment = checkSumAdjusment . TTF.head
name = TTF.name
data F12Group = F12Group { f12StartCharCode :: ULong
, f12EndCharCode :: ULong
, f12StartGlyphId :: ULong
} deriving (Show)
data CmapTable = CmapFormat0 { c0Format :: UShort
, c0Length :: UShort
, c0Version :: UShort
, c0GlyphIDs :: [Byte]
} |
CmapFormat4 { c4Format :: UShort
, c4Length :: UShort
, c4Language :: UShort
, c4SegCountX2 :: UShort
, c4SearchRange :: UShort
, c4EntrySelector :: UShort
, c4RangeShift :: UShort
, c4EndCodes :: [UShort]
, c4ReservedPad :: UShort
, c4StartCodes :: [UShort]
, c4IdDeltas :: [UShort]
, c4IdRangeOffsets :: [UShort]
, c4GlyphIds :: [UShort]
} |
CmapFormat6 { c6Format :: UShort
, c6Length :: UShort
, c6Version :: UShort
, c6FirstCode :: UShort
, c6EntryCount :: UShort
, c6GlyphIds :: [UShort]
} |
CmapFormat12 { c12Format :: Fixed
, c12Length :: ULong
, c12Language :: ULong
, c12NGroups :: ULong
, c12Groups :: [F12Group]
} deriving (Show)
data CmapEncodingDirectory = CmapEncodingDirectory { cmapPlatformId :: UShort
, cmapEncodingId :: UShort
, cmapOffset :: ULong
} deriving (Show)
data Cmap = Cmap { cmapVersion :: UShort
, numberOfSubtables :: UShort
, encodingDirectories :: [CmapEncodingDirectory]
, subTables :: [CmapTable]
} deriving (Show)
data Hhea = Hhea { hheaVersion :: Fixed
, ascender :: FWord
, descender :: FWord
, lineGap :: FWord
, advanceWidthMax :: UFWord
, minLeftSideBearing :: FWord
, minRightSideBearing :: FWord
, xMaxExtend :: FWord
, caretSlopeRise :: Short
, caretSlopeRun :: Short
-- reserved 5 Short
, metricDataFormat :: Short
, numberOfHMetrics :: UShort
} deriving (Show)
data Maxp = Maxp { maxVersion :: Fixed
, numGlyphs :: UShort
, maxPoints :: UShort
, maxContours :: UShort
, maxCompositePoints :: UShort
, maxCompositeContours :: UShort
, maxZones :: UShort
, maxTwilightPoints :: UShort
, maxStorage :: UShort
, maxFunctionDefs :: UShort
, maxInstructionDefs :: UShort
, maxStackElements :: UShort
, maxSizeOfInstructions :: UShort
, maxComponentElements :: UShort
, maxComponentDepth :: UShort
} deriving (Show)
data Loca = Loca { locaOffsets :: [ULong] } deriving (Show)
data CompositeGlyfElement = CompositeGlyfElement {cFlags :: UShort
, cGlyphIndex :: UShort
, cXoffset :: Short
, cYoffset :: Short
, cArgument1 :: Short
, cArgument2 :: Short
, cXScale :: Double
, cYScale :: Double
, cScale01 :: Double
, cScale10 :: Double
} deriving (Show)
data Glyf = EmptyGlyf |
SimpleGlyf { sNumberOfContours :: Short
, sXMin :: FWord
, sYMin :: FWord
, sXMax :: FWord
, sYMax :: FWord
, sEndPtsOfCountours :: [UShort]
, sInstructionLength :: UShort
, sInstructions :: [Byte]
, sFlags :: [Byte]
, sXCoordinates :: [Short]
, sYCoordinates :: [Short]
} |
CompositeGlyf { cNumberOfContours :: Short
, cXMin :: FWord
, cYMin :: FWord
, cXMax :: FWord
, cYMax :: FWord
, cGlyfs :: [CompositeGlyfElement]
, cNumInstruction :: UShort
, cInstructions :: [Byte]
} deriving (Show)
data KernPair = KernPair { kpLeft :: UShort
, kpRight :: UShort
, kpValue :: Short
, kTCoverage :: UShort } deriving (Show)
data KernTable = KernSubTable0 { kNPairs :: UShort
, kSearchRange :: UShort
, kEntrySelector :: UShort
, kRangeShift :: UShort
, kKernPairs :: [KernPair] }
| KernUnknown deriving (Show)
data Kern = Kern { kernVersion :: UShort
, kernNumberOfSubtables :: UShort
, kernTables :: [KernTable]
} deriving (Show)
data TTF = TTF { version :: Fixed
, numTables :: UShort
, searchRange :: UShort
, entrySelector :: UShort
, rangeShift :: UShort
, tableDirectories :: Map String TableDirectory
, os2 :: OS2
, head :: Head
, hhea :: Hhea
, name :: Name
, cmap :: Cmap
, maxp :: Maxp
, loca :: Loca
, hmtx :: Hmtx
, glyfs :: V.Vector Glyf
, kern :: Kern
} deriving (Show)
cmapTableFind :: TTF -> UShort -> UShort -> CmapTable
cmapTableFind ttf platformId' encodingId' =
subTables (cmap ttf) !! index
where directories = encodingDirectories $ cmap ttf
index = fromJust $ findIndex predicate directories
predicate dr = cmapPlatformId dr == platformId' &&
cmapEncodingId dr == encodingId'
cmapStart :: CmapTable -> Int
cmapStart CmapFormat0{c0GlyphIDs = glyphIds} = fromJust $ findIndex (> 0) glyphIds
cmapStart CmapFormat4{c4StartCodes = startCodes} = fromIntegral $ minimum startCodes
cmapStart CmapFormat6{c6FirstCode = firstCode} = fromIntegral firstCode
cmapStart CmapFormat12{c12Groups = groups} = fromIntegral $ f12StartCharCode $ Prelude.head groups
cmapEnd :: CmapTable -> Int
cmapEnd CmapFormat0{c0GlyphIDs = glyphIds} = last $ findIndices (> 0) glyphIds
cmapEnd CmapFormat4{c4EndCodes = endCodes} = fromIntegral $ maximum endCodes
cmapEnd CmapFormat6{c6FirstCode = firstCode,
c6EntryCount = entryCount} = fromIntegral $ firstCode + entryCount
cmapEnd CmapFormat12{c12Groups = groups} = fromIntegral $ f12EndCharCode $ last groups
glyphId :: CmapTable -> Int -> Int
glyphId CmapFormat0{c0GlyphIDs = glyphIds} n | n >= 0 && n < 256 = fromIntegral $ glyphIds !! n
| otherwise = 0
glyphId CmapFormat4{c4EndCodes = endCodes
, c4StartCodes = startCodes
, c4IdDeltas = deltas
, c4IdRangeOffsets = rangeOffsets
, c4GlyphIds = glyphIds
, c4SegCountX2 = segCountX2} n'
| n < 0 || n > 0xFFFF = 0
| (startCodes !! i) > n = 0
| (rangeOffsets !! i) == 0 = fromIntegral ((deltas !! i) + n) `mod` 65536
| otherwise = fromIntegral $ glyphIds !! (fromIntegral $ ((rangeOffsets !! i) `div` 2) + (n - startCodes !! i) - (segCount - fromIntegral i))
where n = fromIntegral n'
segCount = segCountX2 `div` 2
i = fromIntegral . fromJust $ findIndex (>= n) endCodes
glyphId CmapFormat6{c6GlyphIds = glyphIds,
c6FirstCode = firstCode,
c6EntryCount = entryCount } n | n >= start && n < end = fromIntegral $ glyphIds !! (n - start)
| otherwise = 0
where start = fromIntegral firstCode
end = start + fromIntegral entryCount
glyphId CmapFormat12{c12Groups = groups} n' | start <= n && (start /= -1) = glyphId'
| otherwise = 0
where
n = fromIntegral n'
mg = find ((>= n) . f12EndCharCode) groups
g = fromJust mg
start = fromMaybe (-1) (liftM f12StartCharCode mg)
glyphId' = fromIntegral $ f12StartGlyphId g + (n - f12StartCharCode g)
kernPairs :: KernTable -> [KernPair]
kernPairs KernSubTable0{kKernPairs = pairs} = pairs
kernPairs KernUnknown = []
parseHhea :: Map String TableDirectory -> B.ByteString -> Hhea
parseHhea = parseTable "hhea" (do
hheaVersion <- getFixed
ascender <- getFWord
descender <- getFWord
lineGap <- getFWord
advanceWidthMax <- getUFWord
minLeftSideBearing <- getFWord
minRightSideBearing <- getFWord
xMaxExtend <- getFWord
caretSlopeRise <- getShort
caretSlopeRun <- getShort
replicateM_ 5 getShort
metricDataFormat <- getShort
numberOfHMetrics <- getUShort
return Hhea{..})
parseMaxp :: Map String TableDirectory -> B.ByteString -> Maxp
parseMaxp = parseTable "maxp" (do
maxVersion <- getFixed
numGlyphs <- getUShort
maxPoints <- getUShort
maxContours <- getUShort
maxCompositePoints <- getUShort
maxCompositeContours <- getUShort
maxZones <- getUShort
maxTwilightPoints <- getUShort
maxStorage <- getUShort
maxFunctionDefs <- getUShort
maxInstructionDefs <- getUShort
maxStackElements <- getUShort
maxSizeOfInstructions <- getUShort
maxComponentElements <- getUShort
maxComponentDepth <- getUShort
return Maxp{..})
parseKern :: Map String TableDirectory -> B.ByteString -> Kern
parseKern = parseTable "kern" (do
kernVersion <- getUShort
kernNumberOfSubtables <- getUShort
kernTables <- replicateM (fromIntegral kernNumberOfSubtables) parseKernTable
return Kern{..})
parseKernSubTable :: UShort -> Int -> Int -> Get KernTable
parseKernSubTable kTCoverage _ 0 = do
kNPairs <- getUShort
kSearchRange <- getUShort
kEntrySelector <- getUShort
kRangeShift <- getUShort
kKernPairs <- replicateM (fromIntegral kNPairs) parseKernPair
return KernSubTable0{..}
where parseKernPair = do
kpLeft <- getUShort
kpRight <- getUShort
kpValue <- getShort
return KernPair{..}
parseKernSubTable _ length' _version = do
skip (length' - 6)
return KernUnknown
parseKernTable :: Get KernTable
parseKernTable = do
kTLength <- getULong
kTCoverage <- getUShort
parseKernSubTable kTCoverage (fromIntegral kTLength) $ shiftR (fromIntegral kTCoverage) 8
parseHMetric :: Get HMetric
parseHMetric = do
advanceWidth <- getUFWord
lsb <- getFWord
return HMetric{..}
parseHmtx :: Int -> Int -> Map String TableDirectory -> B.ByteString -> Hmtx
parseHmtx mcount glyphCount = parseTable "hmtx" (do
hMetrics <- liftM V.fromList $ replicateM mcount parseHMetric
leftSideBearings <- replicateM (glyphCount - mcount) getShort
return Hmtx{..})
parseFlags :: Int -> [Byte] -> Get [Byte]
parseFlags n a | n <= 0 = return a
| otherwise = do
flag <- getByte
if testBit flag 3 then
do
repeats <- liftM fromIntegral getByte
parseFlags (n - repeats - 1) $ a ++ replicate repeats flag ++ [flag]
else
parseFlags (n - 1) $ a ++ [flag]
parseCoordinate ::
Int -> Int -> (Short, [Short]) -> Byte -> Get (Short, [Short])
parseCoordinate shortBit sameBit (current, ac) flag
| testBit flag shortBit = do
delta <- liftM fromIntegral getByte
return (if testBit flag sameBit then
(current + delta, current + delta : ac)
else
(current - delta, current - delta : ac))
| otherwise =
if testBit flag sameBit then
return (current, current : ac)
else
do
delta <- getShort
return (current + delta, current + delta : ac)
parseCoordinates :: [Byte] -> Int -> Int -> Get [Short]
parseCoordinates flags shortBit sameBit =
liftM (reverse . snd) $ foldM (parseCoordinate shortBit sameBit) (0, []) flags
parseCompositeGlyfElement :: Get CompositeGlyfElement
parseCompositeGlyfElement = do
cFlags <- getUShort
cGlyphIndex <- getUShort
cArgument1 <- getArg cFlags
cArgument2 <- getArg cFlags
let cScale01 = 0.0
cScale10 = 0.0
cXScale = 1.0
cYScale = 1.0
cXoffset | testBit cFlags args_are_xy_values = cArgument1
| otherwise = 0
cYoffset | testBit cFlags args_are_xy_values = cArgument2
| otherwise = 0
if testBit cFlags we_have_a_scale then
do
cXScale <- liftM fromIntegral getUShort
let cYScale = cXScale
return CompositeGlyfElement{..}
else if testBit cFlags we_have_an_x_and_y_scale then
do
cXScale <- getUFixed
cYScale <- getUFixed
return CompositeGlyfElement{..}
else if testBit cFlags we_have_a_two_by_tow then
do
cXScale <- getUFixed
cScale01 <- getUFixed
cScale10 <- getUFixed
cYScale <- getUFixed
return CompositeGlyfElement{..}
else return CompositeGlyfElement{..}
where getArg f | testBit f arg_1_and_2_are_words = liftM fromIntegral getUShort
| otherwise = liftM fromIntegral Font.getChar
arg_1_and_2_are_words = 0
args_are_xy_values = 1
we_have_a_scale = 3
we_have_an_x_and_y_scale = 6
we_have_a_two_by_tow = 7
parseGlyf :: Short -> Get Glyf
parseGlyf numberOfContours | numberOfContours >= 0 = do
sXMin <- getFWord
sYMin <- getFWord
sXMax <- getFWord
sYMax <- getFWord
sEndPtsOfCountours <- replicateM (fromIntegral numberOfContours) getUShort
sInstructionLength <- getUShort
sInstructions <- replicateM (fromIntegral sInstructionLength) getByte
let count = if numberOfContours == 0 then 0 else fromIntegral $ last sEndPtsOfCountours + 1
sFlags <- parseFlags count []
sXCoordinates <- parseCoordinates sFlags 1 4
sYCoordinates <- parseCoordinates sFlags 2 5
return SimpleGlyf{sNumberOfContours = numberOfContours, ..}
| otherwise = do
cXMin <- getFWord
cYMin <- getFWord
cXMax <- getFWord
cYMax <- getFWord
cGlyfs <- parseElements
let lastFlag = cFlags $ last cGlyfs
cNumInstruction = 0
cInstructions = []
if testBit lastFlag we_have_instructions then
do
cNumInstruction <- getUShort
cInstructions <- replicateM (fromIntegral cNumInstruction) getByte
return CompositeGlyf{cNumberOfContours = numberOfContours, ..}
else return CompositeGlyf{cNumberOfContours = numberOfContours, ..}
where
parseElements = do
cge <- parseCompositeGlyfElement
if testBit (cFlags cge) more_components then
do
rest <- parseElements
return $ cge : rest
else
return [cge]
more_components = 5
we_have_instructions = 8
parseGlyfs :: Int -> [Int] -> Map String TableDirectory -> B.ByteString -> [Glyf]
parseGlyfs glyphCount offsets tds font =
zipWith getGlyph (Data.List.take glyphCount offsets) $ diff offsets
where tableStart = fromIntegral . tDOffset $ tds ! "glyf"
getGlyph _ 0 = EmptyGlyf
getGlyph offset _len =
fromRight $ runGet (do
skip $ tableStart + offset
numberOfContours <- getShort
parseGlyf numberOfContours
) font
parseLoca :: Int -> Int -> Map String TableDirectory -> B.ByteString -> Loca
parseLoca 0 count = parseTable "loca" (do
locaOffsets <- replicateM (count + 1) (liftM ((*) 2 . fromIntegral) getUShort)
return Loca{..})
parseLoca 1 count = parseTable "loca" (do
locaOffsets <- replicateM (count + 1) getULong
return Loca{..})
parseLoca _ _ = error "error while parsing loca table"
parseCmapEncodingDirectory :: Get CmapEncodingDirectory
parseCmapEncodingDirectory = do
cmapPlatformId <- getUShort
cmapEncodingId <- getUShort
cmapOffset <- getULong
return CmapEncodingDirectory{..}
parseCmapSubTable :: Int -> Get CmapTable
parseCmapSubTable 4 = do
c4Length <- getUShort
c4Language <- getUShort
c4SegCountX2 <- getUShort
let segCount = fromIntegral c4SegCountX2 `div` 2
c4SearchRange <- getUShort
c4EntrySelector <- getUShort
c4RangeShift <- getUShort
c4EndCodes <- replicateM segCount getUShort
c4ReservedPad <- getUShort
c4StartCodes <- replicateM segCount getUShort
c4IdDeltas <- replicateM segCount getUShort
c4IdRangeOffsets <- replicateM segCount getUShort
let glyphCount = (fromIntegral c4Length - (2 * 8) - (2 * segCount * 4)) `div` 2
c4GlyphIds <- replicateM glyphCount getUShort
return CmapFormat4{c4Format = 4, ..}
parseCmapSubTable 0 = do
c0Length <- getUShort
c0Version <- getUShort
c0GlyphIDs <- replicateM 256 getByte
return CmapFormat0{c0Format = 0, ..}
parseCmapSubTable 6 = do
c6Length <- getUShort
c6Version <- getUShort
c6FirstCode <- getUShort
c6EntryCount <- getUShort
c6GlyphIds <- replicateM (fromIntegral c6EntryCount) getUShort
return CmapFormat6{c6Format = 6, ..}
parseCmapSubTable 12 = do
_ <- getUShort
c12Length <- getULong
c12Language <- getULong
c12NGroups <- getULong
c12Groups <- replicateM (fromIntegral c12NGroups) parseF12Group
return CmapFormat12{c12Format = 12, ..}
where parseF12Group = do
f12StartCharCode <- getULong
f12EndCharCode <- getULong
f12StartGlyphId <- getULong
return F12Group{..}
parseCmapSubTable n = error $ "subtable format not implemented " ++ show n
parseCmapEncoding :: B.ByteString -> Int -> CmapTable
parseCmapEncoding font offset =
fromRight $ runGet (do
skip offset
format <- getUShort
parseCmapSubTable $ fromIntegral format) font
parseCmap :: Map String TableDirectory -> B.ByteString -> Cmap
parseCmap tds font =
fromRight $ runGet (do
let tableStart = fromIntegral $ tDOffset $ tds ! "cmap"
skip tableStart
cmapVersion <- getUShort
numberOfSubtables <- getUShort
encodingDirectories <- replicateM (fromIntegral numberOfSubtables) parseCmapEncodingDirectory
let subTables = map (parseCmapEncoding font . (+ tableStart) . fromIntegral . cmapOffset) encodingDirectories
return Cmap{..}) font
parse :: B.ByteString -> Get TTF
parse font = do
version <- getFixed
numTables <- getUShort
searchRange <- getUShort
entrySelector <- getUShort
rangeShift <- getUShort
tableDirectories <- parseTableDirectories font (fromIntegral numTables)
let os2 = parseOS2 tableDirectories font
head = parseHead tableDirectories font
hhea = parseHhea tableDirectories font
name = parseName tableDirectories font
cmap = parseCmap tableDirectories font
maxp = parseMaxp tableDirectories font
kern = parseKern tableDirectories font
glyphCount = (fromIntegral $ numGlyphs maxp)
loca = parseLoca (fromIntegral $ indexToLocFormat head) glyphCount tableDirectories font
hmtx = parseHmtx (fromIntegral $ numberOfHMetrics hhea) glyphCount tableDirectories font
glyfs = V.fromList $ parseGlyfs glyphCount (map fromIntegral $ locaOffsets loca) tableDirectories font
in
return TTF{..}