diff --git a/src/EOT.hs b/src/EOT.hs new file mode 100644 --- /dev/null +++ b/src/EOT.hs @@ -0,0 +1,88 @@ +module EOT( + generate +) where + +import Control.Monad +import Data.Binary.Put +import Data.Bits +import qualified Data.ByteString as B +import Data.List (find) +import Data.Maybe (fromJust, isJust) +import Data.Text.Encoding (encodeUtf16LE) +import Font +import Utils + +putULong :: ULong -> Put +putULong = putWord32le + +putByte :: Byte -> Put +putByte = putWord8 + +putUShort :: UShort -> Put +putUShort = putWord16le + +match :: UShort -> Name -> Maybe NameRecord +match nameId' name' = + find predicate records + where + records = nameRecords name' + predicate nr = + ((platformId nr == 1 && + encodingId nr == 0 && + languageId nr == 0) || + (platformId nr == 3 && + encodingId nr == 1 && + languageId nr == 0x0409)) && + nameId nr == nameId' + +putNameStr :: Name -> UShort -> PutM () +putNameStr name' i | isJust mnameRecord = do + putUShort $ fromIntegral $ B.length encodedStr + putByteString encodedStr + putUShort 0 + | otherwise = do + putUShort 0 + putUShort 0 + where mnameRecord = match i name' + nameRecord = fromJust mnameRecord + encodedStr = encodeUtf16LE $ str nameRecord + + +payload :: Font f => f -> B.ByteString -> Put +payload font rawFont = do + putULong (fromIntegral (B.length rawFont)) -- font size + putULong 0x00020001 + putULong 0 -- flags + let name' = name font + mapM_ putByte $ os2panose font + putByte 0x01 + putByte (if testBit (os2fsSelection font) 0 then 0x01 else 0) + putULong $ fromIntegral $ os2usWeightClass font + putUShort 0 -- embedding permission putUShort $ fsType os + putUShort 0x504C + putULong $ os2ulUnicodeRange1 font + putULong $ os2ulUnicodeRange2 font + putULong $ os2ulUnicodeRange3 font + putULong $ os2ulUnicodeRange4 font + putULong $ os2ulCodePageRange1 font + putULong $ os2ulCodePageRange2 font + putULong $ headCheckSumAdjusment font + replicateM_ 4 (putULong 0) + putUShort 0 + putNameStr name' 1 + putNameStr name' 2 + putNameStr name' 5 + putNameStr name' 4 + putUShort 0 -- RootString + putByteString rawFont + + +combine :: B.ByteString -> PutM () +combine rest = do + putULong $ fromIntegral $ B.length rest + 4 + putByteString rest + +generate :: Font f => f -> B.ByteString -> B.ByteString +generate font rawFont = + let rest = toStrict $ runPut (payload font rawFont) + in toStrict $ runPut $ combine rest diff --git a/src/Font.hs b/src/Font.hs new file mode 100644 --- /dev/null +++ b/src/Font.hs @@ -0,0 +1,309 @@ +{-# LANGUAGE RecordWildCards #-} + +module Font( + Font(..) + + -- parser + , Byte + , Font.Char + , UShort + , Short + , FWord + , UFWord + , ULong + , Fixed + , getFixed + , getULong + , getUShort + , getShort + , getByte + , Font.getChar + , getFWord + , getUFWord + , getUFixed + + -- common font structure + , TableDirectory(..) + , Name(..) + , NameRecord(..) + , HMetric(..) + , Hmtx(..) + , OS2(..) + , Head(..) + + + , parseTableDirectory + , parseTableDirectories + , parseTable + , parseOS2 + , parseHead + , parseName +) where + +import Control.Monad +import Data.Binary.Strict.Get +import qualified Data.ByteString as B +import Data.ByteString.Char8 (unpack) +import Data.Int +import Data.Map hiding(map) +import qualified Data.Text as T +import Data.Text.Encoding.Error +import qualified Data.Vector as V +import Data.Word +import Utils +import Data.Text.Encoding + +-- font data types + +type Byte = Word8 +type Char = Int8 +type UShort = Word16 +type Short = Int16 +type FWord = Int16 +type UFWord = Word16 +type ULong = Word32 +-- type Long = Int32 +type Fixed = Word32 + + +getFixed :: Get Fixed +getFixed = liftM fromIntegral getWord32be + +getULong :: Get ULong +getULong = getWord32be + +getUShort :: Get UShort +getUShort = getWord16be + +getShort :: Get Short +getShort = liftM fromIntegral getWord16be + +getByte :: Get Byte +getByte = getWord8 + +getChar :: Get Font.Char +getChar = liftM fromIntegral getWord8 + +getFWord :: Get FWord +getFWord = getShort + +getUFWord :: Get UFWord +getUFWord = getUShort + +-- format 2.14 +getUFixed :: Get Double +getUFixed = liftM ((/ 0x4000) . fromIntegral) getShort + + +--- common parsing utils +data TableDirectory = TableDirectory { tDTag :: String + , tDCheckSum :: ULong + , tDOffset :: ULong + , tDLength :: ULong + , tDRawData :: B.ByteString + } deriving (Show) + +data NameRecord = NameRecord { platformId :: UShort + , encodingId :: UShort + , languageId :: UShort + , nameId :: UShort + , strLength :: UShort + , strOffset :: UShort + , str :: T.Text + } deriving (Show) + +data Name = Name { formatSelector :: UShort + , numberOfNameRecords :: UShort + , storageOffset :: UShort + , nameRecords :: [NameRecord] + } deriving (Show) + +data HMetric = HMetric { advanceWidth :: UFWord + , lsb :: FWord + } deriving (Show) + +data Hmtx = Hmtx { hMetrics :: V.Vector HMetric + , leftSideBearings :: [FWord] + } deriving (Show) + +data OS2 = OS2 { os2Version :: UShort + , xAvgCharWidth :: Short + , usWeightClass :: UShort + , usWidthClass :: UShort + , fsType :: UShort + , ySubscriptXSize :: Short + , ySubscriptYSize :: Short + , ySubscriptXOffset :: Short + , ySubscriptYOffset :: Short + , ySuperscriptXSize :: Short + , ySuperscriptYSize :: Short + , ySuperscriptXOffset :: Short + , ySuperscriptYOffset :: Short + , yStrikeoutSize :: Short + , yStrikeoutPosition :: Short + , sFamilyClass :: Short + , panose :: [Byte] + , ulUnicodeRange1 :: ULong + , ulUnicodeRange2 :: ULong + , ulUnicodeRange3 :: ULong + , ulUnicodeRange4 :: ULong + , aschVendID :: [Byte] + , fsSelection :: UShort + , usFirstCharIndex :: UShort + , usLastCharIndex :: UShort + , sTypoAscender :: UShort + , sTypoDescender :: UShort + , sTypoLineGap :: UShort + , usWinAscent :: UShort + , usWinDescent :: UShort + , ulCodePageRange1 :: ULong + , ulCodePageRange2 :: ULong + } deriving (Show) + +parseTableDirectory :: B.ByteString -> Get TableDirectory +parseTableDirectory font = do + tDTag <- liftM unpack $ getByteString 4 + tDCheckSum <- getULong + tDOffset <- getULong + tDLength <- getULong + let tDRawData = substr (fromIntegral tDOffset) (fromIntegral tDLength) font + return TableDirectory{..} + +parseTableDirectories :: B.ByteString -> Int -> Get (Map String TableDirectory) +parseTableDirectories font n = do + list <- replicateM n $ parseTableDirectory font + return $ fromList $ map (\x -> (tDTag x, x)) list + +parseTable :: String -> Get a -> Map String TableDirectory -> B.ByteString -> a +parseTable name' m tds font = + fromRight $ runGet (do + skip $ fromIntegral . tDOffset $ tds ! name' + m) font + +parseOS2 :: Map String TableDirectory -> B.ByteString -> OS2 +parseOS2 = parseTable "OS/2" (do + os2Version <- getUShort + unless (os2Version `elem` [1..4]) (error $ "unhandled os2 version " ++ show os2Version) + xAvgCharWidth <- getShort + usWeightClass <- getUShort + usWidthClass <- getUShort + fsType <- getUShort + ySubscriptXSize <- getShort + ySubscriptYSize <- getShort + ySubscriptXOffset <- getShort + ySubscriptYOffset <- getShort + ySuperscriptXSize <- getShort + ySuperscriptYSize <- getShort + ySuperscriptXOffset <- getShort + ySuperscriptYOffset <- getShort + yStrikeoutSize <- getShort + yStrikeoutPosition <- getShort + sFamilyClass <- getShort + panose <- replicateM 10 getByte + ulUnicodeRange1 <- getULong + ulUnicodeRange2 <- getULong + ulUnicodeRange3 <- getULong + ulUnicodeRange4 <- getULong + aschVendID <- replicateM 4 getByte + fsSelection <- getUShort + usFirstCharIndex <- getUShort + usLastCharIndex <- getUShort + sTypoAscender <- getUShort + sTypoDescender <- getUShort + sTypoLineGap <- getUShort + usWinAscent <- getUShort + usWinDescent <- getUShort + ulCodePageRange1 <- getULong + ulCodePageRange2 <- getULong + return OS2 {..}) + +data Head = Head { headVersion :: Fixed + , fontRevision :: Fixed + , checkSumAdjusment :: ULong + , magicNumber :: ULong + , headFlags :: UShort + , unitsPerEm :: UShort + , created :: B.ByteString + , modified :: B.ByteString + , xMin :: FWord + , yMin :: FWord + , xMax :: FWord + , yMax :: FWord + , macStyle :: UShort + , lowestRecPPEM :: UShort + , fontDirectionHint :: Short + , indexToLocFormat :: Short + , glyphDataFormat :: Short + } deriving (Show) + +parseHead :: Map String TableDirectory -> B.ByteString -> Head +parseHead = parseTable "head" (do + headVersion <- getFixed + fontRevision <- getFixed + checkSumAdjusment <- getULong + magicNumber <- getULong + headFlags <- getUShort + unitsPerEm <- getUShort + created <- getByteString 8 + modified <- getByteString 8 + xMin <- getFWord + yMin <- getFWord + xMax <- getFWord + yMax <- getFWord + macStyle <- getUShort + lowestRecPPEM <- getUShort + fontDirectionHint <- getShort + indexToLocFormat <- getShort + glyphDataFormat <- getShort + return Head{..}) + +parseNameRecord :: B.ByteString -> Int -> Get NameRecord +parseNameRecord font storageOffset = do + platformId <- getUShort + encodingId <- getUShort + languageId <- getUShort + nameId <- getUShort + strLength <- getUShort + strOffset <- getUShort + let str = decoder platformId encodingId $ substr + (fromIntegral ((fromIntegral storageOffset :: Int) + fromIntegral strOffset)) (fromIntegral strLength) font + return NameRecord{..} + where + decoder 3 _ = decodeUtf16BE + decoder 2 _ = decodeUtf16BE + decoder 1 _ = decodeUtf8With ignore + decoder 0 _ = decodeUtf16BE + decoder _ _ = decodeUtf16BE + +parseName ::Map String TableDirectory -> B.ByteString -> Name +parseName tds font = + fromRight $ runGet (do + let tableStart = fromIntegral $ tDOffset $ tds ! "name" + skip tableStart + formatSelector <- getUShort + numberOfNameRecords <- getUShort + storageOffset <- getUShort + nameRecords <- replicateM (fromIntegral numberOfNameRecords) $ parseNameRecord font (tableStart + fromIntegral storageOffset) + return Name{..}) font + +class Font a where + version :: a -> Fixed + numTables :: a -> UShort + tableDirectories :: a -> Map String TableDirectory + +-- os2 + os2panose :: a -> [Byte] + os2fsSelection :: a -> UShort + os2usWeightClass :: a -> UShort + os2ulUnicodeRange1 :: a -> ULong + os2ulUnicodeRange2 :: a -> ULong + os2ulUnicodeRange3 :: a -> ULong + os2ulUnicodeRange4 :: a -> ULong + os2ulCodePageRange1 :: a -> ULong + os2ulCodePageRange2 :: a -> ULong + +-- head + headCheckSumAdjusment :: a -> ULong + +-- name + name :: a -> Name diff --git a/src/OTF.hs b/src/OTF.hs new file mode 100644 --- /dev/null +++ b/src/OTF.hs @@ -0,0 +1,52 @@ +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# LANGUAGE RecordWildCards #-} + +module OTF( + OTF(..) + , parse +) where + +import qualified Data.ByteString as B +import Data.Binary.Strict.Get +import Data.Map +import Font + +instance Font OTF where + version = OTF.version + numTables = OTF.numTables + tableDirectories = OTF.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 . OTF.head + name = OTF.name + +data OTF = OTF { version :: Fixed + , numTables :: UShort + , searchRange :: UShort + , entrySelector :: UShort + , rangeShift :: UShort + , tableDirectories :: Map String TableDirectory + , os2 :: OS2 + , head :: Head + , name :: Name + } deriving (Show) + +parse :: B.ByteString -> Get OTF +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 + name = parseName tableDirectories font + return OTF{..} diff --git a/src/SVG.hs b/src/SVG.hs new file mode 100644 --- /dev/null +++ b/src/SVG.hs @@ -0,0 +1,236 @@ +module SVG( + generate +) where + +import Data.Bits +import qualified Data.ByteString as B +import Data.Char +import Data.List (find, foldl', intercalate) +import Data.Maybe (fromJust) +import qualified Data.Text as T +import qualified Data.Map as M +import TTF +import Font hiding (Char, name) +import Text.XML.Generator +import Numeric +import Utils +import Data.Vector as V ((!), length, last) + +byNameId :: UShort -> TTF -> T.Text +byNameId id' ttf = + str $ fromJust $ find predicate $ nameRecords $ name ttf + where predicate nr = + nameId nr == id' + +fontFamilyName :: TTF -> T.Text +fontFamilyName = byNameId 1 + +svgDocType :: String +svgDocType = "" + +svgDocInfo :: DocInfo +svgDocInfo = DocInfo { docInfo_standalone = False + , docInfo_docType = Just svgDocType + , docInfo_preMisc = xempty + , docInfo_postMisc = xempty } + + +advanceX :: Hmtx -> Int -> UFWord +advanceX hmtx' id' = + advanceWidth hMetric + where hMetrics' = hMetrics hmtx' + hMetric | id' < V.length hMetrics' = hMetrics' ! id' + | otherwise = V.last hMetrics' + + +formatCoordinate :: Double -> String +formatCoordinate x + | fromIntegral floored == x = show floored + | otherwise = formatFloat 1 x + where floored = floor x :: Int + formatFloat precision a = showFFloat (Just precision) a "" + +formatCoordinates :: Double -> Double -> String +formatCoordinates x y = formatCoordinate x ++ " " ++ formatCoordinate y + +midval :: Double -> Double -> Double +midval a b = a + (b - a) / 2 + +toUpcase :: String -> String +toUpcase = map toUpper + +shortestPath :: String -> [(String, String)] -> String +shortestPath command coordinates + | Prelude.length relative < Prelude.length absolute = command ++ relative + | otherwise = toUpcase command ++ absolute + where relative = unwords (map fst coordinates) + absolute = unwords (map snd coordinates) + + +contourPath :: [(Double, Double, Int)] -> String +contourPath contour = + "M" ++ formatCoordinates x' y' ++ path 0 ccontour x' y' + where (x', y', _) = Prelude.head contour + onCurve flag = testBit flag 0 + ccontour = cycle contour + second = Prelude.head . tail + third = Prelude.head . tail . tail + path n ccontour' lastx lasty | n >= Prelude.length contour = "Z" + | otherwise = + let (x, y, f) = Prelude.head ccontour' + (x1, y1, f1) = second ccontour' + (x2, y2, f2) = third ccontour' + showx x'' = (formatCoordinate (x'' - lastx), formatCoordinate x'') + showy y'' = (formatCoordinate (y'' - lasty), formatCoordinate y'') + showxy x'' y'' = (formatCoordinates (x'' - lastx) (y'' - lasty), formatCoordinates x'' y'') + sp = shortestPath + without i = path (n + i) (drop i ccontour') + next True True _ | x == x1 = sp "v" [showy y1] ++ rest + | y == y1 = sp "h" [showx x1] ++ rest + | otherwise = sp "l" [showxy x1 y1] ++ rest + where rest = without 1 x1 y1 + next True False True = sp "q" [showxy x1 y1, showxy x2 y2] ++ without 2 x2 y2 + next True False False = sp "q" [showxy x1 y1, showxy (midval x1 x2) (midval y1 y2)] ++ rest + where rest = without 2 (midval x1 x2) (midval y1 y2) + next False False _ = sp "t" [showxy (midval x x1) (midval y y1)] ++ rest + where rest = without 1 (midval x x1) (midval y y1) + next False True _ = sp "t" [showxy x1 y1] ++ rest + where rest = without 1 x1 y1 + -- rest not implemented + in + next (onCurve f) (onCurve f1) (onCurve f2) + + +glyphPoints :: Glyf -> TTF -> [[(Double, Double, Int)]] +glyphPoints EmptyGlyf _ = [] +glyphPoints CompositeGlyf{cGlyfs = cglyfs} ttf = + concatMap cglyhPoints cglyfs + where + cglyhPoints cg = map (map (transform cg)) (glyphPoints (glyf $ cGlyphIndex cg) ttf) + glyf index = glyfs ttf ! fromIntegral index + transform cg (x, y, flag) = + ((x * cXScale cg + y * cScale10 cg) + fromIntegral (cXoffset cg) + , (y * cYScale cg + x * cScale01 cg) + fromIntegral (cYoffset cg) + , flag) + +glyphPoints glyph _ = + reverse bpts + where endPts = map fromIntegral $ sEndPtsOfCountours glyph + pts = zipWith3 (\x y f -> (fromIntegral x, fromIntegral y, fromIntegral f)) (sXCoordinates glyph) (sYCoordinates glyph) (sFlags glyph) + splitPts (ac, offset', pts') x = (take (x - offset') pts' : ac, x, drop (x - offset') pts') + (bpts, _, _) = foldl' splitPts ([], -1, pts) endPts + + +svgPath :: Glyf -> TTF -> String +svgPath glyf ttf = foldl' (++) "" $ map contourPath (glyphPoints glyf ttf) + + +escapeXMLChar :: Char -> String +escapeXMLChar '<' = "<" +escapeXMLChar '>' = ">" +escapeXMLChar '&' = "&" +escapeXMLChar '"' = """ +escapeXMLChar '\'' = "'" +escapeXMLChar c | oc <= 0x7f && isPrint c = [c] + | otherwise = "&#x" ++ showHex oc "" ++ ";" + where oc = ord c + +svgGlyph :: TTF -> CmapTable -> Int -> Int -> Xml Elem +svgGlyph ttf cmapTable averageAdvanceX code = + xelem "glyph" (xattrs ([xattrRaw "unicode" (escapeXMLChar $ chr code)] ++ + horizAdvanceXAttr ++ + [xattrRaw "d" $ svgPath glyph ttf])) + where glyphId' = glyphId cmapTable code + glyph = glyfs ttf ! glyphId' + horizAdvanceX = fromIntegral $ advanceX (hmtx ttf) glyphId' + horizAdvanceXAttr | horizAdvanceX == averageAdvanceX = [] + | otherwise = [xattrRaw "horiz-adv-x" $ show horizAdvanceX] + + +missingGlyph :: TTF -> Xml Elem +missingGlyph ttf = + xelem "missing-glyph" (xattrs [xattr "horiz-adv-x" $ show $ advanceX (hmtx ttf) 0, + xattr "d" $ svgPath glyph ttf]) + where glyph = glyfs ttf ! 0 + + +validCharCode :: Int -> Bool +validCharCode n | n == 0x9 = True + | n == 0xA = True + | n == 0xD = True + | n >= 0x20 && n <= 0xD7FF = True + | n >= 0xE000 && n <= 0xFFFD = True + | n >= 0x1000 && n <= 0x10FFFF = True + | otherwise = False + +svgGlyphs :: TTF -> CmapTable -> (Xml Elem, Int) +svgGlyphs ttf cmapTable= + (xelems $ missingGlyph ttf : map (svgGlyph ttf cmapTable averageAdvanceX) validGlyphCodes, averageAdvanceX) + where codeRange = [(cmapStart cmapTable)..(cmapEnd cmapTable)] + validGlyph code = validCharCode code && glyphId cmapTable code > 0 + validGlyphCodes = filter validGlyph codeRange + averageAdvanceX = maxDuplicate $ map (fromIntegral . advanceX (hmtx ttf) . glyphId cmapTable) validGlyphCodes + +fontFace :: TTF -> Xml Elem +fontFace ttf = + xelem "font-face" (xattrs [xattr "font-family" $ fontFamilyName ttf, + xattr "units-per-em" $ show . unitsPerEm $ TTF.head ttf, + xattr "ascent" $ show . ascender $ hhea ttf, + xattr "descent" $ show . descender $ hhea ttf]) + + +svgKern :: M.Map Int [Int] -> KernPair -> Xml Elem +svgKern glyphIdToCodeMap KernPair{kpLeft = left, kpRight = right, + kpValue = value, kTCoverage = coverage} = + xelem ktype (xattrs [xattrRaw "u1" $ unicode left, + xattrRaw "u2" $ unicode right, + xattr "k" $ show (-value)]) + where unicode code = intercalate "," $ map (escapeXMLChar . chr . fromIntegral) (glyphIdToCodeMap M.! fromIntegral code) + ktype = if testBit coverage 0 then "hkern" else "vkern" + +glyphIdToCode :: CmapTable -> M.Map Int [Int] +glyphIdToCode cmapTable = + foldl build M.empty codeRange + where codeRange = [(cmapStart cmapTable)..(cmapEnd cmapTable)] + build m code | gid > 0 = M.alter (addCode code) gid m + | otherwise = m + where gid = glyphId cmapTable code + addCode code Nothing = Just [code] + addCode code (Just codes) = Just (code : codes) + +svgKerns :: TTF -> CmapTable -> Bool -> [Xml Elem] +svgKerns _ _ False = [] +svgKerns ttf cmapTable _ = + map (svgKern $ glyphIdToCode cmapTable) allKernPairs + where + allKernPairs = filter validKernPair $ concatMap kernPairs $ kernTables $ kern ttf + validKernPair KernPair{kpLeft = left, kpRight = right} = + glyphId cmapTable (fromIntegral left) > 0 && glyphId cmapTable (fromIntegral right) > 0 + +testText :: TTF -> Xml Elem +testText ttf = + xelem "g" (xattr "style" ("font-family: " ++ show (fontFamilyName ttf) ++ "; font-size:50;fill:black") <#> + xelems (zipWith text ["!\"#$%&'()*+,-./0123456789:;å<>?", + "@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_", + "` abcdefghijklmnopqrstuvwxyz|{}~"] [1..])) + where + text :: String -> Int -> Xml Elem + text t i = xelem "text" (xattrs [xattr "x" "20", + xattr "y" $ show (i * 50)] <#> xtext t) + +svgbody :: TTF -> CmapTable -> Bool -> Xml Elem +svgbody ttf cmapTable enableKern = + xelems [xelemEmpty "metadata", + xelem "defs" $ + xelem "font" (xattrs [xattr "horiz-adv-x" $ show avgAdvanceX] <#> + xelems ([fontFace ttf, + glyps] ++ svgKerns ttf cmapTable enableKern)), + testText ttf] + where (glyps, avgAdvanceX) = svgGlyphs ttf cmapTable + +generate :: TTF -> B.ByteString -> CmapTable -> Bool -> B.ByteString +generate ttf _font cmapTable enableKern = + xrender svg + where + svg = doc svgDocInfo $ + xelem "svg" (xattr "xmlns" "http://www.w3.org/2000/svg" <#> svgbody ttf cmapTable enableKern) diff --git a/src/TTF.hs b/src/TTF.hs new file mode 100644 --- /dev/null +++ b/src/TTF.hs @@ -0,0 +1,583 @@ +{-# 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(map, findIndex) +import Data.Maybe +import qualified Data.Vector as V +import Utils +import Font + + +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{..} diff --git a/src/Utils.hs b/src/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Utils.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE RecordWildCards #-} +module Utils( + fromRight + , substr + , toStrict + , toLazy + , diff + , debug + , formatTable + , maxDuplicate +) where + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import Control.Monad +import Debug.Trace +import Data.List +import Text.Printf +import Data.Function + +fromRight :: (Either String t2, t) -> t2 +fromRight (Right x, _) = x +fromRight (Left y, _) = error y + +substr :: Int -> Int -> B.ByteString -> B.ByteString +substr s l = B.take l . B.drop s + +toStrict :: BL.ByteString -> B.ByteString +toStrict = B.concat . BL.toChunks + +toLazy :: B.ByteString -> BL.ByteString +toLazy str = BL.fromChunks [str] + +diff :: Num b => [b] -> [b] +diff l = zipWith (-) l $ tail l + +formatTable :: [[String]] -> String +formatTable table = + line ++ unlines (map formatRow table) ++ line + where maxSize = map maximum $ transpose $ map (map length) table + line = concat (replicate (sum maxSize + (length maxSize - 1) * 3) "-") ++ "\n" + formatRow row = intercalate " | " $ zipWith formatCell row maxSize + formatCell :: String -> Int -> String + formatCell field size = printf ("%-" ++ show size ++ "s") field + +maxDuplicate :: [Int] -> Int +maxDuplicate = head . minimumBy (compare `on` (negate . length)) . group . sort + +debug :: Monad m => String -> m () +debug str = + when True $ trace str $ return () diff --git a/src/WOFF.hs b/src/WOFF.hs new file mode 100644 --- /dev/null +++ b/src/WOFF.hs @@ -0,0 +1,98 @@ +module WOFF( + generate +) where + +import qualified Codec.Compression.Hopfli as Hopfli +import qualified Codec.Compression.Zlib as Zlib +import Control.Monad +import Data.Binary.Put +import qualified Data.ByteString as B +import Data.ByteString.Char8 (pack) +import Data.Function +import Data.List +import qualified Data.Map as Map +import Data.Word +import Font +import Utils + + +type UInt32 = Word32 +type UInt16 = Word16 + +putUInt32 :: UInt32 -> Put +putUInt32 = putWord32be + +putUInt16 :: UInt16 -> Put +putUInt16 = putWord16be + +putTableDirectory :: + ((Int, Int, Int, B.ByteString), TableDirectory) -> PutM () +putTableDirectory ((startOffset, size, _padding, _compressedData), directory) = do + putByteString $ pack $ tDTag directory + putUInt32 $ fromIntegral startOffset + putUInt32 $ fromIntegral size + putUInt32 $ fromIntegral $ tDLength directory + putUInt32 $ tDCheckSum directory + + +type Compressor = B.ByteString -> B.ByteString + +getCompressor :: Bool -> Compressor +getCompressor False = toStrict . Zlib.compress . toLazy +getCompressor True = Hopfli.compress + +calculateOffset :: + Compressor -> + [(Int, Int, Int, B.ByteString)] -> B.ByteString + -> [(Int, Int, Int, B.ByteString)] +calculateOffset compressor offsets raw = + (start, size, padding, compressedData) : offsets + where originalSize = B.length raw + compressed = compressor raw + compressedSize = B.length compressed + compressedData | originalSize <= compressedSize = raw + | otherwise = compressed + size = min originalSize compressedSize + (lastStart, lastSize, lastPadding, _) = head offsets + start = lastStart + lastSize + lastPadding + padding | (size `mod` 4) == 0 = 0 + | otherwise = 4 - (size `mod` 4) + +putFontData :: (Int, Int, Int, B.ByteString) -> PutM () +putFontData (_, _, padding, compressedData) = do + putByteString compressedData + replicateM_ padding (putWord8 0x0) + +payload :: Font f => f -> B.ByteString -> Bool -> Put +payload font rawFont enableZopfli = do + putUInt16 $ numTables font + putUInt16 0 -- reserved + putUInt32 $ fromIntegral $ B.length rawFont + putUInt16 1 -- woff version major + putUInt16 0 -- woff version minor + putUInt32 0 -- meta offset + putUInt32 0 -- meta length + putUInt32 0 -- meta length uncompressed + putUInt32 0 -- private block offset + putUInt32 0 -- private block length + let tds = Map.elems $ tableDirectories font + sortByOffset = sortBy (compare `on` tDOffset) + sortedByTag = sortBy (compare `on` tDTag . snd) + initialOffset = [(fromIntegral (44 + (20 * numTables font)), 0, 0, pack "")] + offsets = drop 1 $ reverse $ + foldl (calculateOffset $ getCompressor enableZopfli) initialOffset (map tDRawData $ sortByOffset tds) + mapM_ putTableDirectory $ sortedByTag $ zip offsets (sortByOffset tds) + mapM_ putFontData offsets + + +combine :: Font f => f -> B.ByteString -> PutM () +combine font rest = do + putUInt32 0x774F4646 + putUInt32 $ version font + putUInt32 $ fromIntegral $ B.length rest + 12 + putByteString rest + +generate :: Font f => f -> B.ByteString -> Bool -> B.ByteString +generate font rawFont enableZopfli = + let rest = toStrict $ runPut (payload font rawFont enableZopfli) + in toStrict $ runPut $ combine font rest diff --git a/src/Webify.hs b/src/Webify.hs --- a/src/Webify.hs +++ b/src/Webify.hs @@ -121,7 +121,7 @@ displayError :: FilePath -> SomeException -> IO () displayError file e = (putStrLn $ "Failed to convert " ++ file) >> (putStrLn $ show e) -webifyVersion = "0.1.5.0" +webifyVersion = "0.1.6.0" main :: IO () main = do diff --git a/webify.cabal b/webify.cabal --- a/webify.cabal +++ b/webify.cabal @@ -1,5 +1,5 @@ name: webify -version: 0.1.5.0 +version: 0.1.6.0 synopsis: webfont generator description: A command line tool to convert ttf file to woff, eot & svg files @@ -20,11 +20,11 @@ executable webify hs-source-dirs: src main-is: Webify.hs + other-modules: EOT, Font, OTF, SVG, TTF, Utils, WOFF if flag(debug) ghc-prof-options: -prof, -fprof-auto - -- other-modules: build-depends: base ==4.6.*, containers >= 0.4.2.1, bytestring >= 0.9,