{-# 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 (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{..}