stb-truetype 0.1 → 0.1.1

raw patch · 2 files changed

+181/−43 lines, 2 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Graphics/Rendering/TrueType/STB.hs +180/−42
• stb-truetype.cabal +1/−1

@@ -2,10 +2,14 @@ -- TODO:  --   * rewrite the file loading so that it we do not depend on ByteString --   * automatic glyph indexing, texture creation+--+-- BUG in stb_truetype? +--   * compound contours not implemented yet... +--  -- -- Module      : Graphics.Rendering.TrueType.STB--- Version     : 0.1+-- Version     : 0.1.1 -- License     : Public Domain -- Author      : Balazs Komuves -- Maintainer  : bkomuves (plus) hackage (at) gmail (dot) com@@ -17,21 +21,23 @@ -- | This is a wrapper around Sean Barrett's TrueType font rasterizer code. -- The original can be found at <http://nothings.org/stb/stb_truetype.h>. -- The version of @stb-truetype@ used here is @0.2@.+--+-- Note: it seems that compound glyphs are not implemented yet!  {-# LANGUAGE CPP, ForeignFunctionInterface #-} {-# CFILES cbits/wrapper.c #-}  -- for Hugs (?) module Graphics.Rendering.TrueType.STB    ( TrueType   , Offset-  , FontInfo+  , Font   , Glyph-  --+  -- * Initialization   , loadTTF   , withTTF   , enumerateFonts   , initFont-  , findGlyphIndex-  --+  , findGlyph+  -- * Font metrics   , Unscaled   , HorizontalMetrics(..)   , VerticalMetrics(..)@@ -43,11 +49,12 @@   , getGlyphHorizontalMetrics   , getGlyphKernAdvance   , getGlyphBoundingBox-  --+  -- * Bitmaps   , Scaling   , Bitmap(..)   , newBitmap   , withBitmap+  , flipBitmap   , BitmapOfs   , getGlyphBitmapBox   , newGlyphBitmap@@ -55,7 +62,13 @@   , renderGlyphIntoBitmap   , bitmapArray   , bitmapFloatArray-  --+  -- * Cached glyph storage+  , CachedBitmap(..)+  , BitmapCache+  , bmcVerticalMetrics+  , bmcScaling+  , newBitmapCache+  , getCachedBitmap      ) where @@ -63,6 +76,7 @@  import Control.Monad import Control.Applicative+import Control.Concurrent.MVar  import Data.Char import Data.Maybe@@ -74,7 +88,12 @@ import qualified Data.Array.Base as Arr  #endif -import Foreign+--import Data.Map (Map)+--import qualified Data.Map as Map+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap++import Foreign hiding (newArray) import Foreign.C  import Data.ByteString (ByteString)@@ -87,10 +106,10 @@ newtype TrueType = TrueType ByteString  -- | A font offset inside a TrueType font file.-newtype Offset = Offset Int deriving Show+newtype Offset = Offset Int deriving (Eq,Ord,Show)  -- | A glyph inside a font.-newtype Glyph = Glyph Int deriving Show+newtype Glyph = Glyph Int deriving (Eq,Ord,Show)  ccodepoint :: Char -> CCodepoint ccodepoint = fromIntegral . ord@@ -105,15 +124,57 @@ withByteString bs action = withForeignPtr fptr h where   (fptr,ofs,len) = BI.toForeignPtr bs   h p = action (plusPtr p ofs) -  -newtype FontInfo = FontInfo (ForeignPtr CFontInfo) -withFontInfo :: FontInfo -> (Ptr CFontInfo -> IO a) -> IO a-withFontInfo (FontInfo fptr) = withForeignPtr fptr+-- we need to refer to the the original font data here, +-- otherwise it could be garbage collected !!!  +data Font = Font +  { _fontData :: TrueType +  , _fontInfo :: ForeignPtr CFontInfo+  , _glyphMap :: UnicodeCache (Maybe Glyph) +  }  +withFontInfo :: Font -> (Ptr CFontInfo -> IO a) -> IO a+withFontInfo (Font _ fptr _) = withForeignPtr fptr+ -------------------------------------------------------------------------------- --- | Enumerates the fonts found in a TrueType file.+-- Organized into small continous blocks (say 128 characters)+-- so lookup should pretty very fast+type UnicodeCache a = MVar (IntMap (IOArray Char (Maybe a)))++unicodeCacheGranularity = 128 :: Int++newUnicodeCache :: IO (UnicodeCache a)+newUnicodeCache = newMVar (IntMap.empty)++lookupUnicodeCache :: Char -> (Char -> IO a) -> UnicodeCache a -> IO a+lookupUnicodeCache char calculate cache = do+  themap <- takeMVar cache  +  let k = ord char `div` unicodeCacheGranularity+  case IntMap.lookup k themap of+    Just arr -> do+      putMVar cache themap+      mvalue <- readArray arr char+      case mvalue of+        Just value -> do+          return value+        Nothing -> do+          new <- calculate char+          writeArray arr char (Just new)+          return new         +    Nothing -> do+      let u = k*unicodeCacheGranularity+      let v = u + unicodeCacheGranularity - 1+      arr <- newArray (chr u, chr v) Nothing+      new <- calculate char+      writeArray arr char (Just new)+      putMVar cache (IntMap.insert k arr themap)+      return new+      +--------------------------------------------------------------------------------++-- | Enumerates the fonts found in a TrueType file. Often there is only one,+-- but there may be more. enumerateFonts :: TrueType -> IO [Offset]  enumerateFonts ttf = withTrueType ttf $ \ptr -> worker ptr 0 where   worker ptr i = do@@ -124,11 +185,12 @@         os <- worker ptr (i+1)          return (Offset o : os)     -initFont :: TrueType -> Offset -> IO FontInfo+initFont :: TrueType -> Offset -> IO Font initFont ttf (Offset ofs) = withTrueType ttf $ \ptr -> do   fq <- mallocForeignPtr :: IO (ForeignPtr CFontInfo)   withForeignPtr fq $ \q -> stbtt_InitFont q ptr (fromIntegral ofs)-  return (FontInfo fq)    +  mglyphmap <- newUnicodeCache -- newMVar Map.empty+  return (Font ttf fq mglyphmap)          -------------------------------------------------------------------------------- @@ -144,55 +206,118 @@    -------------------------------------------------------------------------------- -findGlyphIndex :: FontInfo -> Char -> IO (Maybe Glyph)-findGlyphIndex fontinfo char = +-- | Note: this is cached.+findGlyph :: Font -> Char -> IO (Maybe Glyph)+findGlyph fontinfo@(Font _ _ glyphmap) char =+  lookupUnicodeCache char (findGlyphNotCached fontinfo) glyphmap ++-- this is not cached+findGlyphNotCached :: Font -> Char -> IO (Maybe Glyph)+findGlyphNotCached fontinfo char =   withFontInfo fontinfo $ \ptr -> do     let codepoint = ord char     i <- stbtt_FindGlyphIndex ptr (fromIntegral codepoint)-    return $ if i == 0 -      then Nothing-      else Just $ Glyph (fromIntegral i)+    if i == 0 +      then return Nothing+      else do+        let glyph = Glyph (fromIntegral i)+        return (Just glyph)  --------------------------------------------------------------------------------++-- | Note: the metrics are scaled!+data CachedBitmap = CBM Bitmap BitmapOfs (HorizontalMetrics Float)++-- | A \"bitmap cache\".+data BitmapCache = BMCache+  { bmc_fontinfo :: Font+  , bmc_scaling  :: (Float,Float)+  , bmc_cache    :: UnicodeCache (Maybe CachedBitmap)+  , bmc_vmetrics :: VerticalMetrics Float+  , bmc_flipped  :: Bool+  }++-- | Note: these metrics are scaled!+bmcVerticalMetrics :: BitmapCache -> VerticalMetrics Float+bmcVerticalMetrics = bmc_vmetrics++bmcScaling :: BitmapCache -> Scaling+bmcScaling = bmc_scaling++-- | Creates a new cache where glyph bitmaps with the given scaling+-- will be stored. The second argument is whether the resulting bitmaps+-- should be flipped vertically or not (this is useful with OpenGL).+newBitmapCache :: Font -> Bool -> (Float,Float) -> IO BitmapCache +newBitmapCache fontinfo flipped scaling@(xscale,yscale) = do +  cache <- newUnicodeCache+  vmetu <- getFontVerticalMetrics fontinfo+  let vmets = fmap (\y -> yscale * fromIntegral y) vmetu  +  return $ BMCache fontinfo scaling cache vmets flipped   +-- | Fetches a rendered glyph bitmap from the cache (rendering it first if+-- it was not present in the cache before).+getCachedBitmap :: BitmapCache -> Char -> IO (Maybe CachedBitmap)+getCachedBitmap (BMCache font scaling@(xscale,yscale) cache vmet flipped) char = +  lookupUnicodeCache char createBitmap cache+  where+    createBitmap char = do+      mglyph <- findGlyph font char+      case mglyph of+        Just glyph -> do+          (bm',ofs) <- newGlyphBitmap font glyph scaling+          bm <- if flipped then flipBitmap bm' else return bm'+          hmetu <- getGlyphHorizontalMetrics font glyph+          let hmets = fmap (\x -> xscale * fromIntegral x) hmetu +          return $ Just (CBM bm ofs hmets)+        Nothing -> do+          return Nothing+        +--------------------------------------------------------------------------------+   type Unscaled = Int          -- | 'ascent' is the coordinate above the baseline the font extends; 'descent' -- is the coordinate below the baseline the font extends (i.e. it is typically negative) -- 'lineGap' is the spacing between one row's descent and the next row's ascent... -- so you should advance the vertical position by @ascent - descent + lineGap@      -data VerticalMetrics = VMetrics-  { ascent  :: Unscaled      -  , descent :: Unscaled-  , lineGap :: Unscaled+data VerticalMetrics a = VMetrics+  { ascent  :: a   +  , descent :: a+  , lineGap :: a   }   deriving Show   +instance Functor VerticalMetrics where+  fmap f (VMetrics a d l) = VMetrics (f a) (f d) (f l)  +   -- | As calculated by @(ascent - descent + lineGap)@.-lineAdvance :: VerticalMetrics -> Unscaled+lineAdvance :: Num a => VerticalMetrics a -> a lineAdvance vm = ascent vm - descent vm + lineGap vm    -- | As calculated by @(ascent - descent)@.-verticalSize :: VerticalMetrics -> Unscaled+verticalSize :: Num a => VerticalMetrics a -> a  verticalSize vm = ascent vm - descent vm -scaleForPixelHeight :: VerticalMetrics -> Float -> Float +scaleForPixelHeight :: VerticalMetrics Unscaled -> Float -> Float  scaleForPixelHeight vm pixels = pixels / fromIntegral (verticalSize vm)  -- 'leftSideBearing' is the offset from the current horizontal position to the left edge of the character; -- 'advanceWidth' is the offset from the current horizontal position to the next horizontal position.-data HorizontalMetrics = HMetrics-  { advanceWidth     :: Unscaled      -  , leftSideBearing :: Unscaled+data HorizontalMetrics a = HMetrics+  { advanceWidth    :: a      +  , leftSideBearing :: a   }   deriving Show++instance Functor HorizontalMetrics where+  fmap f (HMetrics a l) = HMetrics (f a) (f l)      -- | The convention is @BBox (x0,y0) (x1,y1)@. data BoundingBox a = BBox (a,a) (a,a) deriving Show  --------------------------------------------------------------------------------      -getFontVerticalMetrics :: FontInfo -> IO VerticalMetrics+getFontVerticalMetrics :: Font -> IO (VerticalMetrics Unscaled) getFontVerticalMetrics fontinfo =    withFontInfo fontinfo $ \ptr -> do     alloca $ \pasc -> alloca $ \pdesc -> alloca $ \pgap -> do@@ -208,7 +333,7 @@  -------------------------------------------------------------------------------- -getGlyphHorizontalMetrics :: FontInfo -> Glyph -> IO HorizontalMetrics+getGlyphHorizontalMetrics :: Font -> Glyph -> IO (HorizontalMetrics Unscaled) getGlyphHorizontalMetrics fontinfo glyph =    withFontInfo fontinfo $ \ptr -> do     alloca $ \padv -> alloca $ \plsb  -> do@@ -221,13 +346,13 @@         }          -- | This is not yet implemented in @stb_truetype@; it always returns 0.-getGlyphKernAdvance :: FontInfo -> Glyph -> Glyph -> IO Unscaled+getGlyphKernAdvance :: Font -> Glyph -> Glyph -> IO Unscaled getGlyphKernAdvance fontinfo glyph1 glyph2 =    withFontInfo fontinfo $ \ptr -> do     kern <- stbtt_GetGlyphKernAdvance ptr (cglyphindex glyph1) (cglyphindex glyph1)     return (fromIntegral kern)     -getGlyphBoundingBox :: FontInfo -> Glyph -> IO (BoundingBox Unscaled)+getGlyphBoundingBox :: Font -> Glyph -> IO (BoundingBox Unscaled) getGlyphBoundingBox fontinfo glyph =   withFontInfo fontinfo $ \ptr -> do     alloca $ \px0 -> alloca $ \py0 -> alloca $ \px1 -> alloca $ \py1 -> do@@ -265,6 +390,18 @@   let (xsiz,ysiz) = bitmapSize bm   withForeignPtr (bitmapPtr bm) $ \ptr -> action xsiz ysiz ptr   +-- | Flips the bitmap vertically (leaving the original unchanged)+flipBitmap :: Bitmap -> IO Bitmap+flipBitmap (Bitmap siz@(xsiz,ysiz) fptr1) = withForeignPtr fptr1 $ \ptr1 -> do+  let n = xsiz*ysiz+  fptr2 <- mallocForeignPtrBytes n+  withForeignPtr fptr2 $ \ptr2 -> do+    forM_ [0..ysiz-1] $ \y1 -> do+      let y2 = ysiz-1-y1+      copyBytes (ptr2 `plusPtr` (y2*xsiz)) (ptr1 `plusPtr` (y1*xsiz)) xsiz+  return (Bitmap siz fptr2)++ -- | NOTE: because of the way Haskell indexes rectangular arrays, -- the resulting array is indexed with @(y,x)@, as opposed to what -- you would expect.@@ -309,7 +446,7 @@ -- Note that the bitmap uses /y-increases-down/, but the shape uses -- /y-increases-up/, so the results of 'getGlyphBitmapBox' and  -- 'getGlyphBoundingBox' are inverted.-getGlyphBitmapBox :: FontInfo -> Glyph -> Scaling -> IO (BoundingBox Int)+getGlyphBitmapBox :: Font -> Glyph -> Scaling -> IO (BoundingBox Int) getGlyphBitmapBox fontinfo glyph (xscale,yscale) =   withFontInfo fontinfo $ \ptr -> do     alloca $ \px0 -> alloca $ \py0 -> alloca $ \px1 -> alloca $ \py1 -> do@@ -323,9 +460,10 @@         (fromIntegral x1, fromIntegral y1)  -- | Creates a new bitmap just enough to fit the glyph with the given scaling,--- and renders the glyph into it. The offset returned is the offset of the glyph origin--- within the bitmap.-newGlyphBitmap :: FontInfo -> Glyph -> Scaling -> IO (Bitmap,BitmapOfs)+-- and renders the glyph into it. The offset returned is the offset +-- in pixel space /from/ the glyph origin /to/ the top-left of the bitmap+-- (so it's almost always negative).+newGlyphBitmap :: Font -> Glyph -> Scaling -> IO (Bitmap,BitmapOfs) newGlyphBitmap fontinfo glyph (xscale,yscale) = do   withFontInfo fontinfo $ \ptr -> do     alloca $ \pxsiz -> alloca $ \pysiz -> alloca $ \pxofs -> alloca $ \pyofs -> do@@ -344,7 +482,7 @@  -- | The offset is the /top-left corner/ of the bounding box of the glyph, -- and must be nonnegative (otherwise nothing will happen).-renderGlyphIntoBitmap' :: FontInfo -> Glyph -> Scaling -> Bitmap -> BitmapOfs -> IO ()+renderGlyphIntoBitmap' :: Font -> Glyph -> Scaling -> Bitmap -> BitmapOfs -> IO () renderGlyphIntoBitmap' fontinfo glyph (xscale,yscale) bm (xofs,yofs) = do   let (xsiz,ysiz) = bitmapSize bm    when ( xofs < xsiz && yofs < ysiz && xofs >= 0 && yofs >= 0 ) $ do@@ -360,7 +498,7 @@ -- | The offset is the /origin/ of the glyph. If the glyph extends from the -- bitmap in the positive direction, it is clipped; however, if it extends -- in the negative direction, no drawing will happen!-renderGlyphIntoBitmap ::  FontInfo -> Glyph -> Scaling -> Bitmap -> BitmapOfs -> IO ()+renderGlyphIntoBitmap ::  Font -> Glyph -> Scaling -> Bitmap -> BitmapOfs -> IO () renderGlyphIntoBitmap fontinfo glyph scaling@(xscale,yscale) bm ofs@(xofs,yofs) = do   BBox (x0,y0) _ <- getGlyphBitmapBox fontinfo glyph scaling   renderGlyphIntoBitmap' fontinfo glyph scaling bm (xofs+x0,yofs+y0) 

@@ -1,5 +1,5 @@ Name:                stb-truetype-Version:             0.1+Version:             0.1.1 Synopsis:            A wrapper around Sean Barrett's TrueType rasterizer library. Description:         A wrapper around Sean Barrett's TrueType rasterizer library. License:             PublicDomain