diff --git a/FontyFruity.cabal b/FontyFruity.cabal --- a/FontyFruity.cabal +++ b/FontyFruity.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: FontyFruity -version: 0.3 +version: 0.4 synopsis: A true type file format loader description: A haskell Truetype file parser. @@ -28,8 +28,7 @@ Source-Repository this Type: git Location: https://github.com/Twinside/FontyFruity.git - Tag: v0.3 - + Tag: v0.4 library exposed-modules: Graphics.Text.TrueType diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,5 +1,10 @@ -*-change-log-*- +v0.4 + * Adding function to get back unplaced glyph. + * Adding Binary instance for Font cache. + * Fixing font cache. + v0.3 June 2014 * Adding a font finding function * Adding a font cache type to speed-up frequent font diff --git a/src/Graphics/Text/TrueType.hs b/src/Graphics/Text/TrueType.hs --- a/src/Graphics/Text/TrueType.hs +++ b/src/Graphics/Text/TrueType.hs @@ -8,27 +8,37 @@ decodeFont , loadFontFile , getStringCurveAtPoint + , unitsPerEm + , isPlaceholder + , getCharacterGlyphsAndMetrics + , getGlyphForStrings , stringBoundingBox , findFontOfFamily -- * Font cache , FontCache , FontDescriptor( .. ) + , emptyFontCache , findFontInCache , buildCache + , enumerateFonts -- * Types - , Font( .. ) + , Font , FontStyle( .. ) + , RawGlyph( .. ) , Dpi , PointSize + , CompositeScaling ( .. ) ) where import Control.Applicative( (<$>) ) import Control.Monad( foldM, forM ) import Data.Function( on ) +import Data.Int ( Int16 ) import Data.List( sortBy, mapAccumL, foldl' ) import Data.Word( Word16 ) +import Data.Monoid( mempty ) import Data.Binary( Binary( .. ) ) import Data.Binary.Get( Get , bytesRead @@ -120,13 +130,13 @@ getGlyph :: Font -> LB.ByteString -> Get Font getGlyph font@(Font { _fontLoca = Just locations }) str = - return font { _fontGlyph = Just . V.map decoder $ VU.convert locationInterval } + return font { _fontGlyph = Just . V.map decoder $ VU.convert locationInterval } where decoder (xStart, xEnd) | xEnd <= xStart = emptyGlyph | otherwise = decodeWithDefault emptyGlyph $ chop xStart xEnd chop start _ = LB.drop (fromIntegral start) str - locationsAll = locations `VU.snoc` (fromIntegral $ LB.length str) + locationsAll = locations `VU.snoc` fromIntegral (LB.length str) locationInterval = VU.zip locations $ VU.tail locationsAll getGlyph font _ = return font @@ -149,7 +159,7 @@ (B.unpack $ _tdeTag entry,) <$> getLazyByteString (fromIntegral $ _tdeLength entry) foldM (fetch tableData) (emptyFont offsetTable) tableList - + where getFetch tables name getter = case [str | (n, str) <- tables, n == name] of @@ -187,7 +197,7 @@ fetch tables font "loca" = getFetch tables "loca" (getLoca font) - fetch tables font "hmtx" = do + fetch tables font "hmtx" = getFetch tables "hmtx" (getHmtx font) fetch _ font _ = return font @@ -201,7 +211,7 @@ getFontNameAndStyle = (filterTable isNecessaryForName <$> get) >>= fetchTables ["head", "name"] where - isNecessaryForName v = v == "name" || v == "head" + isNecessaryForName v = v == "name" || v == "head" -- | This function will search in the system for truetype -- files and index them in a cache for further fast search. @@ -244,6 +254,7 @@ fetcher ix = (glyphes V.! ix, _glyphMetrics hmtx V.! ix) glyphOfStrings _ _ = [] +-- | Return the number of pixels relative to the point size. unitsPerEm :: Font -> Word16 unitsPerEm Font { _fontHeader = Just hdr } = fromIntegral $ _fUnitsPerEm hdr @@ -299,8 +310,35 @@ getGlyphIndexCurvesAtPointSizeAndPos font dpi (toFCoord p maximumSize) (pointSize, glyph) (xi + bearing, yi) +-- | This function return the list of all contour for all char with the given +-- font in a string. All glyph are at the same position, they are not placed +-- like with `getStringCurveAtPoint`. It is a function helpful to extract +-- the glyph geometry for further external manipulation. +getGlyphForStrings :: Dpi -> [(Font, PointSize, String)] + -> [[VU.Vector (Float, Float)]] +getGlyphForStrings dpi lst = go <$> glyphes where + glyphes = concat + [(font, size, fromIntegral $ unitsPerEm font,) + <$> glyphOfStrings font str | (font, size, str) <- lst] -getGlyphIndexCurvesAtPointSizeAndPos :: Font -> Dpi -> Int -> (PointSize, Glyph) -> (Int, Int) + toFCoord (_, pointSize, emSize, _) v = floor $ v * emSize / pixelSize :: Int + where + pixelSize = fromIntegral (pointSize * dpi) / 72 + + toPixel pointSize emSize v = fromIntegral v * pixelSize / emSize + where + pixelSize = fromIntegral (pointSize * dpi) / 72 + + maximumSize :: Float + maximumSize = maximum [ toPixel pointSize em . _glfYMax $ _glyphHeader glyph + | (_, pointSize, em, (glyph, _)) <- glyphes ] + + go p@(font, pointSize, _, (glyph, _metric)) = + getGlyphIndexCurvesAtPointSizeAndPos + font dpi (toFCoord p maximumSize) (pointSize, glyph) (0, 0) + +getGlyphIndexCurvesAtPointSizeAndPos :: Font -> Dpi -> Int -> (PointSize, Glyph) + -> (Int, Int) -> [VU.Vector (Float, Float)] getGlyphIndexCurvesAtPointSizeAndPos Font { _fontHeader = Nothing } _ _ _ _ = [] getGlyphIndexCurvesAtPointSizeAndPos Font { _fontGlyph = Nothing } _ _ _ _ = [] @@ -317,7 +355,7 @@ maxiF = toPixelCoordinate (0 :: Int) maximumSize baseYF = toPixelCoordinate (0 :: Int) baseY - glyphReverse = VU.map (\(x,y) -> (x, maxiF - y + baseYF)) + glyphReverse = VU.map (\(x,y) -> (x, baseYF - y)) toPixelCoordinate shift coord = (fromIntegral (shift + fromIntegral coord) * pixelSize) / emSize @@ -341,8 +379,8 @@ cm = toFloat ci / m bn = toFloat ci / n dn = toFloat di / n - e = toFloat ei - f = toFloat fi + e = fromIntegral ei + f = fromIntegral fi updateCoords (x,y) = (m * (am * x + cm *y + e), n * (bn * x + dn * y + f)) @@ -351,6 +389,68 @@ glyphExtract Glyph { _glyphContent = GlyphComposite compositions _ } = concatMap composeGlyph $ V.toList compositions glyphExtract Glyph { _glyphContent = GlyphSimple countour } = - [ VU.map (\(x, y) -> (toPixelCoordinate baseX x, toPixelCoordinate (0 :: Int) y)) c - | c <- extractFlatOutline countour] + [ VU.map mapper c | c <- extractFlatOutline countour] + where + mapper (x,y) = + (toPixelCoordinate baseX x, toPixelCoordinate (0 :: Int) y) + +-- | True if the character is not present in the font, therefore it +-- will appear as a placeholder in renderings. +isPlaceholder :: Font -> Char -> Bool +isPlaceholder Font { _fontMap = Just fontMap } character = + findCharGlyph fontMap 0 character == 0 +isPlaceholder Font { _fontMap = Nothing } _ = True + +-- | Retrive the glyph contours and associated transformations. +-- The coordinate system is assumed to be the TTF one (y upward). +-- No transformation is performed. +getCharacterGlyphsAndMetrics :: Font + -> Char + -> (Float, V.Vector RawGlyph) -- ^ Advance and glyph information. +getCharacterGlyphsAndMetrics + Font { _fontMap = Just mapping + , _fontGlyph = Just allGlyphs + , _fontHorizontalMetrics = Just hmtx } + character = + (advance, getCharacterGlyphs allGlyphs allMetrics glyphIndex) + where + glyphIndex = findCharGlyph mapping 0 character + allMetrics = _glyphMetrics hmtx + metrics = allMetrics V.! glyphIndex + advance = fromIntegral (_hmtxAdvanceWidth metrics) +getCharacterGlyphsAndMetrics _ _ = (0, mempty) + +-- | This type represent unscaled glyph information, everything +-- is still in its raw form. +data RawGlyph = RawGlyph + { -- | List of transformations to apply to the contour in order + -- to get their correct placement. + _rawGlyphCompositionScale :: ![CompositeScaling] + + -- | Glyph index in the current font. + , _rawGlyphIndex :: !Int + + -- | Real Geometry of glyph, each vector contain one + -- contour. + , _rawGlyphContour :: ![VU.Vector (Int16, Int16)] + } + +prependScale :: CompositeScaling -> RawGlyph -> RawGlyph +prependScale scale rGlyph = + rGlyph { _rawGlyphCompositionScale = scale : _rawGlyphCompositionScale rGlyph } + +getCharacterGlyphs :: V.Vector Glyph -> V.Vector HorizontalMetric -> Int + -> V.Vector RawGlyph +getCharacterGlyphs allGlyphs allMetrics glyphIndex = + case _glyphContent (allGlyphs V.! glyphIndex) of + GlyphEmpty -> mempty + GlyphComposite compositions _ -> V.concatMap expandComposition compositions + GlyphSimple countour -> + V.singleton . RawGlyph mempty glyphIndex $ extractFlatOutline countour + where + recurse = getCharacterGlyphs allGlyphs allMetrics + + expandComposition GlyphComposition { _glyphCompositeIndex = index + , _glyphCompositionScale = scale } = + V.map (prependScale scale) . recurse $ fromIntegral index diff --git a/src/Graphics/Text/TrueType/CharacterMap.hs b/src/Graphics/Text/TrueType/CharacterMap.hs --- a/src/Graphics/Text/TrueType/CharacterMap.hs +++ b/src/Graphics/Text/TrueType/CharacterMap.hs @@ -20,7 +20,7 @@ import Data.Binary.Put( putWord16be , putWord32be ) import Data.Int( Int16 ) -import Data.List( find, sortBy ) +import Data.List( find, sort, sortBy ) import qualified Data.Map.Strict as M import Data.Maybe( fromMaybe ) import Data.Word( Word8, Word16, Word32 ) @@ -163,8 +163,8 @@ findCharGlyph :: CharacterMaps -> LangId -> Char -> Int findCharGlyph (CharacterMaps charMaps) langId character = - fromMaybe 0 $ find (/= 0) - [charTableMap (flip glyphIdFromTable character) m + fromMaybe 0 . find (/= 0) . map snd . sort $ + [(_charMapPlatformId allMap, charTableMap (`glyphIdFromTable` character) m) | allMap <- charMaps , let m = _charMap allMap , isLangCompatible m] @@ -174,13 +174,13 @@ instance Ord CharacterTable where compare (TableFormat0 v1) (TableFormat0 v2) = - (comparing langIdOfCharMap) v1 v2 + comparing langIdOfCharMap v1 v2 compare (TableFormat2 v1) (TableFormat2 v2) = - (comparing langIdOfCharMap) v1 v2 + comparing langIdOfCharMap v1 v2 compare (TableFormat4 v1) (TableFormat4 v2) = - (comparing langIdOfCharMap) v1 v2 + comparing langIdOfCharMap v1 v2 compare (TableFormat6 v1) (TableFormat6 v2) = - (comparing langIdOfCharMap) v1 v2 + comparing langIdOfCharMap v1 v2 compare (TableFormat0 _) _ = LT compare (TableFormat2 _) _ = LT compare (TableFormat4 _) _ = LT @@ -268,7 +268,7 @@ $ concatMap (prepare segCount indexTable) rangeInfo where prepare _ _ (start, end, delta, 0, _) = - [(fromIntegral $ char, fromIntegral $ char + delta) + [(fromIntegral char, fromIntegral $ char + delta) | char <- [start .. end]] prepare segCount indexTable (start, end, delta, rangeOffset, ix) = diff --git a/src/Graphics/Text/TrueType/FontFolders.hs b/src/Graphics/Text/TrueType/FontFolders.hs --- a/src/Graphics/Text/TrueType/FontFolders.hs +++ b/src/Graphics/Text/TrueType/FontFolders.hs @@ -1,4 +1,4 @@ - +{-# LANGUAGE OverloadedStrings #-} module Graphics.Text.TrueType.FontFolders ( loadUnixFontFolderList , loadWindowsFontFolderList @@ -6,15 +6,29 @@ , findFont , FontCache( .. ) , FontDescriptor( .. ) + , emptyFontCache , buildFontCache + , enumerateFonts ) where +import Control.Monad( when, replicateM ) import Control.Applicative( (<$>), (<*>) ) {-import Control.DeepSeq( ($!!) )-} {-import Data.Monoid( (<>) )-} import System.Directory( getDirectoryContents + , getHomeDirectory , doesDirectoryExist + , doesFileExist ) +import qualified Data.ByteString as B +import Data.Binary( Binary( .. ) ) +import Data.Binary.Get( Get + , getWord32be + , getByteString + ) +import Data.Binary.Put( Put + , putWord32be + , putByteString ) import qualified Data.Map as M import System.Environment( lookupEnv ) import System.FilePath( () ) @@ -48,7 +62,7 @@ readDocument [withValidate no, withSubstDTDEntities no] "/etc/fonts/fonts.conf" >>> multi (isElem >>> hasName "dir" >>> getChildren >>> getText)) - + -- -} loadUnixFontFolderList :: IO [FilePath] @@ -67,14 +81,15 @@ toFontFolder Nothing = [] loadOsXFontFolderList :: IO [FilePath] -loadOsXFontFolderList = return - ["~/Library/Fonts" - ,"/Library/Fonts" - ,"/System/Library/Fonts" - ,"/System Folder/Fonts" - ] - +loadOsXFontFolderList = do + home <- getHomeDirectory + return [home "Library" "Fonts" + ,"/" "Library" "Fonts" + ,"/" "System" "Library" "Fonts" + ,"/" "System Folder" "Fonts" + ] + fontFolders :: IO [FilePath] fontFolders = do unix <- loadUnixFontFolderList @@ -92,16 +107,57 @@ } deriving (Eq, Ord, Show) +instance Binary FontDescriptor where + put (FontDescriptor t s) = put (T.unpack t) >> put s + get = FontDescriptor <$> (T.pack <$> get) <*> get + -- | A font cache is a cache listing all the found -- fonts on the system, allowing faster font lookup -- once created -newtype FontCache = +-- +-- FontCache is an instance of binary, to get okish +-- performance you should save it in a file somewhere +-- instead of rebuilding it everytime! +-- +-- The font cache is dependent on the version +-- of rasterific, you must rebuild it for every +-- version. +newtype FontCache = FontCache (M.Map FontDescriptor FilePath) +-- | Font cache with no pre-existing fonts in it. +emptyFontCache :: FontCache +emptyFontCache = FontCache M.empty + +signature :: B.ByteString +signature = "FontyFruity__FONTCACHE:0.4" + +putFontCache :: FontCache -> Put +putFontCache (FontCache cache) = do + putByteString signature + putWord32be . fromIntegral $ M.size cache + mapM_ put $ M.toList cache + +getFontCache :: Get FontCache +getFontCache = do + str <- getByteString $ B.length signature + when (str /= signature) $ + fail "Invalid font cache" + count <- fromIntegral <$> getWord32be + FontCache . M.fromList <$> replicateM count get + +instance Binary FontCache where + put = putFontCache + get = getFontCache + +-- | Returns a list of descriptors of fonts stored in the given cache. +enumerateFonts :: FontCache -> [FontDescriptor] +enumerateFonts (FontCache fs) = M.keys fs + -- | Look in the system's folder for usable fonts. buildFontCache :: (FilePath -> IO (Maybe Font)) -> IO FontCache buildFontCache loader = do - folders <- fontFolders + folders <- fontFolders found <- build [("", v) | v <- folders] return . FontCache $ M.fromList [(d, path) | (Just d, path) <- found] @@ -119,19 +175,22 @@ isDirectory <- doesDirectoryExist n if isDirectory then do - sub <- getDirectoryContents n + sub <- getDirectoryContents n (++) <$> build [(s, n s) | s <- sub] <*> build rest else do - f <- loader n - case f of - Nothing -> build rest - Just fo -> ((descriptorOf fo, n) :) <$> build rest + isFile <- doesFileExist n + if isFile then do + f <- loader n + case f of + Nothing -> build rest + Just fo -> ((descriptorOf fo, n) :) <$> build rest + else build rest findFont :: (FilePath -> IO (Maybe Font)) -> String -> FontStyle -> IO (Maybe FilePath) findFont loader fontName fontStyle = do - folders <- fontFolders + folders <- fontFolders searchIn [("", v) | v <- folders] where fontNameText = T.pack fontName @@ -151,7 +210,7 @@ findOrRest l = return l if isDirectory then do - sub <- getDirectoryContents n + sub <- getDirectoryContents n subRez <- searchIn [(s, n s) | s <- sub] findOrRest subRez else do diff --git a/src/Graphics/Text/TrueType/Glyph.hs b/src/Graphics/Text/TrueType/Glyph.hs --- a/src/Graphics/Text/TrueType/Glyph.hs +++ b/src/Graphics/Text/TrueType/Glyph.hs @@ -49,7 +49,7 @@ deriving (Eq, Show) instance NFData GlyphHeader where - rnf (GlyphHeader _ _ _ _ _) = () + rnf (GlyphHeader {}) = () emptyGlyphHeader :: GlyphHeader emptyGlyphHeader = GlyphHeader 0 0 0 0 0 @@ -73,13 +73,21 @@ rnf (GlyphContour instr fl points) = instr `seq` fl `seq` points `seq` () +-- | Transformation matrix used to transform composite +-- glyph +-- +-- @ +-- | a b c | +-- | d e f | +-- @ +-- data CompositeScaling = CompositeScaling - { _a :: {-# UNPACK #-} !Int16 - , _b :: {-# UNPACK #-} !Int16 - , _c :: {-# UNPACK #-} !Int16 - , _d :: {-# UNPACK #-} !Int16 - , _e :: {-# UNPACK #-} !Int16 - , _f :: {-# UNPACK #-} !Int16 + { _a :: {-# UNPACK #-} !Int16 -- ^ a coeff. + , _b :: {-# UNPACK #-} !Int16 -- ^ b coeff. + , _c :: {-# UNPACK #-} !Int16 -- ^ c coeff. + , _d :: {-# UNPACK #-} !Int16 -- ^ d coeff. + , _e :: {-# UNPACK #-} !Int16 -- ^ e coeff. + , _f :: {-# UNPACK #-} !Int16 -- ^ f coeff. } deriving (Eq, Show) @@ -160,8 +168,10 @@ getInt16be = fromIntegral <$> getWord16be getF2Dot14 = fromIntegral <$> getWord16be - getInt8 = fromIntegral <$> getWord8 + getInt8 = fixByteSign . fromIntegral <$> getWord8 + fixByteSign value = if value >= 0x80 then value - 0x100 else value + aRG_1_AND_2_ARE_WORDS = 0 aRGS_ARE_XY_VALUES = 1 {-rOUND_XY_TO_GRID = 2-} @@ -217,7 +227,7 @@ setter v (ix, True) = setBit v ix get = do tester <- testBit <$> getWord8 - return $ GlyphFlag + return GlyphFlag { _flagOnCurve = tester 0 , _flagXshort = tester 1 , _flagYShort = tester 2 @@ -261,7 +271,7 @@ extractFlatOutline :: GlyphContour -> [VU.Vector (Int16, Int16)] -extractFlatOutline contour = map go $ zip flagGroup coords +extractFlatOutline contour = zipWith (curry go) flagGroup coords where allFlags = _glyphFlags contour coords = _glyphPoints contour diff --git a/src/Graphics/Text/TrueType/LanguageIds.hs b/src/Graphics/Text/TrueType/LanguageIds.hs --- a/src/Graphics/Text/TrueType/LanguageIds.hs +++ b/src/Graphics/Text/TrueType/LanguageIds.hs @@ -22,7 +22,7 @@ | PlatformWindows -- ^ 3 | PlatformCustom -- ^ 4 | PlatformId Word16 - deriving (Eq, Show) + deriving (Eq, Ord, Show) instance Binary PlatformId where put = putWord16be . platformToWord diff --git a/src/Graphics/Text/TrueType/Name.hs b/src/Graphics/Text/TrueType/Name.hs --- a/src/Graphics/Text/TrueType/Name.hs +++ b/src/Graphics/Text/TrueType/Name.hs @@ -10,6 +10,7 @@ import Data.Foldable( asum ) import Data.Function( on ) import Data.List( maximumBy ) +import Data.Maybe( fromMaybe ) import Data.Monoid( mempty ) import Data.Binary( Binary( .. ) ) import Data.Binary.Get( getWord16be, getByteString ) @@ -62,7 +63,7 @@ fontFamilyName :: NameTable -> T.Text fontFamilyName (NameTable { _ntRecords = records }) = - maybe T.empty id . asum $ transform <$> + fromMaybe T.empty . asum $ transform <$> [ (selectorUnicode, utf16Decoder) , (selectorMac, utf8Decoder) , (selectorWin0, utf16Decoder)