From 3ed8e9c1e9f76b39e14b9be0c2f4d03a506f7a61 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Sat, 28 Jan 2023 16:57:12 +1300 Subject: [PATCH] Code cleanliness fixes, propagate exceptions, & add more spatial transforms. --- src/Graphics/Text/Font/Render.hs | 625 ------------------------------- src/Typograffiti.hs | 2 +- src/Typograffiti/Atlas.hs | 57 +-- src/Typograffiti/Cache.hs | 30 +- src/Typograffiti/GL.hs | 8 +- src/Typograffiti/Store.hs | 29 +- src/Typograffiti/Text.hs | 49 ++- 7 files changed, 95 insertions(+), 705 deletions(-) delete mode 100644 src/Graphics/Text/Font/Render.hs diff --git a/src/Graphics/Text/Font/Render.hs b/src/Graphics/Text/Font/Render.hs deleted file mode 100644 index 2745392..0000000 --- a/src/Graphics/Text/Font/Render.hs +++ /dev/null @@ -1,625 +0,0 @@ -{-# LANGUAGE RecordWildCards, LambdaCase #-} -{-# LANGUAGE FlexibleContexts, FlexibleInstances #-} -module Graphics.Text.Font.Render where - -import Data.Map (Map) -import Data.Int (Int32) -import Data.IntMap (IntMap) -import qualified Data.IntMap as IM -import qualified Data.IntSet as IS -import Linear.V2 (V2(..)) -import Linear.V (toV, dim, Finite, Size) -import FreeType.Core.Base (FT_Library, FT_Face, FT_FaceRec(..), ft_Load_Glyph, - FT_GlyphSlotRec(..), FT_Glyph_Metrics(..), - ft_Set_Pixel_Sizes, ft_Set_Char_Size, ft_New_Face, - ft_With_FreeType, ft_Reference_Face, ft_Done_Face) -import qualified FreeType.Core.Base as FT -import FreeType.Core.Types (FT_Bitmap(..)) -import Data.Text.Glyphize (GlyphInfo(..), GlyphPos(..), - shape, Buffer(..), defaultBuffer, - createFace, createFont) - -import Graphics.GL as GL -import qualified Graphics.GL.Core32 as GL -import Control.Monad (foldM, when) -import Control.Exception (assert, Exception) -import qualified Data.Foldable as F -import GHC.TypeNats (KnownNat) -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as B8 -import qualified Data.ByteString as B - -import Linear.V3 (V3(..)) -import Linear.V4 (V4(..)) -import Linear.Matrix (M44, (!*!), identity, mkTransformationMat, mkTransformation) -import Linear.Quaternion (axisAngle) -import Linear.Projection (ortho) -import Data.List (foldl') - -import Foreign.Ptr (castPtr, nullPtr) -import Foreign.C.String (withCString, peekCAStringLen) -import Foreign.C.Types (CInt) -import Foreign.Marshal.Array (peekArray, allocaArray, withArray) -import Foreign.Marshal.Utils (with) -import Foreign.Storable (Storable(..)) -import qualified Data.Vector.Storable as SV -import Data.Vector.Unboxed (Unbox) -import qualified Data.Vector.Unboxed as UV - ------- ---- 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 - -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) - -mat4Translate :: Num a => V3 a -> M44 a -mat4Translate = mkTransformationMat identity - -mat4Rotate phi v = mkTransformation (axisAngle v phi) (V3 0 0 0) - - -mat4Scale :: Num a => V3 a -> M44 a -mat4Scale (V3 x y z) = - V4 (V4 x 0 0 0) - (V4 0 y 0 0) - (V4 0 0 z 0) - (V4 0 0 0 1) - -orthoProjection :: Integral a => V2 a -> M44 Float -orthoProjection (V2 ww wh) = - let (hw,hh) = (fromIntegral ww, fromIntegral wh) - in ortho 0 hw hh 0 0 1 - - ------- ---- OpenGL Utilities ------- - -newBuffer :: IO GLuint -newBuffer = do - [b] <- allocaArray 1 $ \ptr -> do - glGenBuffers 1 ptr - peekArray 1 ptr - return b - --- | Buffer some geometry into an attribute. --- The type variable 'f' should be V0, V1, V2, V3 or V4. -bufferGeometry - :: ( Foldable f - , Unbox (f Float) - , Storable (f Float) - , Finite f - , KnownNat (Size f) - ) - => GLuint - -- ^ The attribute location. - -> GLuint - -- ^ The buffer identifier. - -> UV.Vector (f Float) - -- ^ The geometry to buffer. - -> IO () -bufferGeometry loc buf as - | UV.null as = return () - | otherwise = do - let v = UV.head as - asize = UV.length as * sizeOf v - n = fromIntegral $ dim $ toV v - glBindBuffer GL.GL_ARRAY_BUFFER buf - SV.unsafeWith (convertVec as) $ \ptr -> - glBufferData GL.GL_ARRAY_BUFFER (fromIntegral asize) (castPtr ptr) GL.GL_STATIC_DRAW - glEnableVertexAttribArray loc - glVertexAttribPointer loc n GL.GL_FLOAT GL.GL_FALSE 0 nullPtr - clearErrors "bufferGeometry" - -convertVec - :: (Unbox (f Float), Foldable f) => UV.Vector (f Float) -> SV.Vector GLfloat -convertVec = - SV.convert . UV.map realToFrac . UV.concatMap (UV.fromList . F.toList) - -clearErrors str = do - err' <- glGetError - when (err' /= 0) $ do - putStrLn $ unwords [str, show err'] - assert False $ return () - -compileOGLShader - :: ByteString - -- ^ The shader source - -> GLenum - -- ^ The shader type (vertex, frag, etc) - -> IO (Either String GLuint) - -- ^ Either an error message or the generated shader handle. -compileOGLShader src shType = do - shader <- glCreateShader shType - if shader == 0 - then return $ Left "Could not create shader" - else do - success <- do - withCString (B8.unpack src) $ \ptr -> - with ptr $ \ptrptr -> glShaderSource shader 1 ptrptr nullPtr - - glCompileShader shader - with (0 :: GLint) $ \ptr -> do - glGetShaderiv shader GL_COMPILE_STATUS ptr - peek ptr - - if success == GL_FALSE - then do - err <- do - infoLog <- with (0 :: GLint) $ \ptr -> do - glGetShaderiv shader GL_INFO_LOG_LENGTH ptr - logsize <- peek ptr - allocaArray (fromIntegral logsize) $ \logptr -> do - glGetShaderInfoLog shader logsize nullPtr logptr - peekArray (fromIntegral logsize) logptr - - return $ unlines [ "Could not compile shader:" - , B8.unpack src - , map (toEnum . fromEnum) infoLog - ] - return $ Left err - else return $ Right shader - -compileOGLProgram - :: [(String, Integer)] - -> [GLuint] - -> IO (Either String GLuint) -compileOGLProgram attribs shaders = do - (program, success) <- do - program <- glCreateProgram - F.forM_ shaders (glAttachShader program) - F.forM_ attribs - $ \(name, loc) -> - withCString name - $ glBindAttribLocation program - $ fromIntegral loc - glLinkProgram program - - success <- with (0 :: GLint) $ \ptr -> do - glGetProgramiv program GL_LINK_STATUS ptr - peek ptr - return (program, success) - - if success == GL_FALSE - then with (0 :: GLint) $ \ptr -> do - glGetProgramiv program GL_INFO_LOG_LENGTH ptr - logsize <- peek ptr - infoLog <- allocaArray (fromIntegral logsize) $ \logptr -> do - glGetProgramInfoLog program logsize nullPtr logptr - peekArray (fromIntegral logsize) logptr - return - $ Left - $ unlines - [ "Could not link program" - , map (toEnum . fromEnum) infoLog - ] - else do - F.forM_ shaders glDeleteShader - return $ Right program - -newBoundVAO :: IO GLuint -newBoundVAO = do - [vao] <- allocaArray 1 $ \ptr -> do - glGenVertexArrays 1 ptr - peekArray 1 ptr - glBindVertexArray vao - return vao - -drawVAO - :: GLuint - -- ^ The program - -> GLuint - -- ^ The vao - -> GLenum - -- ^ The draw mode - -> GLsizei - -- ^ The number of vertices to draw - -> IO () -drawVAO program vao mode num = do - glUseProgram program - glBindVertexArray vao - clearErrors "drawBuffer:glBindVertex" - glDrawArrays mode 0 num - clearErrors "drawBuffer:glDrawArrays" - -withBoundTextures :: [GLuint] -> IO a -> IO a -withBoundTextures ts f = do - mapM_ (uncurry bindTex) (zip ts [GL_TEXTURE0 ..]) - a <- f - glBindTexture GL_TEXTURE_2D 0 - return a - where bindTex tex u = glActiveTexture u >> glBindTexture GL_TEXTURE_2D tex - - ---- - -getUniformLocation :: GLuint -> String -> IO GLint -getUniformLocation program ident = withCString ident $ glGetUniformLocation program - -class UniformValue a where - updateUniform - :: GLuint - -- ^ The program - -> GLint - -- ^ The uniform location - -> a - -- ^ The value. - -> IO () - -clearUniformUpdateError :: Show a => GLuint -> GLint -> a -> IO () -clearUniformUpdateError prog loc val = glGetError >>= \case - 0 -> return () - e -> do - let buf = replicate 256 ' ' - ident <- withCString buf - $ \strptr -> with 0 - $ \szptr -> do - glGetActiveUniformName prog (fromIntegral loc) 256 szptr strptr - sz <- peek szptr - peekCAStringLen (strptr, fromIntegral sz) - putStrLn $ unwords - [ "Could not update uniform" - , ident - , "with value" - , show val - , ", encountered error (" ++ show e ++ ")" - , show (GL_INVALID_OPERATION :: Integer, "invalid operation" :: String) - , show (GL_INVALID_VALUE :: Integer, "invalid value" :: String) - ] - assert False $ return () - - -instance UniformValue Bool where - updateUniform p loc bool = do - glUniform1i loc $ if bool then 1 else 0 - clearUniformUpdateError p loc bool - -instance UniformValue Int where - updateUniform p loc enum = do - glUniform1i loc $ fromIntegral $ fromEnum enum - clearUniformUpdateError p loc enum - -instance UniformValue Float where - updateUniform p loc float = do - glUniform1f loc $ realToFrac float - clearUniformUpdateError p loc float - -instance UniformValue Double where - updateUniform p loc d = do - glUniform1f loc $ realToFrac d - clearUniformUpdateError p loc d - -instance UniformValue (V2 Float) where - updateUniform p loc v = do - let V2 x y = fmap realToFrac v - glUniform2f loc x y - clearUniformUpdateError p loc v - -instance UniformValue (V3 Float) where - updateUniform p loc v = do - let V3 x y z = fmap realToFrac v - glUniform3f loc x y z - clearUniformUpdateError p loc v - -instance UniformValue (V4 Float) where - updateUniform p loc v = do - let (V4 r g b a) = realToFrac <$> v - glUniform4f loc r g b a - clearUniformUpdateError p loc v - -instance UniformValue (M44 Float) where - updateUniform p loc val = do - with val $ glUniformMatrix4fv loc 1 GL_TRUE . castPtr - clearUniformUpdateError p loc val - -instance UniformValue (V2 Int) where - updateUniform p loc v = do - let V2 x y = fmap fromIntegral v - glUniform2i loc x y - clearUniformUpdateError p loc v - -instance UniformValue (Int,Int) where - updateUniform p loc = updateUniform p loc . uncurry V2 - -liftGL - :: IO (Either String a) - -> IO a -liftGL n = do - let lft (Left msg) = error msg - lft (Right a) = return a - n >>= lft - -boundingBox [] = (0,0) -boundingBox vs = foldl' f (br,tl) vs - where mn a = min a . realToFrac - mx a = max a . realToFrac - f (a, b) c = (mn <$> a <*> c, mx <$> b <*> c) - inf = 1/0 - ninf = (-1)/0 - tl = V2 ninf ninf - br = V2 inf inf - ------- ---- Simple API (Abstracting Harfbuzz) ------- - -data GlyphSize = CharSize Float Float Int Int - | PixelSize Int Int - deriving (Show, Eq, Ord) - -makeDrawText lib filepath index fontsize features sampletext = 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 $ \string -> - drawGlyphs atlas $ shape font' defaultBuffer { text = string } features - where x2 = (*2) - -makeDrawText' a b c d e = ft_With_FreeType $ \ft -> makeDrawText ft a b c d e diff --git a/src/Typograffiti.hs b/src/Typograffiti.hs index 097e1ef..2cf48f3 100644 --- a/src/Typograffiti.hs +++ b/src/Typograffiti.hs @@ -10,7 +10,7 @@ module Typograffiti( TypograffitiError(..), allocAtlas, freeAtlas, stringTris, Atlas(..), GlyphMetrics(..), makeDrawGlyphs, AllocatedRendering(..), Layout(..), - SpatialTransform(..), TextTransform(..), move, scale, rotate, color, alpha, + SpatialTransform(..), TextTransform(..), move, scale, rotate, skew, color, alpha, withFontStore, newFontStore, FontStore(..), Font(..), SampleText (..), defaultSample, addSampleFeature, parseSampleFeature, parseSampleFeatures, addFontVariant, parseFontVariant, parseFontVariants, diff --git a/src/Typograffiti/Atlas.hs b/src/Typograffiti/Atlas.hs index 2c07d20..b87fe7b 100644 --- a/src/Typograffiti/Atlas.hs +++ b/src/Typograffiti/Atlas.hs @@ -1,6 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} -- | -- Module: Typograffiti.Atlas -- Copyright: (c) 2018 Schell Scivally @@ -12,40 +11,38 @@ -- 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.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 Graphics.GL.Types (GLuint) import FreeType.Core.Base import FreeType.Core.Types as BM -import FreeType.Support.Bitmap as BM -import FreeType.Support.Bitmap.Internal as BM -import Linear +import FreeType.Exception (FtError (..)) +import Linear (V2 (..)) import Data.Int (Int32) -import Data.Text.Glyphize (GlyphInfo(..), GlyphPos(..)) import Data.Word (Word32) +import Data.Text.Glyphize (GlyphInfo (..), GlyphPos (..)) -import Foreign.Storable (Storable(..)) +import Foreign.Storable (peek) import Foreign.Ptr (castPtr) -import Foreign.Marshal.Array (allocaArray, peekArray) import Foreign.C.String (withCString) import Typograffiti.GL -- | Represents a failure to render text. data TypograffitiError = - TypograffitiErrorNoGlyphMetricsForChar Char + TypograffitiErrorNoMetricsForGlyph Int -- ^ The are no glyph metrics for this character. This probably means -- the character has not been loaded into the atlas. - | TypograffitiErrorFreetype String String + | TypograffitiErrorFreetype String Int32 -- ^ There was a problem while interacting with the freetype2 library. | TypograffitiErrorGL String -- ^ There was a problem while interacting with OpenGL. @@ -59,8 +56,6 @@ data TypograffitiError = data GlyphMetrics = GlyphMetrics { glyphTexBB :: (V2 Int, V2 Int), -- ^ Bounding box of the glyph in the texture. - glyphTexSize :: V2 Int, - -- ^ Size of the glyph in the texture. glyphSize :: V2 Int -- ^ Size of the glyph onscreen. } deriving (Show, Eq) @@ -71,15 +66,13 @@ data Atlas = Atlas { -- ^ The texture holding the pre-rendered glyphs. atlasTextureSize :: V2 Int, -- ^ The size of the texture. - atlasMetrics :: IntMap GlyphMetrics, + atlasMetrics :: IntMap GlyphMetrics -- ^ Mapping from glyphs to their position in the texture. - atlasFilePath :: FilePath - -- ^ Filepath for the font. } deriving (Show) -- | Initializes an empty atlas. emptyAtlas :: GLuint -> Atlas -emptyAtlas t = Atlas t 0 mempty "" +emptyAtlas t = Atlas t 0 mempty -- | Precomputed positioning of glyphs in an `Atlas` texture. data AtlasMeasure = AM { @@ -106,16 +99,17 @@ spacing = 1 -- when calling the low-level APIs. type GlyphRetriever m = Word32 -> m (FT_Bitmap, FT_Glyph_Metrics) -- | Default callback for glyph lookups, with no modifications. -glyphRetriever :: MonadIO m => FT_Face -> GlyphRetriever m -glyphRetriever font glyph = liftIO $ do - ft_Load_Glyph font (fromIntegral $ fromEnum glyph) FT_LOAD_RENDER - font' <- peek font - slot <- peek $ frGlyph font' +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) -- | Extract the measurements of a character in the FT_Face and append it to -- the given AtlasMeasure. -measure :: MonadIO m => GlyphRetriever m -> Int -> AtlasMeasure -> Word32 -> m AtlasMeasure +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 @@ -139,7 +133,8 @@ measure cb maxw am@AM{..} glyph return am -- | Uploads glyphs into an `Atlas` texture for the GPU to composite. -texturize :: MonadIO m => GlyphRetriever m -> IntMap (V2 Int) -> Atlas -> Word32 -> m Atlas +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 @@ -156,7 +151,6 @@ texturize cb xymap atlas@Atlas{..} glyph 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 } @@ -169,7 +163,8 @@ texturize cb xymap atlas@Atlas{..} glyph -- 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 once. -allocAtlas :: (MonadIO m, MonadFail m) => GlyphRetriever m -> [Word32] -> m 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 @@ -204,7 +199,7 @@ makeCharQuad :: (MonadIO m, MonadError TypograffitiError m) => 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) + Nothing -> throwError $ TypograffitiErrorNoMetricsForGlyph iglyph Just GlyphMetrics {..} -> do let x = penx + f x_offset y = peny + f y_offset @@ -236,3 +231,11 @@ stringTris' :: (MonadIO m, MonadError TypograffitiError m) => stringTris' atlas glyphs = do (_, _, ret) <- stringTris atlas glyphs return $ UV.concat $ reverse ret + +-- | Internal utility to propagate FreeType errors into Typograffiti errors. +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 diff --git a/src/Typograffiti/Cache.hs b/src/Typograffiti/Cache.hs index 0102e90..1708a87 100644 --- a/src/Typograffiti/Cache.hs +++ b/src/Typograffiti/Cache.hs @@ -1,9 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -- | -- Module: Typograffiti.Cache -- Copyright: (c) 2018 Schell Scivally @@ -15,22 +11,17 @@ -- module Typograffiti.Cache where -import Control.Monad (foldM) -import Control.Monad.Except (MonadError (..), liftEither, - runExceptT) +import Control.Monad.Except (MonadError (..), liftEither) import Control.Monad.Fail (MonadFail (..)) 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 Foreign.Marshal.Array (withArray) import Graphics.GL -import Linear +import Linear (V2 (..), V3 (..), V4 (..), M44 (..), + (!*!), identity) import Data.Text.Glyphize (GlyphInfo(..), GlyphPos(..)) import Typograffiti.Atlas @@ -155,6 +146,10 @@ data SpatialTransform = SpatialTransformTranslate (V2 Float) -- ^ Resize the text. | SpatialTransformRotate Float -- ^ Enlarge the text. + | SpatialTransformSkew Float + -- ^ Skew the text, approximating italics (or rather obliques). + | SpatialTransform (M44 Float) + -- ^ Apply an arbitrary matrix transform to the text. -- | Modify the rendered text. data TextTransform = TextTransformMultiply (V4 Float) @@ -175,6 +170,9 @@ transformToUniforms = foldl toUniform (identity, 1.0) mv !*! mat4Scale (V3 x y 1) SpatialTransformRotate r -> mv !*! mat4Rotate r (V3 0 0 1) + SpatialTransformSkew x -> + mv !*! mat4SkewXbyY x + SpatialTransform mat -> mv !*! mat in (mv1, clr) -- | Shift the text horizontally or vertically. @@ -197,6 +195,12 @@ rotate = TextTransformSpatial . SpatialTransformRotate +skew :: Float -> TextTransform +skew = TextTransformSpatial . SpatialTransformSkew + +matrix :: M44 Float -> TextTransform +matrix = TextTransformSpatial . SpatialTransform + -- | Recolour the text. color :: Float -> Float -> Float -> Float -> TextTransform color r g b a = diff --git a/src/Typograffiti/GL.hs b/src/Typograffiti/GL.hs index 5166757..d3ab210 100644 --- a/src/Typograffiti/GL.hs +++ b/src/Typograffiti/GL.hs @@ -23,7 +23,6 @@ import Graphics.GL.Core32 import Graphics.GL.Types import Linear import Linear.V (Finite, Size, dim, toV) -import Data.List (foldl') -- | Allocates a new active texture (image data) in the GPU. allocAndActivateTex :: (MonadIO m, MonadFail m) => GLenum -> m GLuint @@ -349,6 +348,13 @@ mat4Scale (V3 x y z) = (V4 0 0 z 0) (V4 0 0 0 1) +mat4SkewXbyY :: Num a => a -> M44 a +mat4SkewXbyY a = + V4 (V4 1 a 0 0) + (V4 0 1 0 0) + (V4 0 0 1 0) + (V4 0 0 0 1) + -- | Constructs a matrix that converts screen coordinates to range 1,-1; with perspective. orthoProjection :: Integral a diff --git a/src/Typograffiti/Store.hs b/src/Typograffiti/Store.hs index c18820b..bdd2b40 100644 --- a/src/Typograffiti/Store.hs +++ b/src/Typograffiti/Store.hs @@ -3,7 +3,8 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} -- | -- Module: Typograffiti.Monad -- Copyright: (c) 2018 Schell Scivally @@ -17,21 +18,17 @@ module Typograffiti.Store where import Control.Concurrent.STM (TMVar, atomically, newTMVar, putTMVar, readTMVar, takeTMVar) -import Control.Monad.Except (MonadError (..), liftEither, runExceptT, ExceptT (..)) +import Control.Monad.Except (MonadError (..), runExceptT, ExceptT (..)) import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Fail (MonadFail (..)) import Control.Monad (unless) import Data.Map (Map) import qualified Data.Map as M -import Data.Set (Set) -import qualified Data.Set as S import qualified Data.IntSet as IS -import Linear import qualified Data.ByteString as B import Data.Text.Glyphize (defaultBuffer, Buffer(..), shape, - GlyphInfo(..), GlyphPos(..)) + GlyphInfo(..), GlyphPos(..), FontOptions) import qualified Data.Text.Glyphize as HB -import Data.Text.Lazy (Text, pack) import qualified Data.Text.Lazy as Txt import FreeType.Core.Base import FreeType.Core.Types (FT_Fixed) @@ -42,9 +39,15 @@ import Typograffiti.Cache import Typograffiti.Text (GlyphSize(..), drawLinesWrapper, SampleText(..)) import Typograffiti.Rich (RichText(..)) +-- Since HarfBuzz language bindings neglected to declare these itself. +deriving instance Eq HB.Variation +deriving instance Ord HB.Variation +deriving instance Eq FontOptions +deriving instance Ord FontOptions + -- | Stored fonts at specific sizes. data FontStore n = FontStore { - fontMap :: TMVar (Map (FilePath, GlyphSize, Int) Font), + fontMap :: TMVar (Map (FilePath, GlyphSize, Int, FontOptions) Font), -- ^ Map for looking up previously-opened fonts & their atlases. drawGlyphs :: Atlas -> [(GlyphInfo, GlyphPos)] -> n (AllocatedRendering [TextTransform]), -- ^ Cached routine for compositing from the given atlas. @@ -69,7 +72,7 @@ makeDrawTextCached :: (MonadIO m, MonadFail m, MonadError TypograffitiError m, m (RichText -> n (AllocatedRendering [TextTransform])) makeDrawTextCached store filepath index fontsize SampleText {..} = do s <- liftIO $ atomically $ readTMVar $ fontMap store - font <- case M.lookup (filepath, fontsize, index) s of + font <- case M.lookup (filepath, fontsize, index, fontOptions) s of Nothing -> allocFont store filepath index fontsize fontOptions Just font -> return font @@ -89,9 +92,9 @@ makeDrawTextCached store filepath index fontsize SampleText {..} = do -- | Opens & sizes the given font using both FreeType & Harfbuzz, -- loading it into the `FontStore` before returning. -allocFont :: (MonadIO m) => +allocFont :: (MonadIO m, MonadError TypograffitiError m) => FontStore n -> FilePath -> Int -> GlyphSize -> HB.FontOptions -> m Font -allocFont FontStore {..} filepath index fontsize options = liftIO $ do +allocFont FontStore {..} filepath index fontsize options = liftFreetype $ do font <- ft_New_Face lib filepath $ toEnum index case fontsize of PixelSize w h -> ft_Set_Pixel_Sizes font (toEnum $ x2 w) (toEnum $ x2 h) @@ -110,7 +113,7 @@ allocFont FontStore {..} filepath index fontsize options = liftIO $ do atomically $ do map <- takeTMVar fontMap - putTMVar fontMap $ M.insert (filepath, fontsize, index) ret map + putTMVar fontMap $ M.insert (filepath, fontsize, index, options) ret map return ret where x2 = (*2) @@ -119,7 +122,7 @@ allocFont FontStore {..} filepath index fontsize options = liftIO $ do -- | Allocates a new Atlas for the given font & glyphset, -- loading it into the atlas cache before returning. -allocAtlas' :: (MonadIO m, MonadFail m) => +allocAtlas' :: (MonadIO m, MonadFail m, MonadError TypograffitiError m) => TMVar [(IS.IntSet, Atlas)] -> FT_Face -> IS.IntSet -> m Atlas allocAtlas' atlases font glyphset = do let glyphs = map toEnum $ IS.toList glyphset diff --git a/src/Typograffiti/Text.hs b/src/Typograffiti/Text.hs index f215a13..0d5ba28 100644 --- a/src/Typograffiti/Text.hs +++ b/src/Typograffiti/Text.hs @@ -1,8 +1,4 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} -- | @@ -16,22 +12,16 @@ module Typograffiti.Text where -import Control.Concurrent.STM (TMVar, atomically, newTMVar, putTMVar, - readTMVar, takeTMVar) -import Control.Monad.Except (MonadError (..), liftEither, runExceptT) +import Control.Monad.Except (MonadError (..), runExceptT) import Control.Monad.Fail (MonadFail (..)) import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad (foldM, forM, unless) -import Data.Map (Map) -import qualified Data.Map as M -import Data.Set (Set) -import qualified Data.Set as S import qualified Data.IntSet as IS -import Linear +import Linear (V2 (..)) import qualified Data.ByteString as B -import Data.Text.Glyphize (defaultBuffer, Buffer(..), shape, GlyphInfo(..), - parseFeature, parseVariation, Variation(..), - FontOptions(..), defaultFontOptions) +import Data.Text.Glyphize (defaultBuffer, shape, GlyphInfo (..), + parseFeature, parseVariation, Variation (..), + FontOptions (..), defaultFontOptions) import qualified Data.Text.Glyphize as HB import FreeType.Core.Base import FreeType.Core.Types (FT_Fixed) @@ -132,8 +122,8 @@ makeDrawText :: (MonadIO m, MonadFail m, MonadError TypograffitiError m, FT_Library -> FilePath -> Int -> GlyphSize -> SampleText -> m (RichText -> n (AllocatedRendering [TextTransform])) makeDrawText lib filepath index fontsize SampleText {..} = do - font <- liftIO $ ft_New_Face lib filepath $ toEnum index - liftIO $ case fontsize of + font <- liftFreetype $ ft_New_Face lib filepath $ toEnum index + liftFreetype $ 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) @@ -148,13 +138,14 @@ makeDrawText lib filepath index fontsize SampleText {..} = do let glyphs' = map toEnum $ IS.toList $ IS.fromList $ map fromEnum glyphs let designCoords = map float2fixed $ HB.fontVarCoordsDesign font' - unless (null designCoords) $ liftIO $ ft_Set_Var_Design_Coordinates font designCoords + unless (null designCoords) $ + liftFreetype $ ft_Set_Var_Design_Coordinates font designCoords atlas <- allocAtlas (glyphRetriever font) glyphs' - liftIO $ ft_Done_Face font + liftFreetype $ ft_Done_Face font drawGlyphs <- makeDrawGlyphs - return $ drawLinesWrapper tabwidth $ \RichText {..} -> + return $ freeAtlasWrapper atlas $ drawLinesWrapper tabwidth $ \RichText {..} -> drawGlyphs atlas $ shape font' defaultBuffer { HB.text = text } features where x2 = (*2) @@ -166,12 +157,12 @@ makeDrawText' a b c d = ft_With_FreeType $ \ft -> runExceptT $ makeDrawText ft a b c d -- | Internal utility for rendering multiple lines of text & expanding tabs as configured. -drawLinesWrapper :: (MonadIO m, MonadFail m) => - Int -> (RichText -> m (AllocatedRendering [TextTransform])) -> - RichText -> m (AllocatedRendering [TextTransform]) +type TextRenderer m = RichText -> m (AllocatedRendering [TextTransform]) +drawLinesWrapper :: (MonadIO m, MonadFail m) => Int -> TextRenderer m -> TextRenderer m drawLinesWrapper indent cb RichText {..} = do let features' = splitFeatures 0 features (Txt.lines text) ++ repeat [] let cb' (a, b) = cb $ RichText a b + liftIO $ print $ Txt.lines text renderers <- mapM cb' $ flip zip features' $ map processLine $ Txt.lines text let drawLine ts wsz y renderer = do arDraw renderer (move 0 y:ts) wsz @@ -204,8 +195,7 @@ drawLinesWrapper indent cb RichText {..} = do splitFeatures (offset + toEnum n) features' lines' processLine :: Text -> Text - processLine "" = " " -- enforce nonempty - processLine cs = expandTabs 0 cs + processLine = expandTabs 0 -- monospace tabshaping, good enough outside full line-layout. expandTabs n cs = case Txt.break (== '\t') cs of (tail, "") -> tail @@ -213,3 +203,12 @@ drawLinesWrapper indent cb RichText {..} = do let spaces = indent - ((fromEnum (Txt.length pre) + fromEnum n) `rem` indent) in Txt.concat [pre, Txt.replicate (toEnum spaces) " ", expandTabs (n + Txt.length pre + toEnum spaces) $ Txt.tail cs'] + +freeAtlasWrapper :: MonadIO m => Atlas -> TextRenderer m -> TextRenderer m +freeAtlasWrapper atlas cb text = do + ret <- cb text + return ret { + arRelease = do + arRelease ret + freeAtlas atlas + } -- 2.30.2