M app/Main.hs => app/Main.hs +8 -118
@@ 4,124 4,14 @@
{-# LANGUAGE ScopedTypeVariables #-}
module Main where
-import Control.Monad (unless)
-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 Data.Function (fix)
-import qualified Data.Vector.Unboxed as UV
-import Foreign.Marshal.Array
+import Control.Monad (unless)
+import Control.Monad.Except (runExceptT)
+import Data.Function (fix)
import Graphics.GL
-import SDL
-import System.FilePath ((</>))
-import Text.Show.Pretty (pPrint)
+import SDL hiding (rotate)
+import System.FilePath ((</>))
import Typograffiti
-import Typograffiti.GL
-
-
-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;"
- , "void main () {"
- , " fcolor = texture(tex, fuv);"
- , "}"
- ]
-
-
--- TODO: Include a default Cache.
--- That allows translation, scale, rotation and color.
-
-
-instance Layout (V2 Float) where
- translate = (+)
-
-
-makeAllocateWord
- :: ( MonadIO m
- , MonadError TypograffitiError m
- )
- => Window
- -> m (Atlas -> String -> m (AllocatedRendering (V2 Float) m))
-makeAllocateWord window = do
- -- Compile our shader program
- let position = 0
- uv = 1
- liftGL = liftEither . first TypograffitiErrorGL
- 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
- -- Get our uniform locations
- projection <- getUniformLocation prog "projection"
- modelview <- getUniformLocation prog "modelview"
- tex <- getUniformLocation prog "tex"
- -- Return a function that will generate new words
- return $ \atlas string -> do
- liftIO $ putStrLn $ unwords ["Allocating", string]
- vao <- newBoundVAO
- pbuf <- newBuffer
- uvbuf <- newBuffer
- -- Generate our string geometry
- geom <- stringTris atlas True string
- let (ps, uvs) = UV.unzip geom
- -- Buffer the geometry into our attributes
- bufferGeometry position pbuf ps
- bufferGeometry uv uvbuf uvs
- glBindVertexArray 0
-
- let draw (V2 x y) = do
- liftIO $ pPrint (string, V2 x y)
- glUseProgram prog
- wsz <- get (windowSize window)
- let pj :: M44 Float = orthoProjection wsz
- mv :: M44 Float = mat4Translate (V3 x y 0)
- updateUniform prog projection pj
- updateUniform prog modelview mv
- updateUniform prog tex (0 :: Int)
- glBindVertexArray vao
- withBoundTextures [atlasTexture atlas] $ do
- drawVAO
- prog
- vao
- GL_TRIANGLES
- (fromIntegral $ UV.length ps)
- glBindVertexArray 0
- release = liftIO $ 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
- }
main :: IO ()
@@ 147,7 37,7 @@ main = do
(GlyphSizeInPixels 16 16)
asciiChars
- allocWord <- makeAllocateWord w
+ allocWord <- makeDefaultAllocateWord (get $ windowSize w)
(draw, _, cache) <-
loadText
@@ 172,9 62,9 @@ main = do
(V2 dw dh) <- glGetDrawableSize w
glViewport 0 0 (fromIntegral dw) (fromIntegral dh)
- draw $ V2 10 32
- glSwapWindow w
+ draw [move 20 32, rotate (pi / 4), color 1 0 1 1, alpha 0.5]
+ glSwapWindow w
unless (QuitEvent `elem` events) loop
_ <- unloadMissingWords cache ""
return ()
M src/Typograffiti.hs => src/Typograffiti.hs +6 -0
@@ 22,6 22,12 @@ module Typograffiti
, stringTris
, loadText
, unloadMissingWords
+ , makeDefaultAllocateWord
+ , move
+ , scale
+ , rotate
+ , color
+ , alpha
) where
import Typograffiti.Atlas
M src/Typograffiti/Atlas.hs => src/Typograffiti/Atlas.hs +10 -5
@@ 122,11 122,16 @@ texturize xymap atlas@Atlas{..} char
slot <- liftIO $ peek $ glyph atlasFontFace
bmp <- liftIO $ peek $ bitmap slot
-- Update our texture by adding the bitmap
- glTexSubImage2D GL_TEXTURE_2D 0
- (fromIntegral x) (fromIntegral y)
- (fromIntegral $ BM.width bmp) (fromIntegral $ rows bmp)
- GL_RED GL_UNSIGNED_BYTE
- (castPtr $ buffer bmp)
+ glTexSubImage2D
+ GL_TEXTURE_2D
+ 0
+ (fromIntegral x)
+ (fromIntegral y)
+ (fromIntegral $ BM.width bmp)
+ (fromIntegral $ rows bmp)
+ GL_RED
+ GL_UNSIGNED_BYTE
+ (castPtr $ buffer bmp)
-- Get the glyph metrics
ftms <- liftIO $ peek $ metrics slot
-- Add the metrics to the atlas
M src/Typograffiti/Cache.hs => src/Typograffiti/Cache.hs +181 -10
@@ 1,3 1,5 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ 13,25 15,24 @@
module Typograffiti.Cache where
import Control.Monad (foldM)
+import Control.Monad.Except (MonadError (..), liftEither)
+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 SpatialTransform = SpatialTransformTranslate (V2 Float)
--- | SpatialTransformScale (V2 Float)
--- | SpatialTransformRotate Float
---
---
---data FontTransform = FontTransformAlpha Float
--- | FontTransformMultiply (V4 Float)
--- | FontTransformReplaceRed (V4 Float)
--- | FontTransformSpatial SpatialTransform
-
-- | Generic operations for text layout.
class Layout t where
@@ 163,3 164,173 @@ loadText f atlas wc@(WordCache cache) str = do
in measureString n rest
V2 szw szh = snd $ measureString (0,0) str
return (rr, V2 szw (max spaceh szh), wc1)
+
+
+--------------------------------------------------------------------------------
+-- Default word allocation
+--------------------------------------------------------------------------------
+
+
+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);"
+ , "}"
+ ]
+
+
+makeDefaultAllocateWord
+ :: ( MonadIO m
+ , MonadError TypograffitiError m
+ , Integral i
+ )
+ => m (V2 i)
+ -- ^ A monadic operation that returns the current context's dimentions.
+ -- This is used to set the orthographic projection for rendering text.
+ -> m (Atlas -> String -> m (AllocatedRendering [TextTransform] m))
+makeDefaultAllocateWord getContextSize = do
+ -- Compile our shader program
+ let position = 0
+ uv = 1
+ liftGL = liftEither . first TypograffitiErrorGL
+ 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 our uniform locations
+ pjU <- getUniformLocation prog "projection"
+ mvU <- getUniformLocation prog "modelview"
+ multU <- getUniformLocation prog "mult_color"
+ texU <- getUniformLocation prog "tex"
+ -- Return a function that will generate new words
+ return $ \atlas string -> do
+ vao <- newBoundVAO
+ pbuf <- newBuffer
+ uvbuf <- newBuffer
+ -- Generate our string geometry
+ geom <- stringTris atlas True string
+ let (ps, uvs) = UV.unzip geom
+ -- Buffer the geometry into our attributes
+ bufferGeometry position pbuf ps
+ bufferGeometry uv uvbuf uvs
+ glBindVertexArray 0
+
+ let 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 = liftIO $ 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
+ }
M src/Typograffiti/Utils.hs => src/Typograffiti/Utils.hs +0 -1
@@ 125,5 125,4 @@ getKerning ff prevNdx curNdx flags = liftE "ft_Get_Kerning" $ alloca $ \ptr ->
getAdvance :: MonadIO m => FT_GlyphSlot -> FreeTypeT m (Int,Int)
getAdvance slot = do
FT_Vector vx vy <- liftIO $ peek $ advance slot
- liftIO $ print ("v", vx, vy)
return (fromIntegral vx, fromIntegral vy)