From 6b33114535991e9cf0c71bfe32a0cf85a59e1bb1 Mon Sep 17 00:00:00 2001 From: Schell Scivally Date: Sun, 30 Sep 2018 18:32:35 -0700 Subject: [PATCH] default alloc word function --- app/Main.hs | 126 ++----------------------- src/Typograffiti.hs | 6 ++ src/Typograffiti/Atlas.hs | 15 ++- src/Typograffiti/Cache.hs | 191 ++++++++++++++++++++++++++++++++++++-- src/Typograffiti/Utils.hs | 1 - 5 files changed, 205 insertions(+), 134 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index b72820a..1b29c21 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -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 () diff --git a/src/Typograffiti.hs b/src/Typograffiti.hs index 56226ae..2edcf08 100644 --- a/src/Typograffiti.hs +++ b/src/Typograffiti.hs @@ -22,6 +22,12 @@ module Typograffiti , stringTris , loadText , unloadMissingWords + , makeDefaultAllocateWord + , move + , scale + , rotate + , color + , alpha ) where import Typograffiti.Atlas diff --git a/src/Typograffiti/Atlas.hs b/src/Typograffiti/Atlas.hs index 95a27a8..c925473 100644 --- a/src/Typograffiti/Atlas.hs +++ b/src/Typograffiti/Atlas.hs @@ -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 diff --git a/src/Typograffiti/Cache.hs b/src/Typograffiti/Cache.hs index 24a49ae..1b72d90 100644 --- a/src/Typograffiti/Cache.hs +++ b/src/Typograffiti/Cache.hs @@ -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 + } diff --git a/src/Typograffiti/Utils.hs b/src/Typograffiti/Utils.hs index 6a54b55..3524ca5 100644 --- a/src/Typograffiti/Utils.hs +++ b/src/Typograffiti/Utils.hs @@ -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) -- 2.30.2