{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
module Typograffiti.Atlas where
import Control.Exception (try)
import Control.Monad
import Control.Monad.Except (MonadError (..))
import Control.Monad.Fail (MonadFail (..))
import Control.Monad.IO.Class
import Data.IntMap (IntMap)
import qualified Data.IntMap as IM
import Data.Vector.Unboxed (Vector)
import qualified Data.Vector.Unboxed as UV
import Foreign.Marshal.Utils (with)
import Graphics.GL.Core32
import Graphics.GL.Types (GLuint)
import FreeType.Core.Base
import FreeType.Core.Types as BM
import FreeType.Exception (FtError (..))
import Linear (V2 (..))
import Data.Int (Int32)
import Data.Word (Word32)
import Data.Text.Glyphize (GlyphInfo (..), GlyphPos (..))
import Foreign.Storable (peek)
import Foreign.Ptr (castPtr)
import Foreign.C.String (withCString)
import Typograffiti.GL
data TypograffitiError =
TypograffitiErrorNoMetricsForGlyph Int
| TypograffitiErrorFreetype String Int32
| TypograffitiErrorGL String
deriving (Show, Eq)
data GlyphMetrics = GlyphMetrics {
glyphTexBB :: (V2 Int, V2 Int),
glyphSize :: V2 Int
} deriving (Show, Eq)
data Atlas = Atlas {
atlasTexture :: GLuint,
atlasTextureSize :: V2 Int,
atlasMetrics :: IntMap GlyphMetrics
} deriving (Show)
emptyAtlas :: GLuint -> Atlas
emptyAtlas t = Atlas t 0 mempty
data AtlasMeasure = AM {
amWH :: V2 Int,
amXY :: V2 Int,
rowHeight :: Int,
amMap :: IntMap (V2 Int)
} deriving (Show, Eq)
emptyAM :: AtlasMeasure
emptyAM = AM 0 (V2 1 1) 0 mempty
spacing :: Int
spacing = 1
type GlyphRetriever m = Word32 -> m (FT_Bitmap, FT_Glyph_Metrics)
glyphRetriever :: (MonadIO m, MonadError TypograffitiError m) => FT_Face -> GlyphRetriever m
glyphRetriever font glyph = do
liftFreetype $ ft_Load_Glyph font (fromIntegral $ fromEnum glyph) FT_LOAD_RENDER
font' <- liftIO $ peek font
slot <- liftIO $ peek $ frGlyph font'
return (gsrBitmap slot, gsrMetrics slot)
measure :: (MonadIO m, MonadError TypograffitiError m) =>
GlyphRetriever m -> Int -> AtlasMeasure -> Word32 -> m AtlasMeasure
measure cb maxw am@AM{..} glyph
| Just _ <- IM.lookup (fromEnum glyph) amMap = return am
| otherwise = do
let V2 x y = amXY
V2 w h = amWH
(bmp, _) <- cb glyph
let bw = fromIntegral $ bWidth bmp
bh = fromIntegral $ bRows bmp
gotoNextRow = (x + bw + spacing >= maxw)
rh = if gotoNextRow then 0 else max bh rowHeight
nx = if gotoNextRow then 0 else x + bw + spacing
nw = max w (x + bw + spacing)
nh = max h (y + rh + spacing)
ny = if gotoNextRow then nh else y
am = AM {
amWH = V2 nw nh,
amXY = V2 nx ny,
rowHeight = rh,
amMap = IM.insert (fromEnum glyph) amXY amMap
}
return am
texturize :: (MonadIO m, MonadError TypograffitiError m) =>
GlyphRetriever m -> IntMap (V2 Int) -> Atlas -> Word32 -> m Atlas
texturize cb xymap atlas@Atlas{..} glyph
| Just pos@(V2 x y) <- IM.lookup (fromIntegral $ fromEnum glyph) xymap = do
(bmp, metrics) <- cb glyph
glTexSubImage2D GL_TEXTURE_2D 0
(fromIntegral x) (fromIntegral y)
(fromIntegral $ bWidth bmp) (fromIntegral $ bRows bmp)
GL_RED GL_UNSIGNED_BYTE
(castPtr $ bBuffer bmp)
let vecwh = fromIntegral <$> V2 (bWidth bmp) (bRows bmp)
canon = floor . (* 0.5) . (* 0.015625) . realToFrac . fromIntegral
vecsz = canon <$> V2 (gmWidth metrics) (gmHeight metrics)
vecxb = canon <$> V2 (gmHoriBearingX metrics) (gmHoriBearingY metrics)
vecyb = canon <$> V2 (gmVertBearingX metrics) (gmVertBearingY metrics)
vecad = canon <$> V2 (gmHoriAdvance metrics) (gmVertAdvance metrics)
mtrcs = GlyphMetrics {
glyphTexBB = (pos, pos + vecwh),
glyphSize = vecsz
}
return atlas { atlasMetrics = IM.insert (fromEnum glyph) mtrcs atlasMetrics }
| otherwise = do
liftIO $ putStrLn ("Cound not find glyph " ++ show glyph)
return atlas
allocAtlas :: (MonadIO m, MonadFail m, MonadError TypograffitiError m) =>
GlyphRetriever m -> [Word32] -> m Atlas
allocAtlas cb glyphs = do
AM {..} <- foldM (measure cb 512) emptyAM glyphs
let V2 w h = amWH
xymap = amMap
t <- allocAndActivateTex 0
glPixelStorei GL_UNPACK_ALIGNMENT 1
liftIO $ withCString (replicate (w * h) $ toEnum 0) $
glTexImage2D GL_TEXTURE_2D 0 GL_RED (fromIntegral w) (fromIntegral h)
0 GL_RED GL_UNSIGNED_BYTE . castPtr
atlas <- foldM (texturize cb xymap) (emptyAtlas t) glyphs
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 }
freeAtlas :: MonadIO m => Atlas -> m ()
freeAtlas a = liftIO $ with (atlasTexture a) $ \ptr -> glDeleteTextures 1 ptr
type Quads = (Float, Float, [Vector (V2 Float, V2 Float)])
makeCharQuad :: (MonadIO m, MonadError TypograffitiError m) =>
Atlas -> Quads -> (GlyphInfo, GlyphPos) -> m Quads
makeCharQuad Atlas {..} (penx, peny, mLast) (GlyphInfo {codepoint=glyph}, GlyphPos {..}) = do
let iglyph = fromEnum glyph
case IM.lookup iglyph atlasMetrics of
Nothing -> throwError $ TypograffitiErrorNoMetricsForGlyph iglyph
Just GlyphMetrics {..} -> do
let x = penx + f x_offset
y = peny + f y_offset
V2 w h = f' <$> glyphSize
V2 aszW aszH = f' <$> atlasTextureSize
V2 texL texT = f' <$> fst glyphTexBB
V2 texR texB = f' <$> snd glyphTexBB
tl = (V2 (x) (y-h), V2 (texL/aszW) (texT/aszH))
tr = (V2 (x+w) (y-h), V2 (texR/aszW) (texT/aszH))
br = (V2 (x+w) y, V2 (texR/aszW) (texB/aszH))
bl = (V2 (x) y, V2 (texL/aszW) (texB/aszH))
return (penx + f x_advance/150, peny + f y_advance/150,
UV.fromList [tl, tr, br, tl, br, bl] : mLast)
where
f :: Int32 -> Float
f = fromIntegral
f' :: Int -> Float
f' = fromIntegral
stringTris :: (MonadIO m, MonadError TypograffitiError m) =>
Atlas -> [(GlyphInfo, GlyphPos)] -> m Quads
stringTris atlas = foldM (makeCharQuad atlas) (0, 0, [])
stringTris' :: (MonadIO m, MonadError TypograffitiError m) =>
Atlas -> [(GlyphInfo, GlyphPos)] -> m (Vector (V2 Float, V2 Float))
stringTris' atlas glyphs = do
(_, _, ret) <- stringTris atlas glyphs
return $ UV.concat $ reverse ret
liftFreetype :: (MonadIO m, MonadError TypograffitiError m) => IO a -> m a
liftFreetype cb = do
err <- liftIO $ try $ cb
case err of
Left (FtError func code) -> throwError $ TypograffitiErrorFreetype func code
Right ret -> return ret