{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
module Typograffiti.Cache where
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.Vector.Unboxed as UV
import Foreign.Marshal.Array (withArray)
import Graphics.GL
import Linear (V2 (..), V3 (..), V4 (..), M44 (..),
(!*!), identity)
import Data.Text.Glyphize (GlyphInfo(..), GlyphPos(..))
import Typograffiti.Atlas
import Typograffiti.GL
class Layout t where
translate :: t -> V2 Float -> t
data AllocatedRendering t = AllocatedRendering
{ forall t. AllocatedRendering t -> t -> V2 Int -> IO ()
arDraw :: t -> V2 Int -> IO ()
, forall t. AllocatedRendering t -> IO ()
arRelease :: IO ()
, forall t. AllocatedRendering t -> V2 Int
arSize :: V2 Int
}
makeDrawGlyphs
:: ( MonadIO m
, MonadError TypograffitiError m
, MonadIO n
, MonadFail n
, MonadError TypograffitiError n
)
=> m (Atlas
-> [(GlyphInfo, GlyphPos)]
-> n (AllocatedRendering [TextTransform])
)
makeDrawGlyphs :: forall (m :: * -> *) (n :: * -> *).
(MonadIO m, MonadError TypograffitiError m, MonadIO n, MonadFail n,
MonadError TypograffitiError n) =>
m (Atlas
-> [(GlyphInfo, GlyphPos)]
-> n (AllocatedRendering [TextTransform]))
makeDrawGlyphs = do
let position :: GLenum
position = GLenum
0
uv :: GLenum
uv = GLenum
1
GLenum
vert <- m (Either String GLenum) -> m GLenum
forall (m :: * -> *) a.
(MonadIO m, MonadError TypograffitiError m) =>
m (Either String a) -> m a
liftGL (m (Either String GLenum) -> m GLenum)
-> m (Either String GLenum) -> m GLenum
forall a b. (a -> b) -> a -> b
$ ByteString -> GLenum -> m (Either String GLenum)
forall (m :: * -> *).
MonadIO m =>
ByteString -> GLenum -> m (Either String GLenum)
compileOGLShader ByteString
vertexShader GLenum
forall {a}. (Eq a, Num a) => a
GL_VERTEX_SHADER
GLenum
frag <- m (Either String GLenum) -> m GLenum
forall (m :: * -> *) a.
(MonadIO m, MonadError TypograffitiError m) =>
m (Either String a) -> m a
liftGL (m (Either String GLenum) -> m GLenum)
-> m (Either String GLenum) -> m GLenum
forall a b. (a -> b) -> a -> b
$ ByteString -> GLenum -> m (Either String GLenum)
forall (m :: * -> *).
MonadIO m =>
ByteString -> GLenum -> m (Either String GLenum)
compileOGLShader ByteString
fragmentShader GLenum
forall {a}. (Eq a, Num a) => a
GL_FRAGMENT_SHADER
GLenum
prog <- m (Either String GLenum) -> m GLenum
forall (m :: * -> *) a.
(MonadIO m, MonadError TypograffitiError m) =>
m (Either String a) -> m a
liftGL (m (Either String GLenum) -> m GLenum)
-> m (Either String GLenum) -> m GLenum
forall a b. (a -> b) -> a -> b
$ [(String, Integer)] -> [GLenum] -> m (Either String GLenum)
forall (m :: * -> *).
MonadIO m =>
[(String, Integer)] -> [GLenum] -> m (Either String GLenum)
compileOGLProgram [
(String
"position", GLenum -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral GLenum
position),
(String
"uv", GLenum -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral GLenum
uv)
] [GLenum
vert, GLenum
frag]
GLenum -> m ()
forall (m :: * -> *). MonadIO m => GLenum -> m ()
glUseProgram GLenum
prog
GLenum -> m ()
forall (m :: * -> *). MonadIO m => GLenum -> m ()
glEnable GLenum
forall {a}. (Eq a, Num a) => a
GL_BLEND
GLenum -> GLenum -> m ()
forall (m :: * -> *). MonadIO m => GLenum -> GLenum -> m ()
glBlendFunc GLenum
forall {a}. (Eq a, Num a) => a
GL_SRC_ALPHA GLenum
forall {a}. (Eq a, Num a) => a
GL_ONE_MINUS_SRC_ALPHA
GLint
pjU <- GLenum -> String -> m GLint
forall (m :: * -> *). MonadIO m => GLenum -> String -> m GLint
getUniformLocation GLenum
prog String
"projection"
GLint
mvU <- GLenum -> String -> m GLint
forall (m :: * -> *). MonadIO m => GLenum -> String -> m GLint
getUniformLocation GLenum
prog String
"modelview"
GLint
multU <- GLenum -> String -> m GLint
forall (m :: * -> *). MonadIO m => GLenum -> String -> m GLint
getUniformLocation GLenum
prog String
"mult_color"
GLint
texU <- GLenum -> String -> m GLint
forall (m :: * -> *). MonadIO m => GLenum -> String -> m GLint
getUniformLocation GLenum
prog String
"tex"
(Atlas
-> [(GlyphInfo, GlyphPos)]
-> n (AllocatedRendering [TextTransform]))
-> m (Atlas
-> [(GlyphInfo, GlyphPos)]
-> n (AllocatedRendering [TextTransform]))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Atlas
-> [(GlyphInfo, GlyphPos)]
-> n (AllocatedRendering [TextTransform]))
-> m (Atlas
-> [(GlyphInfo, GlyphPos)]
-> n (AllocatedRendering [TextTransform])))
-> (Atlas
-> [(GlyphInfo, GlyphPos)]
-> n (AllocatedRendering [TextTransform]))
-> m (Atlas
-> [(GlyphInfo, GlyphPos)]
-> n (AllocatedRendering [TextTransform]))
forall a b. (a -> b) -> a -> b
$ \Atlas
atlas [(GlyphInfo, GlyphPos)]
glyphs -> do
GLenum
vao <- n GLenum
forall (m :: * -> *). (MonadIO m, MonadFail m) => m GLenum
newBoundVAO
GLenum
pbuf <- n GLenum
forall (m :: * -> *). MonadIO m => m GLenum
newBuffer
GLenum
uvbuf <- n GLenum
forall (m :: * -> *). MonadIO m => m GLenum
newBuffer
(Vector (V2 Float)
ps, Vector (V2 Float)
uvs) <- Vector (V2 Float, V2 Float)
-> (Vector (V2 Float), Vector (V2 Float))
forall a b.
(Unbox a, Unbox b) =>
Vector (a, b) -> (Vector a, Vector b)
UV.unzip (Vector (V2 Float, V2 Float)
-> (Vector (V2 Float), Vector (V2 Float)))
-> n (Vector (V2 Float, V2 Float))
-> n (Vector (V2 Float), Vector (V2 Float))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Atlas -> [(GlyphInfo, GlyphPos)] -> n (Vector (V2 Float, V2 Float))
forall (m :: * -> *).
(MonadIO m, MonadError TypograffitiError m) =>
Atlas -> [(GlyphInfo, GlyphPos)] -> m (Vector (V2 Float, V2 Float))
stringTris' Atlas
atlas [(GlyphInfo, GlyphPos)]
glyphs
GLenum -> GLenum -> Vector (V2 Float) -> n ()
forall (f :: * -> *) (m :: * -> *).
(Foldable f, Unbox (f Float), Storable (f Float), Finite f,
KnownNat (Size f), MonadIO m) =>
GLenum -> GLenum -> Vector (f Float) -> m ()
bufferGeometry GLenum
position GLenum
pbuf Vector (V2 Float)
ps
GLenum -> GLenum -> Vector (V2 Float) -> n ()
forall (f :: * -> *) (m :: * -> *).
(Foldable f, Unbox (f Float), Storable (f Float), Finite f,
KnownNat (Size f), MonadIO m) =>
GLenum -> GLenum -> Vector (f Float) -> m ()
bufferGeometry GLenum
uv GLenum
uvbuf Vector (V2 Float)
uvs
GLenum -> n ()
forall (m :: * -> *). MonadIO m => GLenum -> m ()
glBindVertexArray GLenum
0
let draw :: [TextTransform] -> V2 a -> m ()
draw [TextTransform]
ts V2 a
wsz = do
let (M44 Float
mv, V4 Float
multVal) = [TextTransform] -> (M44 Float, V4 Float)
transformToUniforms [TextTransform]
ts
GLenum -> m ()
forall (m :: * -> *). MonadIO m => GLenum -> m ()
glUseProgram GLenum
prog
let pj :: M44 Float
pj = V2 a -> M44 Float
forall a. Integral a => V2 a -> M44 Float
orthoProjection V2 a
wsz
GLenum -> GLint -> M44 Float -> m ()
forall a (m :: * -> *).
(UniformValue a, MonadIO m) =>
GLenum -> GLint -> a -> m ()
updateUniform GLenum
prog GLint
pjU M44 Float
pj
GLenum -> GLint -> M44 Float -> m ()
forall a (m :: * -> *).
(UniformValue a, MonadIO m) =>
GLenum -> GLint -> a -> m ()
updateUniform GLenum
prog GLint
mvU M44 Float
mv
GLenum -> GLint -> V4 Float -> m ()
forall a (m :: * -> *).
(UniformValue a, MonadIO m) =>
GLenum -> GLint -> a -> m ()
updateUniform GLenum
prog GLint
multU V4 Float
multVal
GLenum -> GLint -> Int -> m ()
forall a (m :: * -> *).
(UniformValue a, MonadIO m) =>
GLenum -> GLint -> a -> m ()
updateUniform GLenum
prog GLint
texU (Int
0 :: Int)
GLenum -> m ()
forall (m :: * -> *). MonadIO m => GLenum -> m ()
glBindVertexArray GLenum
vao
[GLenum] -> m () -> m ()
forall (m :: * -> *) a. MonadIO m => [GLenum] -> m a -> m a
withBoundTextures [Atlas -> GLenum
atlasTexture Atlas
atlas] (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
GLenum -> GLenum -> GLenum -> GLint -> m ()
forall (m :: * -> *).
MonadIO m =>
GLenum -> GLenum -> GLenum -> GLint -> m ()
drawVAO GLenum
prog GLenum
vao GLenum
forall {a}. (Eq a, Num a) => a
GL_TRIANGLES (Int -> GLint
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> GLint) -> Int -> GLint
forall a b. (a -> b) -> a -> b
$ Vector (V2 Float) -> Int
forall a. Unbox a => Vector a -> Int
UV.length Vector (V2 Float)
ps)
GLenum -> m ()
forall (m :: * -> *). MonadIO m => GLenum -> m ()
glBindVertexArray GLenum
0
release :: IO ()
release = do
[GLenum] -> (Ptr GLenum -> IO ()) -> IO ()
forall a b. Storable a => [a] -> (Ptr a -> IO b) -> IO b
withArray [GLenum
pbuf, GLenum
uvbuf] ((Ptr GLenum -> IO ()) -> IO ()) -> (Ptr GLenum -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ GLint -> Ptr GLenum -> IO ()
forall (m :: * -> *). MonadIO m => GLint -> Ptr GLenum -> m ()
glDeleteBuffers GLint
2
[GLenum] -> (Ptr GLenum -> IO ()) -> IO ()
forall a b. Storable a => [a] -> (Ptr a -> IO b) -> IO b
withArray [GLenum
vao] ((Ptr GLenum -> IO ()) -> IO ()) -> (Ptr GLenum -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ GLint -> Ptr GLenum -> IO ()
forall (m :: * -> *). MonadIO m => GLint -> Ptr GLenum -> m ()
glDeleteVertexArrays GLint
1
(V2 Float
tl, V2 Float
br) = Vector (V2 Float) -> (V2 Float, V2 Float)
forall a.
(Unbox a, Real a, Fractional a) =>
Vector (V2 a) -> (V2 a, V2 a)
boundingBox Vector (V2 Float)
ps
size :: V2 Float
size = V2 Float
br V2 Float -> V2 Float -> V2 Float
forall a. Num a => a -> a -> a
- V2 Float
tl
AllocatedRendering [TextTransform]
-> n (AllocatedRendering [TextTransform])
forall (m :: * -> *) a. Monad m => a -> m a
return AllocatedRendering :: forall t.
(t -> V2 Int -> IO ()) -> IO () -> V2 Int -> AllocatedRendering t
AllocatedRendering {
arDraw :: [TextTransform] -> V2 Int -> IO ()
arDraw = [TextTransform] -> V2 Int -> IO ()
forall {m :: * -> *} {a}.
(MonadIO m, Integral a) =>
[TextTransform] -> V2 a -> m ()
draw,
arRelease :: IO ()
arRelease = IO ()
release,
arSize :: V2 Int
arSize = Float -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (Float -> Int) -> V2 Float -> V2 Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> V2 Float
size
}
vertexShader :: ByteString
vertexShader :: ByteString
vertexShader = String -> ByteString
B8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
[ String
"#version 330 core"
, String
"uniform mat4 projection;"
, String
"uniform mat4 modelview;"
, String
"in vec2 position;"
, String
"in vec2 uv;"
, String
"out vec2 fuv;"
, String
"void main () {"
, String
" fuv = uv;"
, String
" gl_Position = projection * modelview * vec4(position.xy, 0.0, 1.0);"
, String
"}"
]
fragmentShader :: ByteString
fragmentShader :: ByteString
fragmentShader = String -> ByteString
B8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
[ String
"#version 330 core"
, String
"in vec2 fuv;"
, String
"out vec4 fcolor;"
, String
"uniform sampler2D tex;"
, String
"uniform vec4 mult_color;"
, String
"void main () {"
, String
" vec4 tcolor = texture(tex, fuv);"
, String
" fcolor = vec4(mult_color.rgb, mult_color.a * tcolor.r);"
, String
"}"
]
data SpatialTransform = SpatialTransformTranslate (V2 Float)
| SpatialTransformScale (V2 Float)
| SpatialTransformRotate Float
| SpatialTransformSkew Float
| SpatialTransform (M44 Float)
data TextTransform = TextTransformMultiply (V4 Float)
| TextTransformSpatial SpatialTransform
transformToUniforms :: [TextTransform] -> (M44 Float, V4 Float)
transformToUniforms :: [TextTransform] -> (M44 Float, V4 Float)
transformToUniforms = ((M44 Float, V4 Float) -> TextTransform -> (M44 Float, V4 Float))
-> (M44 Float, V4 Float)
-> [TextTransform]
-> (M44 Float, V4 Float)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (M44 Float, V4 Float) -> TextTransform -> (M44 Float, V4 Float)
forall {m :: * -> *}.
Functor m =>
(m (V4 Float), V4 Float)
-> TextTransform -> (m (V4 Float), V4 Float)
toUniform (M44 Float
forall a (t :: * -> *).
(Num a, Traversable t, Applicative t) =>
t (t a)
identity, V4 Float
1.0)
where toUniform :: (m (V4 Float), V4 Float)
-> TextTransform -> (m (V4 Float), V4 Float)
toUniform (m (V4 Float)
mv, V4 Float
clr) (TextTransformMultiply V4 Float
c) =
(m (V4 Float)
mv, V4 Float
clr V4 Float -> V4 Float -> V4 Float
forall a. Num a => a -> a -> a
* V4 Float
c)
toUniform (m (V4 Float)
mv, V4 Float
clr) (TextTransformSpatial SpatialTransform
s) =
let mv1 :: m (V4 Float)
mv1 = case SpatialTransform
s of
SpatialTransformTranslate (V2 Float
x Float
y) ->
m (V4 Float)
mv m (V4 Float) -> M44 Float -> m (V4 Float)
forall (m :: * -> *) (t :: * -> *) (n :: * -> *) a.
(Functor m, Foldable t, Additive t, Additive n, Num a) =>
m (t a) -> t (n a) -> m (n a)
!*! V3 Float -> M44 Float
forall a. Num a => V3 a -> M44 a
mat4Translate (Float -> Float -> Float -> V3 Float
forall a. a -> a -> a -> V3 a
V3 Float
x Float
y Float
0)
SpatialTransformScale (V2 Float
x Float
y) ->
m (V4 Float)
mv m (V4 Float) -> M44 Float -> m (V4 Float)
forall (m :: * -> *) (t :: * -> *) (n :: * -> *) a.
(Functor m, Foldable t, Additive t, Additive n, Num a) =>
m (t a) -> t (n a) -> m (n a)
!*! V3 Float -> M44 Float
forall a. Num a => V3 a -> M44 a
mat4Scale (Float -> Float -> Float -> V3 Float
forall a. a -> a -> a -> V3 a
V3 Float
x Float
y Float
1)
SpatialTransformRotate Float
r ->
m (V4 Float)
mv m (V4 Float) -> M44 Float -> m (V4 Float)
forall (m :: * -> *) (t :: * -> *) (n :: * -> *) a.
(Functor m, Foldable t, Additive t, Additive n, Num a) =>
m (t a) -> t (n a) -> m (n a)
!*! Float -> V3 Float -> M44 Float
forall a. (Num a, Epsilon a, Floating a) => a -> V3 a -> M44 a
mat4Rotate Float
r (Float -> Float -> Float -> V3 Float
forall a. a -> a -> a -> V3 a
V3 Float
0 Float
0 Float
1)
SpatialTransformSkew Float
x ->
m (V4 Float)
mv m (V4 Float) -> M44 Float -> m (V4 Float)
forall (m :: * -> *) (t :: * -> *) (n :: * -> *) a.
(Functor m, Foldable t, Additive t, Additive n, Num a) =>
m (t a) -> t (n a) -> m (n a)
!*! Float -> M44 Float
forall a. Num a => a -> M44 a
mat4SkewXbyY Float
x
SpatialTransform M44 Float
mat -> m (V4 Float)
mv m (V4 Float) -> M44 Float -> m (V4 Float)
forall (m :: * -> *) (t :: * -> *) (n :: * -> *) a.
(Functor m, Foldable t, Additive t, Additive n, Num a) =>
m (t a) -> t (n a) -> m (n a)
!*! M44 Float
mat
in (m (V4 Float)
mv1, V4 Float
clr)
move :: Float -> Float -> TextTransform
move :: Float -> Float -> TextTransform
move Float
x Float
y =
SpatialTransform -> TextTransform
TextTransformSpatial
(SpatialTransform -> TextTransform)
-> SpatialTransform -> TextTransform
forall a b. (a -> b) -> a -> b
$ V2 Float -> SpatialTransform
SpatialTransformTranslate
(V2 Float -> SpatialTransform) -> V2 Float -> SpatialTransform
forall a b. (a -> b) -> a -> b
$ Float -> Float -> V2 Float
forall a. a -> a -> V2 a
V2 Float
x Float
y
scale :: Float -> Float -> TextTransform
scale :: Float -> Float -> TextTransform
scale Float
x Float
y =
SpatialTransform -> TextTransform
TextTransformSpatial
(SpatialTransform -> TextTransform)
-> SpatialTransform -> TextTransform
forall a b. (a -> b) -> a -> b
$ V2 Float -> SpatialTransform
SpatialTransformScale
(V2 Float -> SpatialTransform) -> V2 Float -> SpatialTransform
forall a b. (a -> b) -> a -> b
$ Float -> Float -> V2 Float
forall a. a -> a -> V2 a
V2 Float
x Float
y
rotate :: Float -> TextTransform
rotate :: Float -> TextTransform
rotate =
SpatialTransform -> TextTransform
TextTransformSpatial
(SpatialTransform -> TextTransform)
-> (Float -> SpatialTransform) -> Float -> TextTransform
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> SpatialTransform
SpatialTransformRotate
skew :: Float -> TextTransform
skew :: Float -> TextTransform
skew = SpatialTransform -> TextTransform
TextTransformSpatial (SpatialTransform -> TextTransform)
-> (Float -> SpatialTransform) -> Float -> TextTransform
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> SpatialTransform
SpatialTransformSkew
matrix :: M44 Float -> TextTransform
matrix :: M44 Float -> TextTransform
matrix = SpatialTransform -> TextTransform
TextTransformSpatial (SpatialTransform -> TextTransform)
-> (M44 Float -> SpatialTransform) -> M44 Float -> TextTransform
forall b c a. (b -> c) -> (a -> b) -> a -> c
. M44 Float -> SpatialTransform
SpatialTransform
color :: Float -> Float -> Float -> Float -> TextTransform
color :: Float -> Float -> Float -> Float -> TextTransform
color Float
r Float
g Float
b Float
a =
V4 Float -> TextTransform
TextTransformMultiply
(V4 Float -> TextTransform) -> V4 Float -> TextTransform
forall a b. (a -> b) -> a -> b
$ Float -> Float -> Float -> Float -> V4 Float
forall a. a -> a -> a -> a -> V4 a
V4 Float
r Float
g Float
b Float
a
alpha :: Float -> TextTransform
alpha :: Float -> TextTransform
alpha =
V4 Float -> TextTransform
TextTransformMultiply
(V4 Float -> TextTransform)
-> (Float -> V4 Float) -> Float -> TextTransform
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Float -> Float -> Float -> V4 Float
forall a. a -> a -> a -> a -> V4 a
V4 Float
1 Float
1 Float
1
instance Layout [TextTransform] where
translate :: [TextTransform] -> V2 Float -> [TextTransform]
translate [TextTransform]
ts (V2 Float
x Float
y) = [TextTransform]
ts [TextTransform] -> [TextTransform] -> [TextTransform]
forall a. [a] -> [a] -> [a]
++ [Float -> Float -> TextTransform
move Float
x Float
y]
liftGL
:: ( MonadIO m
, MonadError TypograffitiError m
)
=> m (Either String a)
-> m a
liftGL :: forall (m :: * -> *) a.
(MonadIO m, MonadError TypograffitiError m) =>
m (Either String a) -> m a
liftGL m (Either String a)
n = do
let lft :: Either String a -> m a
lft = Either TypograffitiError a -> m a
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either TypograffitiError a -> m a)
-> (Either String a -> Either TypograffitiError a)
-> Either String a
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> TypograffitiError)
-> Either String a -> Either TypograffitiError a
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first String -> TypograffitiError
TypograffitiErrorGL
m (Either String a)
n m (Either String a) -> (Either String a -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either String a -> m a
forall {a}. Either String a -> m a
lft