3 files changed, 174 insertions(+), 37 deletions(-)

M src/Typograffiti/Atlas.hs
M src/Typograffiti/Store.hs
M src/Typograffiti/Utils.hs

@@ 15,6 15,7 @@ module Typograffiti.Atlas where
 import           Control.Monad
 import           Control.Monad.Except                              (MonadError (..))
 import           Control.Monad.IO.Class
+import           Data.Maybe                                        (fromMaybe)
 import           Data.IntMap                                       (IntMap)
 import qualified Data.IntMap                                       as IM
 import           Data.Vector.Unboxed                               (Vector)


@@ 25,8 26,6 @@ import           Graphics.GL.Types
 import           FreeType.Core.Types                               as BM
 import           FreeType.Support.Bitmap                           as BM
 import           FreeType.Support.Bitmap.Internal                  as BM
---import           Graphics.Rendering.FreeType.Internal.Bitmap       as BM
---import           Graphics.Rendering.FreeType.Internal.GlyphMetrics as GM
 import           Linear
 
 import           Typograffiti.GL


@@ 85,10 84,11 @@ spacing = 1
 measure
   :: FT_Face
   -> Int
+  -> (FT_GlyphSlot -> FreeTypeIO ())
   -> (IntMap AtlasMeasure, AtlasMeasure)
   -> Char
   -> FreeTypeIO (IntMap AtlasMeasure, AtlasMeasure)
-measure fce maxw (prev, am@AM{..}) char
+measure fce maxw glyphCb (prev, am@AM{..}) char
   -- Skip chars that have already been measured
   | fromEnum char `IM.member` prev = return (prev, am)
   | otherwise = do


@@ 96,10 96,11 @@ measure fce maxw (prev, am@AM{..}) char
         V2 w h = amWH
     -- Load the char, replacing the glyph according to
     -- https://www.freetype.org/freetype2/docs/tutorial/step1.html
-    loadChar fce (fromIntegral $ fromEnum char) ft_LOAD_RENDER
+    loadChar fce (fromIntegral $ fromEnum char) ft_LOAD_DEFAULT
     -- Get the glyph slot
     fce' <- liftIO $ peek fce
     let slot = frGlyph fce'
+    glyphCb slot
     -- Get the bitmap
     slot' <- liftIO $ peek slot
     let bmp =  gsrBitmap slot'


@@ 179,45 180,64 @@ allocAtlas
 allocAtlas fontFilePath gs str = do
   e <- liftIO $ runFreeType $ do
     fce <- newFace fontFilePath
-    case gs of
-      GlyphSizeInPixels w h -> setPixelSizes fce w h
-      GlyphSizeByChar (CharSize w h dpix dpiy) -> setCharSize fce w h dpix dpiy
-
-    (amMap, am) <- foldM (measure fce 512) (mempty, emptyAM) str
-
-    let V2 w h = amWH am
-        xymap :: IntMap (V2 Int)
-        xymap  = amXY <$> amMap
-
-    t <- liftIO $ do
-      t <- allocAndActivateTex GL_TEXTURE0
-      glPixelStorei GL_UNPACK_ALIGNMENT 1
-      withCString (replicate (w * h) $ toEnum 0) $
-        glTexImage2D GL_TEXTURE_2D 0 GL_RED (fromIntegral w) (fromIntegral h)
-                     0 GL_RED GL_UNSIGNED_BYTE . castPtr
-      return t
-
-    lib   <- getLibrary
-    atlas <- foldM (texturize xymap) (emptyAtlas lib fce t) str
-
-    glGenerateMipmap GL_TEXTURE_2D
-    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_REPEAT
-    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_REPEAT
-    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR
-    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR
-    glBindTexture GL_TEXTURE_2D 0
-    glPixelStorei GL_UNPACK_ALIGNMENT 4
-    return
-      atlas{ atlasTextureSize = V2 w h
-           , atlasGlyphSize = gs
-           , atlasFilePath = fontFilePath
-           }
+    allocRichAtlas fontFilePath fce (Just gs) renderGlyph str
 
   either
     (throwError . TypograffitiErrorFreetype "cannot alloc atlas")
     (return . fst)
     e
 
+-- | Allocate a new 'Atlas'.
+-- When creating a new 'Atlas' you must pass all the characters that you
+-- might need during the life of the 'Atlas'. Character texturization only
+-- happens once.
+allocRichAtlas
+  :: String
+  -- ^ Key identifying this altered font.
+  -> FT_Face
+  -- ^ Raw FreeType2-loaded font.
+  -> Maybe GlyphSize
+  -- ^ Size of glyphs in this Atlas, callers may configure this externally.
+  -> (FT_GlyphSlot -> FreeTypeIO ())
+  -- ^ Callback for mutating each glyph loaded from the given font.
+  -> String
+  -- ^ The characters to include in this 'Atlas'.
+  -> FreeTypeIO Atlas
+allocRichAtlas key fce gs cb str = do
+  case gs of
+    Just (GlyphSizeInPixels w h) -> setPixelSizes fce w h
+    Just (GlyphSizeByChar (CharSize w h dpix dpiy)) -> setCharSize fce w h dpix dpiy
+    Nothing -> return ()
+
+  (amMap, am) <- foldM (measure fce 512 cb) (mempty, emptyAM) str
+
+  let V2 w h = amWH am
+      xymap :: IntMap (V2 Int)
+      xymap  = amXY <$> amMap
+
+  t <- liftIO $ do
+    t <- allocAndActivateTex GL_TEXTURE0
+    glPixelStorei GL_UNPACK_ALIGNMENT 1
+    withCString (replicate (w * h) $ toEnum 0) $
+      glTexImage2D GL_TEXTURE_2D 0 GL_RED (fromIntegral w) (fromIntegral h)
+                   0 GL_RED GL_UNSIGNED_BYTE . castPtr
+    return t
+
+  lib   <- getLibrary
+  atlas <- foldM (texturize xymap) (emptyAtlas lib fce t) str
+
+  glGenerateMipmap GL_TEXTURE_2D
+  glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_REPEAT
+  glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_REPEAT
+  glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR
+  glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR
+  glBindTexture GL_TEXTURE_2D 0
+  glPixelStorei GL_UNPACK_ALIGNMENT 4
+  return
+    atlas{ atlasTextureSize = V2 w h
+         , atlasGlyphSize = fromMaybe (GlyphSizeInPixels 0 0) gs
+         , atlasFilePath = key
+         }
 
 -- | Releases all resources associated with the given 'Atlas'.
 freeAtlas :: MonadIO m => Atlas -> m ()

@@ 29,6 29,15 @@ import           Typograffiti.Atlas
 import           Typograffiti.Cache
 import           Typograffiti.Glyph
 
+-- For font registration APIs
+import           Typograffiti.Utils
+import           FreeType.Support.Bitmap.Internal
+import           FreeType.Support.Outline.Internal
+import           FreeType.Support.Outline
+import           FreeType.Core.Types
+import           Data.Maybe             (fromMaybe)
+import           System.IO
+
 
 -- | A pre-rendered bit of text, ready to display given
 -- some post compilition transformations. Also contains


@@ 71,6 80,8 @@ getTextRendering
   -> FilePath
   -- ^ The path to the font to use
   -- for rendering.
+  -- Or alternatively: the `key`
+  -- identifying a registered font.
   -> GlyphSize
   -- ^ The size of the font glyphs.
   -> String


@@ 149,3 160,93 @@ allocFont store file sz = do
     $ putTMVar mvar
     $ s{ textRenderingDataFontMap = M.insert (file, sz) font fontmap }
   return font
+
+registerFont
+  :: Layout t
+  => FontStore t
+  -> String
+  -> FT_Face
+  -> Maybe GlyphSize
+  -> (FT_GlyphSlot -> FreeTypeIO ())
+  -> FreeTypeIO (Font t)
+-- | Register an externally-loaded font under a given key (low-level API)
+-- Allows registering a callback for mutating glyphs prior
+-- to being composited into place on the GPU, which is
+-- responsible for ensuring Typograffiti has a bitmap to composite.
+registerFont store key fce sz cb = do
+  let mvar = unFontStore store
+  s     <- liftIO $ atomically $ takeTMVar mvar
+  atlas <-
+    allocRichAtlas
+      key
+      fce
+      sz
+      cb
+      $ S.toList
+      $ textRenderingDataCharSet s
+  let fontmap = textRenderingDataFontMap s
+      font = Font
+        { fontAtlas     = atlas
+        , fontWordCache = mempty
+        }
+  let sz' = atlasGlyphSize atlas
+  liftIO
+    $ atomically
+    $ putTMVar mvar
+    $ s{ textRenderingDataFontMap = M.insert (key, sz') font fontmap }
+  return font
+
+registerStyledFont
+  :: ( MonadIO m
+     , MonadError TypograffitiError m
+     , Layout t
+     )
+  => FontStore t
+  -> String
+  -- ^ Key by which to identify this styled font
+  -> FilePath
+  -- ^ Path to the raw fontfile
+  -> FT_Pos
+  -- ^ How much to embolden the font
+  -- Negative values lighten the font.
+  -> Maybe FT_Pos
+  -- ^ How much to embolden the font vertically, if different from horizontally.
+  -> FT_Fixed
+  -- ^ How much to slant the font, approximating italics.
+  -> GlyphSize
+  -- ^ The desired fontsize
+  -> m (Font t)
+-- | Registers font under the given key modified to approximate the desired boldness & obliqueness.
+-- Adds negligable CPU latency,
+-- but best results always come from giving the font designing full artistic control.
+-- Obliqueness isn't currently supported on bitmap fonts.
+registerStyledFont store key file weight vweight slant sz = do
+    e <- liftIO $ runFreeType $ do
+      lib <- getLibrary
+      fce <- newFace file
+      registerFont store key fce (Just sz) $ modifyGlyph lib
+
+    either
+      (throwError . TypograffitiErrorFreetype "cannot alloc atlas")
+      (return . fst)
+      e
+  where
+    modifyGlyph lib glyf = do
+      glyf' <- liftIO $ peek glyf
+      case gsrFormat glyf' of
+        FT_GLYPH_FORMAT_OUTLINE -> modifyOutline glyf
+        FT_GLYPH_FORMAT_BITMAP -> modifyBitmap lib glyf
+        x -> liftIO $ do
+          hPrint stderr "Unsupported glyph format:"
+          hPrint stderr x
+    modifyOutline glyf = do
+      let outline = gsrOutline' glyf
+      runIOErr "ft_Outline_EmboldenXY" $
+          ft_Outline_EmboldenXY' outline weight $ fromMaybe weight vweight
+      liftIO $ ft_Outline_Transform outline $ FT_Matrix 1 slant 0 1
+      renderGlyph glyf
+    modifyBitmap lib glyf = do
+      let bitmap = gsrBitmap' glyf
+      runIOErr "ft_Bitmap_Embolden" $
+          ft_Bitmap_Embolden' lib bitmap weight $ fromMaybe weight vweight
+      -- FreeType doesn't have a transform method on bitmaps.

@@ 4,6 4,7 @@ module Typograffiti.Utils (
    module FT
  , FreeTypeT
  , FreeTypeIO
+ , runIOErr
  , getAdvance
  , getCharIndex
  , getLibrary


@@ 12,6 13,7 @@ module Typograffiti.Utils (
 -- , hasKerning
  , loadChar
  , loadGlyph
+ , renderGlyph
  , newFace
  , setCharSize
  , setPixelSizes


@@ 22,6 24,8 @@ module Typograffiti.Utils (
  , ft_LOAD_FORCE_AUTOHINT, ft_LOAD_CROP_BITMAP, ft_LOAD_PEDANTIC, ft_LOAD_IGNORE_GLOBAL_ADVANCE_WIDTH
  , ft_LOAD_NO_RECURSE, ft_LOAD_IGNORE_TRANSFORM, ft_LOAD_MONOCHROME, ft_LOAD_LINEAR_DESIGN
  , ft_LOAD_NO_AUTOHINT, ft_LOAD_COLOR, ft_LOAD_COMPUTE_METRICS, ft_LOAD_BITMAP_METRICS_ONLY
+ , gsrOutline'
+ , gsrBitmap'
 ) where
 
 import           Control.Monad.IO.Class (MonadIO, liftIO)


@@ 31,9 35,11 @@ import           Control.Monad (unless)
 import           FreeType.Core.Base                                     as FT
 import           FreeType.Core.Base.Internal                            as FT
 import           FreeType.Core.Types                                    as FT
+import           FreeType.Support.Outline                               as FT
 import           Foreign                                                as FT
 import           Foreign.C.String                                       as FT
 import           Unsafe.Coerce
+import           Foreign.Ptr                                            (Ptr(..), plusPtr)
 
 -- TODO: Tease out the correct way to handle errors.
 -- They're kinda thrown all willy nilly.


@@ 112,6 118,9 @@ loadGlyph ff fg flags = runIOErr "ft_Load_Glyph" $ ft_Load_Glyph' ff fg flags
 loadChar :: MonadIO m => FT_Face -> FT_ULong -> FT_Int32 -> FreeTypeT m ()
 loadChar ff char flags = runIOErr "ft_Load_Char" $ ft_Load_Char' ff char flags
 
+renderGlyph :: MonadIO m => FT_GlyphSlot -> FreeTypeT m ()
+renderGlyph glyph = runIOErr "ft_Render_Glyph" $ ft_Render_Glyph' glyph 0
+
 --hasKerning :: MonadIO m => FT_Face -> FreeTypeT m Bool
 --hasKerning = liftIO . ft_HAS_KERNING
 --ft_HAS_KERNING FT_HAS_KERNING = return True


@@ 160,3 169,10 @@ getAdvance slot = do
   slot' <- liftIO $ peek slot
   let FT_Vector vx vy = gsrAdvance slot'
   return (fromIntegral vx, fromIntegral vy)
+
+-- Offsets taken from: https://hackage.haskell.org/package/freetype2-0.2.0/docs/src/FreeType.Circular.Types.html#line-372
+gsrOutline' :: FT_GlyphSlot -> Ptr FT_Outline
+gsrOutline' slot = plusPtr slot 200
+
+gsrBitmap' :: FT_GlyphSlot -> Ptr FT_Bitmap
+gsrBitmap' slot = plusPtr slot 152