M app/Main.hs => app/Main.hs +44 -45
@@ 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
M package.yaml => package.yaml +2 -0
@@ 27,6 27,8 @@ dependencies:
- gl
- linear
- mtl
+- pretty-show
+- stm
- template-haskell
- vector
M src/Typograffiti.hs => src/Typograffiti.hs +32 -20
@@ 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 <schell@takt.com>
--
--- 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
M src/Typograffiti/Cache.hs => src/Typograffiti/Cache.hs +86 -72
@@ 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
+ }
A src/Typograffiti/Store.hs => src/Typograffiti/Store.hs +151 -0
@@ 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 <schell@takt.com>
+--
+-- 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