From 611a9b485d62d4f54f9e2a02d12c59c3928d2bc0 Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <alcinnz@lavabit.com>
Date: Thu, 10 Feb 2022 20:29:25 +1300
Subject: [PATCH] Expose highlevel API for italic & bold text.

---
 src/Typograffiti/Store.hs | 65 ++++++++++++++++++++++++++++++++++++++-
 src/Typograffiti/Utils.hs | 12 ++++++++
 2 files changed, 76 insertions(+), 1 deletion(-)

diff --git a/src/Typograffiti/Store.hs b/src/Typograffiti/Store.hs
index df8cd8e..8f425df 100644
--- a/src/Typograffiti/Store.hs
+++ b/src/Typograffiti/Store.hs
@@ -28,7 +28,15 @@ import           Linear
 import           Typograffiti.Atlas
 import           Typograffiti.Cache
 import           Typograffiti.Glyph
-import           Typograffiti.Utils     (FT_Face, FT_GlyphSlot, FreeTypeIO(..))
+
+-- 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
@@ -187,3 +195,58 @@ registerFont store key fce sz cb = do
     $ 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.
diff --git a/src/Typograffiti/Utils.hs b/src/Typograffiti/Utils.hs
index 6f2eb67..1c06739 100644
--- a/src/Typograffiti/Utils.hs
+++ b/src/Typograffiti/Utils.hs
@@ -4,6 +4,7 @@ module Typograffiti.Utils (
    module FT
  , FreeTypeT
  , FreeTypeIO
+ , runIOErr
  , getAdvance
  , getCharIndex
  , getLibrary
@@ -23,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)
@@ -32,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.
@@ -164,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
-- 
2.30.2