M src/Typograffiti/Atlas.hs => src/Typograffiti/Atlas.hs +180 -0
@@ 0,0 1,180 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeApplications #-}
+-- |
+-- Module: Typograffiti.Atlas
+-- Copyright: (c) 2018 Schell Scivally
+-- License: MIT
+-- Maintainer: Schell Scivally <schell@takt.com>
+--
+-- 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
M src/Typograffiti/Cache.hs => src/Typograffiti/Cache.hs +194 -0
@@ 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 <schell@takt.com>
+--
+-- 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
D src/Typograffiti/Glyph.hs => src/Typograffiti/Glyph.hs +0 -0
M src/Typograffiti/Store.hs => src/Typograffiti/Store.hs +111 -0
@@ 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 <schell@takt.com>
+--
+-- 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.