{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} -- | -- Module: Gelatin.FreeType2 -- Copyright: (c) 2017 Schell Scivally -- License: MIT -- Maintainer: Schell Scivally -- -- This module provides easy freetype2 font rendering using gelatin's -- graphics primitives. -- module Gelatin.FreeType2.Internal where import Gelatin.GL import Gelatin.FreeType2.Utils import Gelatin.Picture.Internal import Control.Monad import Control.Monad.IO.Class import Control.Monad.State.Strict import Data.Maybe (fromMaybe) import Data.IntMap (IntMap) import qualified Data.IntMap as IM import Data.Map (Map) import qualified Data.Map as M import Foreign.Marshal.Utils (with) import Graphics.Rendering.FreeType.Internal.GlyphMetrics as GM import Graphics.Rendering.FreeType.Internal.Bitmap as BM -------------------------------------------------------------------------------- -- WordMap -------------------------------------------------------------------------------- type WordMap = Map String (V2 Float, Renderer2) -- | Load a string of words into the 'Atlas'. loadWords :: MonadIO m => Backend GLuint e V2V2 (V2 Float) Float Raster -- ^ The V2V2 backend needed to render font glyphs. -> Atlas -- ^ The atlas to load the words into. -> String -- ^ The string of words to load, with each word separated by spaces. -> m Atlas loadWords b atlas str = do wm <- liftIO $ foldM loadWord (atlasWordMap atlas) $ words str return atlas{atlasWordMap=wm} where loadWord wm word | Just _ <- M.lookup word wm = return wm | otherwise = do let pic = do freetypePicture atlas word pictureSize2 fst (sz,r) <- compilePictureT b pic return $ M.insert word (sz,r) wm -- | Unload any words not contained in the source string. unloadMissingWords :: MonadIO m => Atlas -- ^ The 'Atlas' to unload words from. -> String -- ^ The source string. -> m Atlas unloadMissingWords atlas str = do let wm = atlasWordMap atlas ws = M.fromList $ zip (words str) [(0::Int)..] missing = M.difference wm ws retain = M.difference wm missing dealoc = (liftIO . fst . snd) <$> missing sequence_ dealoc return atlas{atlasWordMap=retain} -------------------------------------------------------------------------------- -- Glyph -------------------------------------------------------------------------------- data GlyphSize = CharSize Float Float Int Int | PixelSize Int Int deriving (Show, Eq, Ord) glyphWidth :: GlyphSize -> Float glyphWidth (CharSize x y _ _) = if x == 0 then y else x glyphWidth (PixelSize x y) = fromIntegral $ if x == 0 then y else x glyphHeight :: GlyphSize -> Float glyphHeight (CharSize x y _ _) = if y == 0 then x else y glyphHeight (PixelSize x y) = fromIntegral $ if y == 0 then x else y -- | https://www.freetype.org/freetype2/docs/tutorial/step2.html data GlyphMetrics = GlyphMetrics { glyphTexBB :: (V2 Int, V2 Int) , glyphTexSize :: V2 Int , glyphSize :: V2 Int , glyphHoriBearing :: V2 Int , glyphVertBearing :: V2 Int , glyphAdvance :: V2 Int } deriving (Show, Eq) -------------------------------------------------------------------------------- -- Atlas -------------------------------------------------------------------------------- data Atlas = Atlas { atlasTexture :: GLuint , atlasTextureSize :: V2 Int , atlasLibrary :: FT_Library , atlasFontFace :: FT_Face , atlasMetrics :: IntMap GlyphMetrics , atlasGlyphSize :: GlyphSize , atlasWordMap :: WordMap , atlasFilePath :: FilePath } emptyAtlas :: FT_Library -> FT_Face -> GLuint -> Atlas emptyAtlas lib face t = Atlas t 0 lib face mempty (PixelSize 0 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 measure :: FT_Face -> Int -> AtlasMeasure -> Char -> FreeTypeIO AtlasMeasure measure face maxw am@AM{..} char | Just _ <- IM.lookup (fromEnum char) amMap = return am | otherwise = do let V2 x y = amXY V2 w h = amWH -- Load the char, replacing the glyph according to -- https://www.freetype.org/freetype2/docs/tutorial/step1.html loadChar face (fromIntegral $ fromEnum char) ft_LOAD_RENDER -- Get the glyph slot slot <- liftIO $ peek $ glyph face -- Get the bitmap 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 am = AM { amWH = V2 nw nh , amXY = V2 nx ny , rowHeight = rh , amMap = IM.insert (fromEnum char) amXY amMap } return am texturize :: IntMap (V2 Int) -> Atlas -> Char -> FreeTypeIO Atlas texturize xymap atlas@Atlas{..} char | Just pos@(V2 x y) <- IM.lookup (fromEnum char) xymap = do -- Load the char loadChar atlasFontFace (fromIntegral $ fromEnum char) ft_LOAD_RENDER -- Get the slot and bitmap slot <- liftIO $ peek $ glyph atlasFontFace bmp <- liftIO $ peek $ bitmap slot -- Update our texture by adding the bitmap glTexSubImage2D GL_TEXTURE_2D 0 (fromIntegral x) (fromIntegral y) (fromIntegral $ BM.width bmp) (fromIntegral $ rows bmp) GL_RED GL_UNSIGNED_BYTE (castPtr $ buffer bmp) -- Get the glyph metrics ftms <- liftIO $ peek $ metrics slot -- Add the metrics to the atlas let vecwh = fromIntegral <$> V2 (BM.width bmp) (rows bmp) canon = floor . (* 0.5) . (* 0.015625) . realToFrac . 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 -- | 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 here. allocAtlas :: MonadIO m => FilePath -- ^ 'FilePath' of the 'Font' to use for this 'Atlas'. -> GlyphSize -- ^ Size of glyphs in this 'Atlas' -> String -- ^ The characters to include in this 'Atlas'. -> m (Maybe Atlas) allocAtlas fontFilePath gs str = do e <- liftIO $ runFreeType $ do fce <- newFace fontFilePath case gs of PixelSize w h -> setPixelSizes fce (2*w) (2*h) CharSize w h dpix dpiy -> setCharSize fce (floor $ 26.6 * 2 * w) (floor $ 26.6 * 2 * h) dpix dpiy AM{..} <- foldM (measure fce 512) emptyAM str let V2 w h = amWH xymap = 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 } case e of Left err -> liftIO (print err) >> return Nothing Right (atlas,_) -> return $ Just atlas -- | Releases all resources associated with the given 'Atlas'. freeAtlas :: MonadIO m => Atlas -> m () freeAtlas a = liftIO $ do _ <- ft_Done_FreeType (atlasLibrary a) _ <- unloadMissingWords a "" with (atlasTexture a) $ \ptr -> glDeleteTextures 1 ptr makeCharQuad :: MonadIO m => Atlas -> Bool -> (Int, Maybe FT_UInt) -> Char -> VerticesT (V2 Float, V2 Float) m (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 . (/(64::Double)) . fromIntegral . fst) e _ -> return $ fromIntegral penx case IM.lookup ichar atlasMetrics of Nothing -> return (penx, mndx) 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)) tri tl tr br tri tl br bl let V2 ax _ = glyphAdvance return (px + ax, mndx) -- | A string containing all standard ASCII characters. -- This is often passed as the 'String' parameter in 'allocAtlas'. asciiChars :: String asciiChars = map toEnum [32..126] stringTris :: MonadIO m => Atlas -> Bool -> String -> VerticesT (V2 Float, V2 Float) m () stringTris atlas useKerning = foldM_ (makeCharQuad atlas useKerning) (0, Nothing) -------------------------------------------------------------------------------- -- Picture -------------------------------------------------------------------------------- -- | Constructs a 'TexturePictureT' of one word in all red. -- Colorization can then be done using 'setReplacementColor' in the picture -- computation, or by using 'redChannelReplacement' and passing that to the -- renderer after compilation, at render time. Keep in mind that any new word -- geometry will be discarded, since this computation does not return a new 'Atlas'. -- For that reason it is advised that you load the needed words before using this -- function. For loading words, see 'loadWords'. -- -- This is used in 'freetypeRenderer2' to construct the geometry of each word. -- 'freetypeRenderer2' goes further and stores these geometries, looking them up -- and constructing a string of word renderers for each input 'String'. freetypePicture :: MonadIO m => Atlas -- ^ The 'Atlas' from which to read font textures word geometry. -> String -- ^ The word to render. -> TexturePictureT m () -- ^ Returns a textured picture computation representing the texture and -- geometry of the input word. freetypePicture atlas@Atlas{..} str = do eKerning <- withFreeType (Just atlasLibrary) $ hasKerning atlasFontFace setTextures [atlasTexture] let useKerning = either (const False) id eKerning setGeometry $ triangles $ stringTris atlas useKerning str -------------------------------------------------------------------------------- -- Performance Rendering -------------------------------------------------------------------------------- -- | Constructs a 'Renderer2' from the given color and string. The 'WordMap' -- record of the given 'Atlas' is used to construct the string geometry, greatly -- improving performance and allowing longer strings to be compiled and renderered -- in real time. To create a new 'Atlas' see 'allocAtlas'. -- -- Note that since word geometries are stored in the 'Atlas' 'WordMap' and multiple -- renderers can reference the same 'Atlas', the returned 'Renderer2' contains a -- clean up operation that does nothing. It is expected that the programmer -- will call 'freeAtlas' manually when the 'Atlas' is no longer needed. freetypeRenderer2 :: MonadIO m => Backend GLuint e V2V2 (V2 Float) Float Raster -- ^ The V2V2 backend to use for compilation. -> Atlas -- ^ The 'Atlas' to read character textures from and load word geometry -- into. -> V4 Float -- ^ The solid color to render the string with. -> String -- ^ The string to render. -- This string can contain newlines, which will be respected. -> m (Renderer2, V2 Float, Atlas) -- ^ Returns the 'Renderer2', the size of the text and the new -- 'Atlas' with the loaded geometry of the string. freetypeRenderer2 b atlas0 color str = do atlas <- loadWords b atlas0 str let glyphw = glyphWidth $ atlasGlyphSize atlas spacew = fromMaybe glyphw $ do metrcs <- IM.lookup (fromEnum ' ') $ atlasMetrics atlas let V2 x _ = glyphAdvance metrcs return $ fromIntegral x glyphh = glyphHeight $ atlasGlyphSize atlas spaceh = glyphh isWhiteSpace c = c == ' ' || c == '\n' || c == '\t' renderWord :: [RenderTransform2] -> V2 Float -> String -> IO () renderWord _ _ "" = return () renderWord rs (V2 _ y) ('\n':cs) = renderWord rs (V2 0 (y + spaceh)) cs renderWord rs (V2 x y) (' ':cs) = renderWord rs (V2 (x + spacew) y) cs renderWord rs (V2 x y) cs = do let word = takeWhile (not . isWhiteSpace) cs rest = drop (length word) cs case M.lookup word (atlasWordMap atlas) of Nothing -> renderWord rs (V2 x y) rest Just (V2 w _, r) -> do let ts = [move x y, redChannelReplacementV4 color] snd r $ ts ++ rs renderWord rs (V2 (x + w) y) rest rr t = renderWord t 0 str measureString :: (V2 Float, V2 Float) -> String -> (V2 Float, V2 Float) measureString (V2 x y, V2 w h) "" = (V2 x y, V2 w h) measureString (V2 x y, V2 w _) (' ':cs) = let nx = x + spacew in measureString (V2 nx y, V2 (max w nx) y) cs measureString (V2 x y, V2 w h) ('\n':cs) = let ny = y + spaceh in measureString (V2 x ny, V2 w (max h ny)) cs measureString (V2 x y, V2 w h) cs = let word = takeWhile (not . isWhiteSpace) cs rest = drop (length word) cs n = case M.lookup word (atlasWordMap atlas) of Nothing -> (V2 x y, V2 w h) Just (V2 ww _, _) -> let nx = x + ww in (V2 nx y, V2 (max w nx) y) in measureString n rest V2 szw szh = snd $ measureString (0,0) str return ((return (), rr), V2 szw (max spaceh szh), atlas)