FontyFruity 0.3 → 0.4

raw patch · 8 files changed

+227/−53 lines, 8 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• FontyFruity.cabal +2/−3
• changelog +5/−0
• src/Graphics/Text/TrueType.hs +112/−12
• src/Graphics/Text/TrueType/CharacterMap.hs +8/−8
• src/Graphics/Text/TrueType/FontFolders.hs +77/−18
• src/Graphics/Text/TrueType/Glyph.hs +20/−10
• src/Graphics/Text/TrueType/LanguageIds.hs +1/−1
• src/Graphics/Text/TrueType/Name.hs +2/−1

@@ -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

@@ -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

@@ -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
 

@@ -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) =

@@ -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

@@ -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

@@ -22,7 +22,7 @@     | PlatformWindows   -- ^ 3
     | PlatformCustom    -- ^ 4
     | PlatformId Word16
-    deriving (Eq, Show)
+    deriving (Eq, Ord, Show)
 
 instance Binary PlatformId where
     put = putWord16be . platformToWord

@@ -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)