From a77f277cd76786284dfa493cad5b69967c89d09c Mon Sep 17 00:00:00 2001 From: Schell Scivally Date: Tue, 9 Oct 2018 11:40:32 -0700 Subject: [PATCH] removed MonadTextRenderingT in favor of FontStore --- app/Main.hs | 89 +++++++++++---------- package.yaml | 2 + src/Typograffiti.hs | 52 ++++++++----- src/Typograffiti/Cache.hs | 158 +++++++++++++++++++++----------------- src/Typograffiti/Store.hs | 151 ++++++++++++++++++++++++++++++++++++ 5 files changed, 315 insertions(+), 137 deletions(-) create mode 100644 src/Typograffiti/Store.hs diff --git a/app/Main.hs b/app/Main.hs index 1b29c21..a307808 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -4,16 +4,53 @@ {-# LANGUAGE ScopedTypeVariables #-} module Main where -import Control.Monad (unless) -import Control.Monad.Except (runExceptT) -import Data.Function (fix) +import Control.Monad (unless) +import Control.Monad.Except (runExceptT, MonadError) +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Function (fix) import Graphics.GL -import SDL hiding (rotate) -import System.FilePath (()) +import SDL hiding (rotate) +import System.FilePath (()) import Typograffiti +myTextStuff + :: ( MonadIO m + , MonadError TypograffitiError m + ) + => Window -> m () +myTextStuff w = do + let ttfName = "assets" "Lora-Regular.ttf" + store <- newDefaultFontStore (get $ windowSize w) + RenderedText draw size <- + getTextRendering + store + ttfName + (GlyphSizeInPixels 16 16) + $ unlines + [ "Hey there!" + , "This is a test of the emergency word system." + , "Quit at any time." + ] + liftIO $ print ("text size", size) + + fix $ \loop -> do + events <- fmap eventPayload + <$> pollEvents + + glClearColor 0 0 0 1 + glClear GL_COLOR_BUFFER_BIT + + (V2 dw dh) <- glGetDrawableSize w + glViewport 0 0 (fromIntegral dw) (fromIntegral dh) + + draw [move 20 32, rotate (pi / 4), color 1 0 1 1, alpha 0.5] + + glSwapWindow w + unless (QuitEvent `elem` events) loop + + main :: IO () main = do SDL.initializeAll @@ -28,44 +65,6 @@ main = do w <- createWindow "Typograffiti" wcfg _ <- glCreateContext w - let ttfName = "assets" "Lora-Regular.ttf" - - e <- runExceptT $ do - -- Get the atlas - atlas <- allocAtlas - ttfName - (GlyphSizeInPixels 16 16) - asciiChars - - allocWord <- makeDefaultAllocateWord (get $ windowSize w) - - (draw, _, cache) <- - loadText - allocWord - atlas - mempty - $ unlines - [ "Hey there!" - , "This is a test of the emergency word system." - , "Quit at any time." - ] - - -- Forever loop, drawing stuff - fix $ \loop -> do - - events <- fmap eventPayload - <$> pollEvents - - glClearColor 0 0 0 1 - glClear GL_COLOR_BUFFER_BIT - - (V2 dw dh) <- glGetDrawableSize w - glViewport 0 0 (fromIntegral dw) (fromIntegral dh) - - 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 () - either (fail . show) return e + runExceptT (myTextStuff w) + >>= either (fail . show) return diff --git a/package.yaml b/package.yaml index 411be9d..d452630 100644 --- a/package.yaml +++ b/package.yaml @@ -27,6 +27,8 @@ dependencies: - gl - linear - mtl +- pretty-show +- stm - template-haskell - vector diff --git a/src/Typograffiti.hs b/src/Typograffiti.hs index 2edcf08..ccd5c37 100644 --- a/src/Typograffiti.hs +++ b/src/Typograffiti.hs @@ -1,35 +1,47 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RecordWildCards #-} -- | --- Module: Gelatin.FreeType2 --- Copyright: (c) 2017 Schell Scivally +-- Module: Typograffiti +-- Copyright: (c) 2018 Schell Scivally -- License: MIT -- Maintainer: Schell Scivally -- --- This module provides easy freetype2 font rendering using gelatin's --- graphics primitives. --- +-- This module provides easy freetype2-based font rendering with a nice +-- Haskell interface. module Typograffiti - ( allocAtlas - , GlyphSize (..) - , CharSize (..) - , TypograffitiError (..) - , Atlas (..) - , WordCache (..) - , AllocatedRendering (..) - , Layout (..) - , asciiChars - , stringTris - , loadText - , unloadMissingWords - , makeDefaultAllocateWord + ( + -- * Some simple default text rendering operations + RenderedText (..) + , TextRenderingData (..) + , FontStore + , newDefaultFontStore + , getTextRendering + -- * Transforming rendered text + , TextTransform (..) + -- TODO Vector variants of the transformation helpers. + -- i.e. moveV2, scaleV2, colorV4 , move , scale , rotate , color , alpha + , Layout (..) + -- * Getting low + , allocAtlas + , loadText + , unloadMissingWords + , stringTris + , makeDefaultAllocateWord + , asciiChars + -- * Types + , GlyphSize (..) + , CharSize (..) + , Atlas (..) + , WordCache (..) + , AllocatedRendering (..) + -- * Errors + , TypograffitiError (..) ) where import Typograffiti.Atlas import Typograffiti.Cache import Typograffiti.Glyph +import Typograffiti.Store diff --git a/src/Typograffiti/Cache.hs b/src/Typograffiti/Cache.hs index 1b72d90..9dc0ad8 100644 --- a/src/Typograffiti/Cache.hs +++ b/src/Typograffiti/Cache.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -- | @@ -15,7 +16,8 @@ module Typograffiti.Cache where import Control.Monad (foldM) -import Control.Monad.Except (MonadError (..), liftEither) +import Control.Monad.Except (MonadError (..), liftEither, + runExceptT) import Control.Monad.IO.Class (MonadIO (..)) import Data.Bifunctor (first) import Data.ByteString (ByteString) @@ -43,57 +45,60 @@ class Layout t where -- takes one parameter that can be used to transform the text in various ways. -- This type is generic and can be used to take advantage of your own font -- rendering shaders. -data AllocatedRendering t m = AllocatedRendering - { arDraw :: t -> m () +data AllocatedRendering t = AllocatedRendering + { arDraw :: t -> IO () -- ^ Draw the text with some transformation in some monad. - , arRelease :: m () + , arRelease :: IO () -- ^ Release the allocated draw function in some monad. , arSize :: V2 Int -- ^ The size (in pixels) of the drawn text. } -newtype WordCache t m = WordCache - { unWordCache :: Map String (AllocatedRendering t m) } +newtype WordCache t = WordCache + { unWordCache :: Map String (AllocatedRendering t) } deriving (Semigroup, Monoid) -- | Load a string of words into the WordCache. loadWords - :: Monad m - => (Atlas -> String -> m (AllocatedRendering t m)) + :: ( MonadIO m + , MonadError TypograffitiError m + ) + => (Atlas -> String -> m (AllocatedRendering t)) -- ^ Operation used to allocate a word. -> Atlas -- ^ The character atlas that holds our letters, which is used to generate -- the word geometry. - -> WordCache t m + -> WordCache t -- ^ The atlas to load the words into. -> String -- ^ The string of words to load, with each word separated by spaces. - -> m (WordCache t m) -loadWords f atlas (WordCache cache) str = do - wm <- foldM loadWord cache (words str) - return $ WordCache wm + -> 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 = do - w <- f atlas word - return $ M.insert word w wm + | otherwise = + flip (M.insert word) wm <$> f atlas word -- | Unload any words from the cache that are not contained in the source string. unloadMissingWords - :: Monad m - => WordCache t m + :: MonadIO m + => WordCache t -- ^ The WordCache to unload words from. -> String -- ^ The source string. - -> m (WordCache t m) + -> 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 - sequence_ $ arRelease <$> missing + liftIO + $ sequence_ + $ arRelease <$> missing return $ WordCache retain @@ -107,21 +112,25 @@ unloadMissingWords (WordCache cache) str = do -- clean up operation that does nothing. It is expected that the programmer -- will call 'freeAtlas' manually when the 'Atlas' is no longer needed. loadText - :: forall m t. (Monad m, Layout t) - => (Atlas -> String -> m (AllocatedRendering t m)) + :: forall m t. + ( MonadIO m + , MonadError TypograffitiError m + , Layout t + ) + => (Atlas -> String -> m (AllocatedRendering t)) -- ^ Operation used to allocate a word. -> Atlas -- ^ The character atlas that holds our letters. - -> WordCache t m + -> WordCache t -- ^ The WordCache to load AllocatedRenderings into. -> String -- ^ The string to render. -- This string may contain newlines, which will be respected. - -> m (t -> m (), V2 Int, WordCache t m) + -> m (t -> IO (), V2 Int, WordCache t) -- ^ Returns a function for rendering the text, the size of the text and the -- new WordCache with the allocated renderings of the text. -loadText f atlas wc@(WordCache cache) str = do - wc1@(WordCache cache1) <- loadWords f atlas wc str +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 @@ -131,14 +140,14 @@ loadText f atlas wc@(WordCache cache) str = do glyphh = pixelHeight $ atlasGlyphSize atlas spaceh = round glyphh isWhiteSpace c = c == ' ' || c == '\n' || c == '\t' - renderWord :: t -> V2 Int -> String -> m () + 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 cache1 of + case M.lookup word cache of Nothing -> renderWord t v rest Just ar -> do let t1 = translate t $ fromIntegral <$> v @@ -148,7 +157,7 @@ loadText f atlas wc@(WordCache cache) str = do renderWord t pen rest rr t = renderWord t 0 str measureString :: (V2 Int, V2 Int) -> String -> (V2 Int, V2 Int) - measureString (V2 x y, V2 w h) "" = (V2 x y, V2 w h) + 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) = @@ -157,9 +166,9 @@ loadText f atlas wc@(WordCache cache) str = do 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 + 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 @@ -267,12 +276,14 @@ makeDefaultAllocateWord , MonadError TypograffitiError m , Integral i ) - => m (V2 i) + => IO (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)) + -> m (Atlas + -> String + -> IO (Either TypograffitiError (AllocatedRendering [TextTransform])) + ) makeDefaultAllocateWord getContextSize = do - -- Compile our shader program let position = 0 uv = 1 liftGL = liftEither . first TypograffitiErrorGL @@ -297,40 +308,43 @@ makeDefaultAllocateWord getContextSize = do 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 - } + runExceptT (stringTris atlas True string) >>= \case + Left err -> return $ Left err + Right geom -> do + let (ps, uvs) = UV.unzip geom + -- Buffer the geometry into our attributes + 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 + } diff --git a/src/Typograffiti/Store.hs b/src/Typograffiti/Store.hs new file mode 100644 index 0000000..0e79f51 --- /dev/null +++ b/src/Typograffiti/Store.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | +-- Module: Typograffiti.Monad +-- Copyright: (c) 2018 Schell Scivally +-- License: MIT +-- Maintainer: Schell Scivally +-- +-- 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 + + +-- | A pre-rendered bit of text, ready to display given +-- some post compilition transformations. Also contains +-- the text size. +data RenderedText t m = RenderedText + { drawRenderedText :: t -> m () + , sizeOfRenderedText :: V2 Int + } + + +data Font t = Font + { fontAtlas :: Atlas + , fontWordCache :: WordCache t + } + + +data TextRenderingData t = TextRenderingData + { textRenderingDataAllocWord :: Atlas -> String -> IO (Either TypograffitiError (AllocatedRendering t)) + -- ^ The operation used to alloc a word. + -- Generate geometry, use a shader program, set uniforms, etc. + , textRenderingDataFontMap :: Map (FilePath, GlyphSize) (Font t) + -- ^ The cached fonts. + , textRenderingDataCharSet :: Set Char + -- ^ The character set to have available in all allocated Atlas types. + } + + +-- | Stored fonts at specific sizes. +newtype FontStore t = FontStore + { unFontStore :: TMVar (TextRenderingData t)} + + +getTextRendering + :: ( MonadIO m + , MonadError TypograffitiError m + , Layout t + ) + => FontStore t + -- ^ The font store. + -> FilePath + -- ^ The path to the font to use + -- for rendering. + -> GlyphSize + -- ^ The size of the font glyphs. + -> String + -- ^ The string to render. + -> m (RenderedText t m) + -- ^ The rendered text, ready to draw to the screen. +getTextRendering store file sz str = do + let mvar = unFontStore store + s <- liftIO $ atomically $ readTMVar mvar + font <- case M.lookup (file, sz) $ textRenderingDataFontMap s of + Nothing -> allocFont store file sz + Just font -> return font + (draw, tsz, cache) <- + loadText + (\x y -> liftIO (textRenderingDataAllocWord s x y) >>= liftEither) + (fontAtlas font) + (fontWordCache font) + str + liftIO + $ atomically $ do + s1 <- takeTMVar mvar + let alterf Nothing = Just $ Font (fontAtlas font) cache + alterf (Just (Font atlas _)) = Just $ Font atlas cache + fontmap = M.alter alterf (file,sz) + $ textRenderingDataFontMap s1 + putTMVar mvar s1{ textRenderingDataFontMap = fontmap } + return RenderedText + { drawRenderedText = liftIO . draw + , sizeOfRenderedText = tsz + } + + +newDefaultFontStore + :: ( MonadIO m + , MonadError TypograffitiError m + , Integral i + ) + => IO (V2 i) + -> m (FontStore [TextTransform]) +newDefaultFontStore getDims = do + aw <- makeDefaultAllocateWord getDims + let dat = TextRenderingData + { textRenderingDataAllocWord = aw + , textRenderingDataFontMap = mempty + , textRenderingDataCharSet = S.fromList asciiChars + } + FontStore + <$> liftIO (atomically $ newTMVar dat) + + +allocFont + :: ( MonadIO m + , MonadError TypograffitiError m + , Layout t + ) + => FontStore t + -> FilePath + -> GlyphSize + -> m (Font t) +allocFont store file sz = do + let mvar = unFontStore store + s <- liftIO $ atomically $ takeTMVar mvar + atlas <- + allocAtlas + file + sz + $ S.toList + $ textRenderingDataCharSet s + let fontmap = textRenderingDataFontMap s + font = Font + { fontAtlas = atlas + , fontWordCache = mempty + } + liftIO + $ atomically + $ putTMVar mvar + $ s{ textRenderingDataFontMap = M.insert (file, sz) font fontmap } + return font -- 2.30.2