{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
module Typograffiti.Atlas where
import Control.Monad
import Control.Monad.Except (MonadError (..))
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
import Graphics.Rendering.FreeType.Internal.Bitmap as BM
import Graphics.Rendering.FreeType.Internal.GlyphMetrics as GM
import Linear
import Typograffiti.GL
import Typograffiti.Glyph
import Typograffiti.Utils
data TypograffitiError =
TypograffitiErrorNoGlyphMetricsForChar Char
| TypograffitiErrorFreetype String String
| TypograffitiErrorGL String
deriving (Show, Eq)
data Atlas = Atlas { atlasTexture :: GLuint
, atlasTextureSize :: V2 Int
, atlasLibrary :: FT_Library
, atlasFontFace :: FT_Face
, atlasMetrics :: IntMap GlyphMetrics
, atlasGlyphSize :: GlyphSize
, atlasFilePath :: FilePath
}
emptyAtlas :: FT_Library -> FT_Face -> GLuint -> Atlas
emptyAtlas lib fce t = Atlas t 0 lib fce mempty (GlyphSizeInPixels 0 0) ""
data AtlasMeasure = AM { amWH :: V2 Int
, amXY :: V2 Int
, rowHeight :: Int
} deriving (Show, Eq)
emptyAM :: AtlasMeasure
emptyAM = AM 0 (V2 1 1) 0
spacing :: Int
spacing = 1
measure
:: FT_Face
-> Int
-> (IntMap AtlasMeasure, AtlasMeasure)
-> Char
-> FreeTypeIO (IntMap AtlasMeasure, AtlasMeasure)
measure fce maxw (prev, am@AM{..}) char
| fromEnum char `IM.member` prev = return (prev, am)
| otherwise = do
let V2 x y = amXY
V2 w h = amWH
loadChar fce (fromIntegral $ fromEnum char) ft_LOAD_RENDER
slot <- liftIO $ peek $ glyph fce
bmp <- liftIO $ peek $ bitmap slot
let bw = fromIntegral $ BM.width bmp
bh = fromIntegral $ rows 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
am1 = AM { amWH = V2 nw nh
, amXY = V2 nx ny
, rowHeight = rh
}
return (IM.insert (fromEnum char) am prev, am1)
texturize :: IntMap (V2 Int) -> Atlas -> Char -> FreeTypeIO Atlas
texturize xymap atlas@Atlas{..} char
| Just pos@(V2 x y) <- IM.lookup (fromEnum char) xymap = do
loadChar atlasFontFace (fromIntegral $ fromEnum char) ft_LOAD_RENDER
slot <- liftIO $ peek $ glyph atlasFontFace
bmp <- liftIO $ peek $ bitmap slot
glTexSubImage2D
GL_TEXTURE_2D
0
(fromIntegral x)
(fromIntegral y)
(fromIntegral $ BM.width bmp)
(fromIntegral $ rows bmp)
GL_RED
GL_UNSIGNED_BYTE
(castPtr $ buffer bmp)
ftms <- liftIO $ peek $ metrics slot
let vecwh = fromIntegral <$> V2 (BM.width bmp) (rows bmp)
canon = floor @Double @Int . (* 0.015625) . fromIntegral
vecsz = canon <$> V2 (GM.width ftms) (GM.height ftms)
vecxb = canon <$> V2 (horiBearingX ftms) (horiBearingY ftms)
vecyb = canon <$> V2 (vertBearingX ftms) (vertBearingY ftms)
vecad = canon <$> V2 (horiAdvance ftms) (vertAdvance ftms)
mtrcs = GlyphMetrics { glyphTexBB = (pos, pos + vecwh)
, glyphTexSize = vecwh
, glyphSize = vecsz
, glyphHoriBearing = vecxb
, glyphVertBearing = vecyb
, glyphAdvance = vecad
}
return atlas{ atlasMetrics = IM.insert (fromEnum char) mtrcs atlasMetrics }
| otherwise = do
liftIO $ putStrLn "could not find xy"
return atlas
allocAtlas
:: ( MonadIO m
, MonadError TypograffitiError m
)
=> FilePath
-> GlyphSize
-> String
-> m Atlas
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
}
either
(throwError . TypograffitiErrorFreetype "cannot alloc atlas")
(return . fst)
e
freeAtlas :: MonadIO m => Atlas -> m ()
freeAtlas a = liftIO $ do
_ <- ft_Done_FreeType (atlasLibrary a)
with (atlasTexture a) $ \ptr -> glDeleteTextures 1 ptr
makeCharQuad
:: ( MonadIO m
, MonadError TypograffitiError m
)
=> Atlas
-> Bool
-> Int
-> Maybe FT_UInt
-> Char
-> m (Vector (V2 Float, V2 Float), Int, Maybe FT_UInt)
makeCharQuad Atlas{..} useKerning penx mLast char = do
let ichar = fromEnum char
eNdx <- withFreeType (Just atlasLibrary) $ getCharIndex atlasFontFace ichar
let mndx = either (const Nothing) Just eNdx
px <- case (,,) <$> mndx <*> mLast <*> Just useKerning of
Just (ndx,lndx,True) -> do
e <- withFreeType (Just atlasLibrary) $
getKerning atlasFontFace lndx ndx ft_KERNING_DEFAULT
return $ either (const penx) ((+penx) . floor . (* 0.015625) . fromIntegral . fst) e
_ -> return $ fromIntegral penx
case IM.lookup ichar atlasMetrics of
Nothing -> throwError $ TypograffitiErrorNoGlyphMetricsForChar char
Just GlyphMetrics{..} -> do
let V2 dx dy = fromIntegral <$> glyphHoriBearing
x = fromIntegral px + dx
y = -dy
V2 w h = fromIntegral <$> glyphSize
V2 aszW aszH = fromIntegral <$> atlasTextureSize
V2 texL texT = fromIntegral <$> fst glyphTexBB
V2 texR texB = fromIntegral <$> snd glyphTexBB
tl = (V2 x y , V2 (texL/aszW) (texT/aszH))
tr = (V2 (x+w) y , V2 (texR/aszW) (texT/aszH))
br = (V2 (x+w) (y+h), V2 (texR/aszW) (texB/aszH))
bl = (V2 x (y+h), V2 (texL/aszW) (texB/aszH))
let vs = UV.fromList [ tl, tr, br
, tl, br, bl
]
let V2 ax _ = glyphAdvance
return (vs, px + ax, mndx)
asciiChars :: String
asciiChars = map toEnum [32..126]
stringTris
:: ( MonadIO m
, MonadError TypograffitiError m
)
=> Atlas
-> Bool
-> String
-> m (Vector (V2 Float, V2 Float))
stringTris atlas useKerning str = do
(vs, _, _) <- foldM gen (mempty, 0, Nothing) str
return $ UV.concat vs
where gen (vs, penx, mndx) c = do
(newVs, newPenx, newMndx) <- makeCharQuad atlas useKerning penx mndx c
return (vs ++ [newVs], newPenx, newMndx)