{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
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
class Layout t where
translate :: t -> V2 Float -> t
data AllocatedRendering t = AllocatedRendering
{ arDraw :: t -> IO ()
, arRelease :: IO ()
, arSize :: V2 Int
}
newtype WordCache t = WordCache
{ unWordCache :: Map String (AllocatedRendering t) }
deriving (Semigroup, Monoid)
loadWords
:: ( MonadIO m
, MonadError TypograffitiError m
)
=> (Atlas -> String -> m (AllocatedRendering t))
-> Atlas
-> WordCache t
-> String
-> m (WordCache t)
loadWords f atlas (WordCache cache) str =
WordCache
<$> foldM loadWord cache (words str)
where loadWord wm word
| M.member word wm = return wm
| otherwise =
flip (M.insert word) wm <$> f atlas word
unloadMissingWords
:: MonadIO m
=> WordCache t
-> String
-> m (WordCache t)
unloadMissingWords (WordCache cache) str = do
let ws = M.fromList $ zip (words str) (repeat ())
missing = M.difference cache ws
retain = M.difference cache missing
liftIO
$ sequence_
$ arRelease <$> missing
return $ WordCache retain
loadText
:: forall m t.
( MonadIO m
, MonadError TypograffitiError m
, Layout t
)
=> (Atlas -> String -> m (AllocatedRendering t))
-> Atlas
-> WordCache t
-> String
-> m (t -> IO (), V2 Int, WordCache t)
loadText f atlas wc str = do
wc1@(WordCache cache) <- loadWords f atlas wc str
let glyphw = round $ pixelWidth $ atlasGlyphSize atlas
spacew :: Int
spacew = fromMaybe glyphw $ do
metrcs <- IM.lookup (fromEnum ' ') $ atlasMetrics atlas
let V2 x _ = glyphAdvance metrcs
return x
glyphh = pixelHeight $ atlasGlyphSize atlas
spaceh = round glyphh
isWhiteSpace c = c == ' ' || c == '\n' || c == '\t'
renderWord :: t -> V2 Int -> String -> IO ()
renderWord _ _ "" = return ()
renderWord t (V2 _ y) ('\n':cs) = renderWord t (V2 0 (y + spaceh)) cs
renderWord t (V2 x y) (' ':cs) = renderWord t (V2 (x + spacew) y) cs
renderWord t v@(V2 x y) cs = do
let word = takeWhile (not . isWhiteSpace) cs
rest = drop (length word) cs
case M.lookup word cache of
Nothing -> renderWord t v rest
Just ar -> do
let t1 = translate t $ fromIntegral <$> v
V2 w _ = arSize ar
pen = V2 (x + fromIntegral w) y
arDraw ar t1
renderWord t pen rest
rr t = renderWord t 0 str
measureString :: (V2 Int, V2 Int) -> String -> (V2 Int, V2 Int)
measureString xywh "" = xywh
measureString (V2 x y, V2 w _) (' ':cs) =
let nx = x + spacew in measureString (V2 nx y, V2 (max w nx) y) cs
measureString (V2 x y, V2 w h) ('\n':cs) =
let ny = y + spaceh in measureString (V2 x ny, V2 w (max h ny)) cs
measureString (V2 x y, V2 w h) cs =
let word = takeWhile (not . isWhiteSpace) cs
rest = drop (length word) cs
n = case M.lookup word cache of
Nothing -> (V2 x y, V2 w h)
Just ar -> let V2 ww _ = arSize ar
nx = x + ww
in (V2 nx y, V2 (max w nx) y)
in measureString n rest
V2 szw szh = snd $ measureString (0,0) str
return (rr, V2 szw (max spaceh szh), wc1)
data SpatialTransform = SpatialTransformTranslate (V2 Float)
| SpatialTransformScale (V2 Float)
| SpatialTransformRotate Float
data TextTransform = TextTransformMultiply (V4 Float)
| TextTransformSpatial SpatialTransform
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]
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)
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);"
, "}"
]
liftGL
:: ( MonadIO m
, MonadError TypograffitiError m
)
=> m (Either String a)
-> m a
liftGL n = do
let lft = liftEither . first TypograffitiErrorGL
n >>= lft
makeDefaultAllocateWord
:: ( MonadIO m
, MonadError TypograffitiError m
, Integral i
)
=> IO (V2 i)
-> m (Atlas
-> String
-> IO (Either TypograffitiError (AllocatedRendering [TextTransform]))
)
makeDefaultAllocateWord getContextSize = 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
pjU <- getUniformLocation prog "projection"
mvU <- getUniformLocation prog "modelview"
multU <- getUniformLocation prog "mult_color"
texU <- getUniformLocation prog "tex"
return $ \atlas string -> do
vao <- newBoundVAO
pbuf <- newBuffer
uvbuf <- newBuffer
runExceptT (stringTris atlas True string) >>= \case
Left err -> return $ Left err
Right geom -> do
let (ps, uvs) = UV.unzip geom
bufferGeometry position pbuf ps
bufferGeometry uv uvbuf uvs
glBindVertexArray 0
let draw :: [TextTransform] -> IO ()
draw ts = do
let (mv, multVal) = transformToUniforms ts
glUseProgram prog
wsz <- getContextSize
let pj :: M44 Float = 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 $ UV.length ps)
glBindVertexArray 0
release = do
withArray [pbuf, uvbuf] $ glDeleteBuffers 2
withArray [vao] $ glDeleteVertexArrays 1
(tl, br) = boundingBox ps
size = br - tl
return
$ Right AllocatedRendering
{ arDraw = draw
, arRelease = release
, arSize = round <$> size
}