module Graphics.Rendering.FreeType.Simple where
import Control.Applicative
import Control.Monad
import Data.BoundingBox
import Data.ByteString.Internal
import Foreign
import Foreign.C
import Graphics.Rendering.FreeType.Internal
import Graphics.Rendering.FreeType.Internal.BBox as B
import Graphics.Rendering.FreeType.Internal.Bitmap
import Graphics.Rendering.FreeType.Internal.BitmapGlyph as BG
import Graphics.Rendering.FreeType.Internal.Face
import Graphics.Rendering.FreeType.Internal.Glyph
import qualified Graphics.Rendering.FreeType.Internal.GlyphSlot as GS
import Graphics.Rendering.FreeType.Internal.Library
import Graphics.Rendering.FreeType.Internal.PrimitiveTypes
import qualified Graphics.Rendering.FreeType.Internal.Vector as V
import Linear
import System.IO.Unsafe (unsafePerformIO)
data Font = Font
{ fontFace :: FT_Face
, fontAscender :: Float
, fontDescender :: Float
, fontBBox :: Box V2 Float
}
runFT :: IO CInt -> IO ()
runFT m = do
r <- m
unless (r == 0) $ error $ "FreeType2: " ++ show r
ftlib :: FT_Library
ftlib = unsafePerformIO $ alloca $ \p -> do
runFT $ ft_Init_FreeType p
peek p
readFont :: FilePath -> IO Font
readFont path = alloca $ \p -> do
runFT $ withCString path $ \str -> ft_New_Face ftlib str 0 p
face <- peek p
b <- peek (bbox face)
asc <- fromIntegral <$> peek (ascender face)
desc <- fromIntegral <$> peek (descender face)
u <- fromIntegral <$> peek (units_per_EM face)
let box = pure ((/u).fromIntegral) <*> Box
(V2 (xMin b) (yMin b))
(V2 (xMax b) (yMax b))
return $ Font face (asc/u) (desc/u) box
textLine :: Font -> Float -> String -> IO (ForeignPtr Word8, V2 Int, Box V2 Int)
textLine Font{fontFace = face} size text = do
let dpi = 72
runFT $ ft_Set_Char_Size face 0 (floor $ size * 64) dpi dpi
slot <- peek $ glyph face
let text' = map fromEnum text
let measure :: Ptr V.FT_Vector -> Ptr FT_BBox -> (Int, Ptr FT_Glyph, Int, [Box V2 Int]) -> Int -> IO (Int, Ptr FT_Glyph, Int, [Box V2 Int])
measure delta glyphBBox (prev, glyphs, penX, xs) ch = do
glyphIx <- ft_Get_Char_Index face (fromIntegral ch)
ft_Get_Kerning face (fromIntegral prev) glyphIx (fromIntegral ft_KERNING_DEFAULT) delta
kx <- fromIntegral . V.x <$> peek delta
runFT $ ft_Load_Glyph face glyphIx ft_LOAD_DEFAULT
runFT $ ft_Get_Glyph slot glyphs
dx <- fromIntegral . V.x <$> peek (GS.advance slot)
glyph' <- peek glyphs
ft_Glyph_Get_CBox glyph' ft_GLYPH_BBOX_UNSCALED glyphBBox
bbox@FT_BBox{..} <- peek glyphBBox
let (left, y) = (penX + kx, 0)
let f = fromIntegral
let box = Box (V2 (left + f xMin) (y + f yMin)) (V2 (left + f xMax) (y + f yMax))
return (ch, advancePtr glyphs 1, penX+kx+dx, box:xs)
let render :: Ptr FT_Glyph -> Ptr Word8 -> Int -> Box V2 Int -> Box V2 Int -> Int -> IO ()
render glyphs dst bmpW (Box bmin bmax) (Box gmin gmax) i = do
let imgPtr = advancePtr glyphs i
runFT $ ft_Glyph_To_Bitmap imgPtr ft_RENDER_MODE_NORMAL nullPtr 1
img <- peek imgPtr
let im = BG.cast img
bmp <- peek $ bitmap im
let image = buffer bmp
let V2 (V2 xMin yMin) (V2 gxMin gyMin) = fmap (`shiftR` 6) <$> V2 bmin gmin
let V2 (V2 xMax yMax) (V2 gxMax gyMax) = fmap ((`shiftR` 6) . (+63)) <$> V2 bmax gmax
let V4 gl gt gw gh = V4 (xMin+gxMin) (yMaxgyMax) (gxMaxgxMin) (gyMaxgyMin)
forM_ [0..gh1] $ \y -> do
copyBytes (plusPtr dst $ (y + gt) * bmpW + gl) (plusPtr image (y * gw)) gw
ft_Done_Glyph img
alloca $ \ftVec -> do
alloca $ \glyphBBox -> do
allocaArray (length text) $ \glyphs -> do
(_, _, textW, heads) <- foldM (measure ftVec glyphBBox) (0, glyphs, 0, []) text'
let minimumBox = Box maxBound (V2 textW minBound)
let bitmapBox@(Box (V2 l b) (V2 r t)) = foldl union minimumBox heads
let bmpDim@(V2 w h) = (`shiftR` 6) <$> V2 (r l + 63) (t b + 63)
let alignedW = ((w + 3) `div` 4) * 4
fp <- mallocForeignPtrBytes (alignedW * h)
withForeignPtr fp $ \image -> do
memset image 0 (fromIntegral $ alignedW * h)
zipWithM (render glyphs image alignedW bitmapBox) (reverse heads) [0..]
return (fp, bmpDim, bitmapBox)
foreign import ccall unsafe "FT_Glyph_Get_CBox"
ft_Glyph_Get_CBox :: FT_Glyph -> FT_UInt -> Ptr B.FT_BBox -> IO ()
ft_GLYPH_BBOX_UNSCALED = 0