D src/Graphics/Text/Font/Render.hs => src/Graphics/Text/Font/Render.hs +0 -625
@@ 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
M src/Typograffiti.hs => src/Typograffiti.hs +1 -1
@@ 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,
M src/Typograffiti/Atlas.hs => src/Typograffiti/Atlas.hs +30 -27
@@ 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
M src/Typograffiti/Cache.hs => src/Typograffiti/Cache.hs +17 -13
@@ 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 =
M src/Typograffiti/GL.hs => src/Typograffiti/GL.hs +7 -1
@@ 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
M src/Typograffiti/Store.hs => src/Typograffiti/Store.hs +16 -13
@@ 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
M src/Typograffiti/Text.hs => src/Typograffiti/Text.hs +24 -25
@@ 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
+ }