From ea2776515902b233a93bd4e3d768ce66c28a6073 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Thu, 19 Jan 2023 16:05:05 +1300 Subject: [PATCH] Draft public API akin to existing Typograffiti API. --- src/Typograffiti/Atlas.hs | 180 +++++++++++++++++++++++++++++++++++ src/Typograffiti/Cache.hs | 194 ++++++++++++++++++++++++++++++++++++++ src/Typograffiti/Glyph.hs | 0 src/Typograffiti/Store.hs | 111 ++++++++++++++++++++++ 4 files changed, 485 insertions(+) delete mode 100644 src/Typograffiti/Glyph.hs diff --git a/src/Typograffiti/Atlas.hs b/src/Typograffiti/Atlas.hs index e69de29..d6c266a 100644 --- a/src/Typograffiti/Atlas.hs +++ b/src/Typograffiti/Atlas.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +-- | +-- Module: Typograffiti.Atlas +-- Copyright: (c) 2018 Schell Scivally +-- License: MIT +-- Maintainer: Schell Scivally +-- +-- This module provides a font-character atlas to use in font rendering with +-- opengl. +-- +module Typograffiti.Atlas where + +import Control.Monad +import Control.Monad.Except (MonadError (..)) +import Control.Monad.IO.Class +import Data.Maybe (fromMaybe) +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 FreeType.Core.Types as BM +import FreeType.Support.Bitmap as BM +import FreeType.Support.Bitmap.Internal as BM +import Linear + +import Typograffiti.GL +import Typograffiti.Glyph +import Typograffiti.Utils + +------ +--- Atlas +------ + +data GlyphMetrics = GlyphMetrics { + glyphTexBB :: (V2 Int, V2 Int), + glyphTexSize :: V2 Int, + glyphSize :: V2 Int +} deriving (Show, Eq) + +data Atlas = Atlas { + atlasTexture :: GLuint, + atlasTextureSize :: V2 Int, + atlasMetrics :: IntMap GlyphMetrics, + atlasFilePath :: FilePath +} deriving (Show) + +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 + +glyphRetriever font glyph = do + ft_Load_Glyph font (fromIntegral $ fromEnum glyph) FT.FT_LOAD_RENDER + font' <- peek font + slot <- peek $ frGlyph font' + return (gsrBitmap slot, gsrMetrics slot) + +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 cb xymap atlas@Atlas{..} glyph + | Just pos@(V2 x y) <- IM.lookup (fromIntegral $ fromEnum glyph) xymap = do + (bmp, metrics) <- cb glyph + glTexSubImage2D GL.GL_TEXTURE_2D 0 + (fromIntegral x) (fromIntegral y) + (fromIntegral $ bWidth bmp) (fromIntegral $ bRows bmp) + GL.GL_RED GL.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), + glyphTexSize = vecwh, + glyphSize = vecsz + } + return atlas { atlasMetrics = IM.insert (fromEnum glyph) mtrcs atlasMetrics } + | otherwise = do + putStrLn ("Cound not find glyph " ++ show glyph) + return atlas + +allocAtlas :: (Int32 -> IO (FT_Bitmap, FT_Glyph_Metrics)) -> [Int32] -> IO Atlas +allocAtlas cb glyphs = do + AM {..} <- foldM (measure cb 512) emptyAM glyphs + let V2 w h = amWH + xymap = amMap + + [t] <- allocaArray 1 $ \ptr -> do + glGenTextures 1 ptr + peekArray 1 ptr + glActiveTexture 0 + glBindTexture GL.GL_TEXTURE_2D t + + glPixelStorei GL.GL_UNPACK_ALIGNMENT 1 + withCString (replicate (w * h) $ toEnum 0) $ + glTexImage2D GL.GL_TEXTURE_2D 0 GL.GL_RED (fromIntegral w) (fromIntegral h) + 0 GL.GL_RED GL.GL_UNSIGNED_BYTE . castPtr + atlas <- foldM (texturize cb xymap) (emptyAtlas t) glyphs + + glGenerateMipmap GL.GL_TEXTURE_2D + glTexParameteri GL.GL_TEXTURE_2D GL.GL_TEXTURE_WRAP_S GL.GL_REPEAT + glTexParameteri GL.GL_TEXTURE_2D GL.GL_TEXTURE_WRAP_T GL.GL_REPEAT + glTexParameteri GL.GL_TEXTURE_2D GL.GL_TEXTURE_MAG_FILTER GL.GL_LINEAR + glTexParameteri GL.GL_TEXTURE_2D GL.GL_TEXTURE_MIN_FILTER GL.GL_LINEAR + glBindTexture GL.GL_TEXTURE_2D 0 + glPixelStorei GL.GL_UNPACK_ALIGNMENT 4 + return atlas { atlasTextureSize = V2 w h } + +freeAtlas a = with (atlasTexture a) $ \ptr -> glDeleteTextures 1 ptr + +type Quads = (Float, Float, [(V2 Float, V2 Float)]) +makeCharQuad :: Atlas -> Quads -> (GlyphInfo, GlyphPos) -> IO Quads +makeCharQuad Atlas {..} (penx, peny, mLast) (GlyphInfo {codepoint=glyph}, GlyphPos {..}) = do + let iglyph = fromEnum glyph + case IM.lookup iglyph atlasMetrics of + Nothing -> return (penx, peny, mLast) + 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, + mLast ++ [tl, tr, br, tl, br, bl]) + where + f :: Int32 -> Float + f = fromIntegral + f' :: Int -> Float + f' = fromIntegral + +stringTris :: Atlas -> [(GlyphInfo, GlyphPos)] -> IO Quads +stringTris atlas = foldM (makeCharQuad atlas) (0, 0, []) +stringTris' :: Atlas -> [(GlyphInfo, GlyphPos)] -> IO [(V2 Float, V2 Float)] +stringTris' atlas glyphs = do + (_, _, ret) <- stringTris atlas glyphs + return ret diff --git a/src/Typograffiti/Cache.hs b/src/Typograffiti/Cache.hs index e69de29..4f660cf 100644 --- a/src/Typograffiti/Cache.hs +++ b/src/Typograffiti/Cache.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | +-- Module: Typograffiti.Cache +-- Copyright: (c) 2018 Schell Scivally +-- License: MIT +-- Maintainer: Schell Scivally +-- +-- This module provides a method of caching rendererd text, making it suitable +-- for interactive rendering. You can use the defaultCache or provide your own. +-- +module Typograffiti.Cache where + +import Control.Monad (foldM) +import Control.Monad.Except (MonadError (..), liftEither, + runExceptT) +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Bifunctor (first) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as B8 +import qualified Data.IntMap as IM +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (fromMaybe) +import qualified Data.Vector.Unboxed as UV +import Foreign.Marshal.Array +import Graphics.GL +import Linear + +import Typograffiti.Atlas +import Typograffiti.GL +import Typograffiti.Glyph + +data AllocatedRendering t = AllocatedRendering + { arDraw :: t -> V2 CInt -> IO () + -- ^ Draw the text with some transformation in some monad. + , arRelease :: IO () + -- ^ Release the allocated draw function in some monad. + , arSize :: V2 Int + -- ^ The size (in pixels) of the drawn text. + } + +makeDrawGlyphs = do + let position = 0 + uv = 1 + vert <- liftGL $ compileOGLShader vertexShader GL_VERTEX_SHADER + frag <- liftGL $ compileOGLShader fragmentShader GL_FRAGMENT_SHADER + prog <- liftGL $ compileOGLProgram [ + ("position", fromIntegral position), + ("uv", fromIntegral uv) + ] [vert, frag] + glUseProgram prog + glEnable GL_BLEND + glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA + -- Get uniform locations + pjU <- getUniformLocation prog "projection" + mvU <- getUniformLocation prog "modelview" + multU <- getUniformLocation prog "mult_color" + texU <- getUniformLocation prog "tex" + return $ \atlas glyphs -> do + vao <- newBoundVAO + pbuf <- newBuffer + uvbuf <- newBuffer + (ps, uvs) <- unzip <$> stringTris' atlas glyphs + bufferGeometry position pbuf $ UV.fromList ps + bufferGeometry uv uvbuf $ UV.fromList uvs + glBindVertexArray 0 + + let draw ts wsz = do + let (mv, multVal) = transformToUniforms ts + glUseProgram prog + let pj = orthoProjection wsz + updateUniform prog pjU pj + updateUniform prog mvU mv + updateUniform prog multU multVal + updateUniform prog texU (0 :: Int) + glBindVertexArray vao + withBoundTextures [atlasTexture atlas] $ do + drawVAO prog vao GL_TRIANGLES (fromIntegral $ length ps) + glBindVertexArray 0 + release = do + withArray [pbuf, uvbuf] $ glDeleteBuffers 2 + withArray [vao] $ glDeleteVertexArrays 1 + (tl, br) = boundingBox ps + size = br - tl + return AllocatedRendering { + arDraw = draw, + arRelease = release, + arSize = round <$> size + } + +vertexShader :: ByteString +vertexShader = B8.pack $ unlines + [ "#version 330 core" + , "uniform mat4 projection;" + , "uniform mat4 modelview;" + , "in vec2 position;" + , "in vec2 uv;" + , "out vec2 fuv;" + , "void main () {" + , " fuv = uv;" + , " gl_Position = projection * modelview * vec4(position.xy, 0.0, 1.0);" + , "}" + ] + +fragmentShader :: ByteString +fragmentShader = B8.pack $ unlines + [ "#version 330 core" + , "in vec2 fuv;" + , "out vec4 fcolor;" + , "uniform sampler2D tex;" + , "uniform vec4 mult_color;" + , "void main () {" + , " vec4 tcolor = texture(tex, fuv);" + , " fcolor = vec4(mult_color.rgb, mult_color.a * tcolor.r);" + , "}" + ] + +------ +--- Transforms +------ + +data SpatialTransform = SpatialTransformTranslate (V2 Float) + | SpatialTransformScale (V2 Float) + | SpatialTransformRotate Float + + +data TextTransform = TextTransformMultiply (V4 Float) + | TextTransformSpatial SpatialTransform + + +transformToUniforms :: [TextTransform] -> (M44 Float, V4 Float) +transformToUniforms = foldl toUniform (identity, 1.0) + where toUniform (mv, clr) (TextTransformMultiply c) = + (mv, clr * c) + toUniform (mv, clr) (TextTransformSpatial s) = + let mv1 = case s of + SpatialTransformTranslate (V2 x y) -> + mv !*! mat4Translate (V3 x y 0) + SpatialTransformScale (V2 x y) -> + mv !*! mat4Scale (V3 x y 1) + SpatialTransformRotate r -> + mv !*! mat4Rotate r (V3 0 0 1) + in (mv1, clr) + +move :: Float -> Float -> TextTransform +move x y = + TextTransformSpatial + $ SpatialTransformTranslate + $ V2 x y + + +scale :: Float -> Float -> TextTransform +scale x y = + TextTransformSpatial + $ SpatialTransformScale + $ V2 x y + + +rotate :: Float -> TextTransform +rotate = + TextTransformSpatial + . SpatialTransformRotate + + +color :: Float -> Float -> Float -> Float -> TextTransform +color r g b a = + TextTransformMultiply + $ V4 r g b a + + +alpha :: Float -> TextTransform +alpha = + TextTransformMultiply + . V4 1 1 1 + + +instance Layout [TextTransform] where + translate ts (V2 x y) = ts ++ [move x y] + + +liftGL + :: ( MonadIO m + , MonadError TypograffitiError m + ) + => m (Either String a) + -> m a +liftGL n = do + let lft = liftEither . first TypograffitiErrorGL + n >>= lft diff --git a/src/Typograffiti/Glyph.hs b/src/Typograffiti/Glyph.hs deleted file mode 100644 index e69de29..0000000 diff --git a/src/Typograffiti/Store.hs b/src/Typograffiti/Store.hs index e69de29..b71400e 100644 --- a/src/Typograffiti/Store.hs +++ b/src/Typograffiti/Store.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | +-- Module: Typograffiti.Monad +-- Copyright: (c) 2018 Schell Scivally +-- License: MIT +-- Maintainer: Schell Scivally +-- +-- A storage context an ops for rendering text with multiple fonts +-- and sizes, hiding the details of the Atlas and WordCache. +module Typograffiti.Store where + + +import Control.Concurrent.STM (TMVar, atomically, newTMVar, putTMVar, + readTMVar, takeTMVar) +import Control.Monad.Except (MonadError (..), liftEither) +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Set (Set) +import qualified Data.Set as S +import Linear + + +import Typograffiti.Atlas +import Typograffiti.Cache +import Typograffiti.Glyph + +-- 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 + +data GlyphSize = CharSize Float Float Int Int + | PixelSize Int Int + deriving (Show, Eq, Ord) + +makeDrawTextIndented lib filepath index fontsize features sampletext indent = do + font <- ft_New_Face lib filepath index + case fontsize of + PixelSize w h -> ft_Set_Pixel_Sizes font (toEnum $ x2 w) (toEnum $ x2 h) + CharSize w h dpix dpiy -> ft_Set_Char_Size font (floor $ 26.6 * 2 * w) + (floor $ 26.6 * 2 * h) + (toEnum dpix) (toEnum dpiy) + + bytes <- B.readFile filepath + let font' = createFont $ createFace bytes $ toEnum $ fromEnum index + let glyphs = map (codepoint . fst) $ + shape font' defaultBuffer { text = sampletext } features + let glyphs' = map toEnum $ IS.toList $ IS.fromList $ map fromEnum glyphs + atlas <- allocAtlas (glyphRetriever font) glyphs' + ft_Done_Face font + + drawGlyphs <- makeDrawGlyphs + return $ drawLinesWrapper $ \string -> + drawGlyphs atlas $ shape font' defaultBuffer { text = string } features + where x2 = (*2) + +makeDrawTextIndented' a b c d e f = + ft_With_FreeType $ \ft -> makeDrawText ft a b c d e f + +makeDrawText a b c d e f = makeDrawTextIndented a b c d e f +makeDrawText' a b c d e = ft_With_FreeType $ \ft -> makeDrawText ft a b c d e + +-- Note: May glitch upon ligatures. +makeDrawAsciiIndented a b c d e f = + makeDrawTextIndented a b c d e (map toEnum [32..126]) f +makeDrawAsciiIndented' a b c d e = + ft_With_FreeType $ \ft -> makeDrawAsciiIndented ft a b c d e +makeDrawAscii a b c d e = makeDrawText a b c d e $ map toEnum [32..126] +makeDrawAscii' a b c d = ft_With_FreeType $ \ft -> makeDrawAscii ft a b c d + +drawLinesWrapper indent cb string = do + renderers <- mapM cb $ map processLine $ lines string + let drawLine ts wsz y renderer = do + arDraw renderer (move 0 y:ts) wsz + let V2 _ height = arSize renderer + return y + height + let draw ts wsz = do + foldM (drawLine ts wsz) 0 renderers + return () + let sizes = map arSize renderers + let size = V2 (max [x | V2 x _ <- sizes]) (sum [y | V2 _ y <- sizes]) + let release = do + forM renderers arRelease + return () + return AllocatedRendering { + arDraw = draw, + arRelease = release, + arSize = size + } + where + processLine "" = " " -- enforce nonempty + processLine cs = expandTabs cs + -- monospace tabshaping, good enough outside full line-layout. + expandTabs n cs = case break (== '\t') of + (pre, '\t':cs') -> let spaces = indent - ((length pre + n) `rem` indent) + in pre ++ replicate spaces ' ' ++ expandTabs (n + length pre + spaces) cs' + (tail, _) -> tail + +-- Add cache of imported fonts +--- Key by filepath & index +--- Maps to Harfbuzz & FreeType fonts, +--- as well as a list of atlases associated with glyphsets & fontfeatures. -- 2.30.2