From 1a43ae6f85287fda4ca442b338313c60ee176a85 Mon Sep 17 00:00:00 2001 From: Schell Scivally Date: Sun, 30 Sep 2018 14:12:11 -0700 Subject: [PATCH] word cache --- app/Main.hs | 182 ++++++++++++++++++++++---------------- src/Typograffiti.hs | 108 ++-------------------- src/Typograffiti/Atlas.hs | 70 +-------------- src/Typograffiti/Cache.hs | 165 ++++++++++++++++++++++++++++++++++ src/Typograffiti/GL.hs | 142 +++++++++++++++++------------ src/Typograffiti/Glyph.hs | 16 ++-- 6 files changed, 372 insertions(+), 311 deletions(-) create mode 100644 src/Typograffiti/Cache.hs diff --git a/app/Main.hs b/app/Main.hs index c328b52..b72820a 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,15 +1,19 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} module Main where import Control.Monad (unless) -import Control.Monad.Except (runExceptT, withExceptT) +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 Graphics.GL import SDL import System.FilePath (()) @@ -46,10 +50,78 @@ fragmentShader = B8.pack $ unlines ] --- TODO: Word caching. --- Somehow make it so it isn't bonded to one kind of --- shader. It would be nice if users could write their own --- shaders for this. At the same time, they shouldn't have to. +-- 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 () @@ -68,57 +140,26 @@ main = do _ <- glCreateContext w let ttfName = "assets" "Lora-Regular.ttf" - (either fail return =<<) . runExceptT $ do + e <- runExceptT $ do -- Get the atlas - atlas <- withExceptT show - $ allocAtlas - ttfName - (GlyphSizeInPixels 16 16) - asciiChars - -- Compile our shader program - let position = 0 - uv = 1 - vert <- compileOGLShader vertexShader GL_VERTEX_SHADER - frag <- compileOGLShader fragmentShader GL_FRAGMENT_SHADER - prog <- 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" - -- Generate our string geometry - geom <- withExceptT show - $ stringTris atlas True "Typograffiti from your head to your feetee." - let (ps, uvs) = UV.unzip geom - -- Buffer the geometry into our attributes - textVao <- withVAO $ \vao -> do - withBuffers 2 $ \[pbuf, uvbuf] -> do - bufferGeometry position pbuf ps - bufferGeometry uv uvbuf uvs - return vao - atlasVao <- withVAO $ \vao -> do - withBuffers 2 $ \[pbuf, uvbuf] -> do - let V2 w h = fromIntegral - <$> atlasTextureSize atlas - bufferGeometry position pbuf $ UV.fromList - [ V2 0 0, V2 w 0, V2 w h - , V2 0 0, V2 w h, V2 0 h - ] - bufferGeometry uv uvbuf $ UV.fromList - [ V2 0 0, V2 1 0, V2 1 1 - , V2 0 0, V2 1 1, V2 0 1 - ] - return vao - - -- Set our model view transform - let mv :: M44 Float - mv = mat4Translate (V3 0 16 0) - mv2 :: M44 Float - mv2 = mv !*! mat4Translate (V3 0 16 0) + atlas <- allocAtlas + ttfName + (GlyphSizeInPixels 16 16) + asciiChars + + allocWord <- makeAllocateWord 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 @@ -128,28 +169,13 @@ main = do glClearColor 0 0 0 1 glClear GL_COLOR_BUFFER_BIT - dsz@(V2 dw dh) <- glGetDrawableSize w + (V2 dw dh) <- glGetDrawableSize w glViewport 0 0 (fromIntegral dw) (fromIntegral dh) - wsz <- get (windowSize w) - let pj :: M44 Float = orthoProjection wsz - - withBoundTextures [atlasTexture atlas] $ do - updateUniform prog projection pj - updateUniform prog modelview mv - updateUniform prog tex (0 :: Int) - drawVAO - prog - textVao - GL_TRIANGLES - (fromIntegral $ UV.length ps) - - updateUniform prog projection pj - updateUniform prog modelview mv2 - drawVAO - prog - atlasVao - GL_TRIANGLES - 6 + draw $ V2 10 32 glSwapWindow w - unless (any (== QuitEvent) events) loop + + unless (QuitEvent `elem` events) loop + _ <- unloadMissingWords cache "" + return () + either (fail . show) return e diff --git a/src/Typograffiti.hs b/src/Typograffiti.hs index 1c0c0bf..56226ae 100644 --- a/src/Typograffiti.hs +++ b/src/Typograffiti.hs @@ -15,111 +15,15 @@ module Typograffiti , CharSize (..) , TypograffitiError (..) , Atlas (..) + , WordCache (..) + , AllocatedRendering (..) + , Layout (..) , asciiChars , stringTris + , loadText + , unloadMissingWords ) where import Typograffiti.Atlas +import Typograffiti.Cache import Typograffiti.Glyph - - --------------------------------------------------------------------------------- --- WordMap --------------------------------------------------------------------------------- - - --------------------------------------------------------------------------------- --- Picture --------------------------------------------------------------------------------- --- | Constructs a 'TexturePictureT' of one word in all red. --- V4ization can then be done using 'setReplacementV4' in the picture --- computation, or by using 'redChannelReplacement' and passing that to the --- renderer after compilation, at render time. Keep in mind that any new word --- geometry will be discarded, since this computation does not return a new 'Atlas'. --- For that reason it is advised that you load the needed words before using this --- function. For loading words, see 'loadWords'. --- --- This is used in 'freetypeFontRendering' to construct the geometry of each word. --- 'freetypeFontRendering' goes further and stores these geometries, looking them up --- and constructing a string of word renderers for each input 'String'. ---freetypePicture --- :: MonadIO m --- => Atlas --- -- ^ The 'Atlas' from which to read font textures word geometry. --- -> String --- -- ^ The word to render. --- -> m FontRendering --- -- ^ Returns a textured picture computation representing the texture and --- -- geometry of the input word. ---freetypePicture atlas@Atlas{..} str = do --- eKerning <- withFreeType (Just atlasLibrary) $ hasKerning atlasFontFace --- setTextures [atlasTexture] --- let useKerning = either (const False) id eKerning --- setGeometry $ triangles $ stringTris atlas useKerning str --------------------------------------------------------------------------------- --- Performance FontRendering --------------------------------------------------------------------------------- --- | Constructs a 'FontRendering' from the given color and string. The 'WordMap' --- record of the given 'Atlas' is used to construct the string geometry, greatly --- improving performance and allowing longer strings to be compiled and renderered --- in real time. To create a new 'Atlas' see 'allocAtlas'. --- --- Note that since word geometries are stored in the 'Atlas' 'WordMap' and multiple --- renderers can reference the same 'Atlas', the returned 'FontRendering' contains a --- clean up operation that does nothing. It is expected that the programmer --- will call 'freeAtlas' manually when the 'Atlas' is no longer needed. ---freetypeFontRendering --- :: MonadIO m --- => SomeProgram --- -- ^ The V2(backend, to) use for compilation. --- -> Atlas --- -- ^ The 'Atlas' to read character textures from and load word geometry --- -- into. --- -> V4 Float --- -- ^ The solid color to render the string with. --- -> String --- -- ^ The string to render. --- -- This string can contain newlines, which will be respected. --- -> m (FontRendering, V2 Float, Atlas) --- -- ^ Returns the 'FontRendering', the size of the text and the new --- -- 'Atlas' with the loaded geometry of the string. ---freetypeFontRendering b atlas0 color str = do --- atlas <- loadWords b atlas0 str --- let glyphw = glyphWidth $ atlasGlyphSize atlas --- spacew = fromMaybe glyphw $ do --- metrcs <- IM.lookup (fromEnum ' ') $ atlasMetrics atlas --- let (x, _) = glyphAdvance metrcs --- return $ fromIntegral x --- glyphh = glyphHeight $ atlasGlyphSize atlas --- spaceh = glyphh --- isWhiteSpace c = c == ' ' || c == '\n' || c == '\t' --- renderWord :: [FontTransform] -> V2 Float -> String -> IO () --- renderWord _ _ "" = return () --- renderWord rs (V2 _ y) ('\n':cs) = renderWord rs (V2 0 (y + spaceh)) cs --- renderWord rs (V2 x y) (' ':cs) = renderWord rs (V2 (x + spacew) y) cs --- renderWord rs (V2 x y) cs = do --- let word = takeWhile (not . isWhiteSpace) cs --- rest = drop (length word) cs --- case M.lookup word (atlasWordMap atlas) of --- Nothing -> renderWord rs (V2 x y) rest --- Just (V2 w _, r) -> do --- let ts = [move x y, redChannelReplacementV4 color] --- snd r $ ts ++ rs --- renderWord rs (V2 (x + w) y) rest --- rr t = renderWord t 0 str --- measureString :: (V2 Float, V2 Float) -> String -> (V2 Float, V2 Float) --- measureString (V2 x y, V2 w h) "" = (V2 x y, V2 w h) --- 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) = --- let ny = y + spaceh in measureString (V2 x ny, V2 w (max h ny)) cs --- measureString (V2 x y, V2 w h) cs = --- let word = takeWhile (not . isWhiteSpace) cs --- rest = drop (length word) cs --- n = case M.lookup word (atlasWordMap atlas) of --- Nothing -> (V2 x y, V2 w h) --- Just (V2 ww _, _) -> let nx = x + ww --- in (V2 nx y, V2 (max w nx) y) --- in measureString n rest --- (szw, szh) = snd $ measureString (0,0) str --- return ((return (), rr), V2 szw (max spaceh szh), atlas) diff --git a/src/Typograffiti/Atlas.hs b/src/Typograffiti/Atlas.hs index be2db1e..95a27a8 100644 --- a/src/Typograffiti/Atlas.hs +++ b/src/Typograffiti/Atlas.hs @@ -7,7 +7,7 @@ -- License: MIT -- Maintainer: Schell Scivally -- --- This module provides easy freetype2 font rendering without having to mess with +-- This module provides a font-character atlas to use in font rendering with -- opengl. -- module Typograffiti.Atlas where @@ -15,11 +15,8 @@ module Typograffiti.Atlas where import Control.Monad import Control.Monad.Except (MonadError (..)) import Control.Monad.IO.Class -import Data.Bifunctor (bimap) import Data.IntMap (IntMap) import qualified Data.IntMap as IM -import Data.Map (Map) -import qualified Data.Map as M import Data.Vector.Unboxed (Vector) import qualified Data.Vector.Unboxed as UV import Foreign.Marshal.Utils (with) @@ -34,36 +31,18 @@ import Typograffiti.Glyph import Typograffiti.Utils + data TypograffitiError = TypograffitiErrorNoGlyphMetricsForChar Char -- ^ The are no glyph metrics for this character. This probably means -- the character has not been loaded into the atlas. | TypograffitiErrorFreetype String String -- ^ There was a problem while interacting with the freetype2 library. + | TypograffitiErrorGL String + -- ^ There was a problem while interacting with OpenGL. deriving (Show, Eq) -data SpatialTransform = SpatialTransformTranslate (V2 Float) - | SpatialTransformScale (V2 Float) - | SpatialTransformRotate Float - - -data FontTransform = FontTransformAlpha Float - | FontTransformMultiply (V4 Float) - | FontTransformReplaceRed (V4 Float) - | FontTransformSpatial SpatialTransform - - -data FontRendering = FontRendering - { fontRenderingDraw :: [FontTransform] -> IO () - , fontRenderingRelease :: IO () - , fontRenderingSize :: V2 Int - } - - -type WordMap = Map String (V2 Float, FontRendering) - - -------------------------------------------------------------------------------- -- Atlas -------------------------------------------------------------------------------- @@ -236,47 +215,6 @@ freeAtlas a = liftIO $ do with (atlasTexture a) $ \ptr -> glDeleteTextures 1 ptr --- | Load a string of words into the 'Atlas'. ---loadWords --- :: MonadIO m --- => _program --- -- ^ The V2(backend, needed) to render font glyphs. --- -> Atlas --- -- ^ The atlas to load the words into. --- -> String --- -- ^ The string of words to load, with each word separated by spaces. --- -> m Atlas ---loadWords b atlas str = do --- wm <- liftIO $ foldM loadWord (atlasWordMap atlas) $ words str --- return atlas{atlasWordMap=wm} --- where loadWord wm word --- | M.member word wm = return wm --- | otherwise = do --- let pic = do freetypePicture atlas word --- _pictureSize2 fst --- (sz,r) <- _compilePictureT b pic --- return $ M.insert word (sz,r) wm - - --- | Unload any words not contained in the source string. ---unloadMissingWords --- :: MonadIO m --- => Atlas --- -- ^ The 'Atlas' to unload words from. --- -> String --- -- ^ The source string. --- -> m Atlas ---unloadMissingWords atlas str = do --- let wm = atlasWordMap atlas --- ws = M.fromList $ zip (words str) [(0::Int)..] --- missing = M.difference wm ws --- retain = M.difference wm missing --- dealoc = liftIO . fontRenderingRelease . snd --- <$> missing --- sequence_ dealoc --- return atlas{atlasWordMap=retain} - - -- | Construct the geometry needed to render the given character. makeCharQuad :: ( MonadIO m diff --git a/src/Typograffiti/Cache.hs b/src/Typograffiti/Cache.hs new file mode 100644 index 0000000..24a49ae --- /dev/null +++ b/src/Typograffiti/Cache.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | +-- Module: Typograffiti.Cache +-- Copyright: (c) 2018 Schell Scivally +-- License: MIT +-- Maintainer: Schell Scivally +-- +-- This module provides a method of caching rendererd text, making it suitable +-- for interactive rendering. You can use the defaultCache or provide your own. +-- +module Typograffiti.Cache where + +import Control.Monad (foldM) +import qualified Data.IntMap as IM +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (fromMaybe) +import Linear + +import Typograffiti.Atlas +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 + translate :: t -> V2 Float -> t + + +-- | Holds an allocated draw function for some amount of text. The function +-- 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 () + -- ^ Draw the text with some transformation in some monad. + , arRelease :: m () + -- ^ 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) } + deriving (Semigroup, Monoid) + + +-- | Load a string of words into the WordCache. +loadWords + :: Monad m + => (Atlas -> String -> m (AllocatedRendering t m)) + -- ^ 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 + -- ^ 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 + where loadWord wm word + | M.member word wm = return wm + | otherwise = do + w <- f atlas word + return $ M.insert word w wm + + +-- | Unload any words from the cache that are not contained in the source string. +unloadMissingWords + :: Monad m + => WordCache t m + -- ^ The WordCache to unload words from. + -> String + -- ^ The source string. + -> m (WordCache t m) +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 + return $ WordCache retain + + +-- | Constructs a 'Renderer2' from the given color and string. The 'WordMap' +-- record of the given 'Atlas' is used to construct the string geometry, greatly +-- improving performance and allowing longer strings to be compiled and renderered +-- in real time. To create a new 'Atlas' see 'allocAtlas'. +-- +-- Note that since word geometries are stored in the 'Atlas' 'WordMap' and multiple +-- renderers can reference the same 'Atlas', the returned 'Renderer2' contains a +-- 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)) + -- ^ Operation used to allocate a word. + -> Atlas + -- ^ The character atlas that holds our letters. + -> WordCache t m + -- ^ 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) + -- ^ 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 + let glyphw = round $ pixelWidth $ atlasGlyphSize atlas + spacew :: Int + spacew = fromMaybe glyphw $ do + metrcs <- IM.lookup (fromEnum ' ') $ atlasMetrics atlas + let V2 x _ = glyphAdvance metrcs + return x + glyphh = pixelHeight $ atlasGlyphSize atlas + spaceh = round glyphh + isWhiteSpace c = c == ' ' || c == '\n' || c == '\t' + renderWord :: t -> V2 Int -> String -> m () + 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 + Nothing -> renderWord t v rest + Just ar -> do + let t1 = translate t $ fromIntegral <$> v + V2 w _ = arSize ar + pen = V2 (x + fromIntegral w) y + arDraw ar t1 + 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 (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) = + let ny = y + spaceh in measureString (V2 x ny, V2 w (max h ny)) cs + measureString (V2 x y, V2 w h) cs = + 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 + in (V2 nx y, V2 (max w nx) y) + in measureString n rest + V2 szw szh = snd $ measureString (0,0) str + return (rr, V2 szw (max spaceh szh), wc1) diff --git a/src/Typograffiti/GL.hs b/src/Typograffiti/GL.hs index fc26fa4..65086fd 100644 --- a/src/Typograffiti/GL.hs +++ b/src/Typograffiti/GL.hs @@ -4,8 +4,7 @@ module Typograffiti.GL where import Control.Exception (assert) -import Control.Monad (forM_, when) -import Control.Monad.Except (MonadError (..)) +import Control.Monad (forM_, when, replicateM) import Control.Monad.IO.Class (MonadIO (..)) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B8 @@ -25,43 +24,56 @@ import Linear import Linear.V (Finite, Size, dim, toV) - -allocAndActivateTex :: GLenum -> IO GLuint +allocAndActivateTex :: MonadIO m => GLenum -> m GLuint allocAndActivateTex u = do - [t] <- allocaArray 1 $ \ptr -> do - glGenTextures 1 ptr - peekArray 1 ptr - glActiveTexture u - glBindTexture GL_TEXTURE_2D t - return t + [t] <- liftIO $ allocaArray 1 $ \ptr -> do + glGenTextures 1 ptr + peekArray 1 ptr + glActiveTexture u + glBindTexture GL_TEXTURE_2D t + return t -clearErrors :: String -> IO () +clearErrors :: MonadIO m => String -> m () clearErrors str = do - err' <- glGetError - when (err' /= 0) $ do - putStrLn $ unwords [str, show err'] - assert False $ return () + err' <- glGetError + when (err' /= 0) $ do + liftIO $ putStrLn $ unwords [str, show err'] + assert False $ return () -withVAO :: MonadIO m => (GLuint -> IO b) -> m b -withVAO f = liftIO $ do - [vao] <- allocaArray 1 $ \ptr -> do +newBoundVAO + :: MonadIO m => m GLuint +newBoundVAO = do + [vao] <- liftIO $ allocaArray 1 $ \ptr -> do glGenVertexArrays 1 ptr peekArray 1 ptr glBindVertexArray vao + return vao + + + +withVAO :: MonadIO m => (GLuint -> IO b) -> m b +withVAO f = liftIO $ do + vao <- newBoundVAO r <- f vao clearErrors "withVAO" glBindVertexArray 0 return r -withBuffers :: Int -> ([GLuint] -> IO b) -> IO b -withBuffers n f = do - bufs <- allocaArray n $ \ptr -> do - glGenBuffers (fromIntegral n) ptr - peekArray (fromIntegral n) ptr - f bufs +newBuffer + :: MonadIO m + => m GLuint +newBuffer = liftIO $ do + [b] <- allocaArray 1 $ \ptr -> do + glGenBuffers 1 ptr + peekArray 1 ptr + return b + + +withBuffers :: MonadIO m => Int -> ([GLuint] -> m b) -> m b +withBuffers n = (replicateM n newBuffer >>=) -- | Buffer some geometry into an attribute. @@ -72,6 +84,7 @@ bufferGeometry , Storable (f Float) , Finite f , KnownNat (Size f) + , MonadIO m ) => GLuint -- ^ The attribute location. @@ -79,7 +92,7 @@ bufferGeometry -- ^ The buffer identifier. -> UV.Vector (f Float) -- ^ The geometry to buffer. - -> IO () + -> m () bufferGeometry loc buf as | UV.null as = return () | otherwise = do @@ -87,7 +100,7 @@ bufferGeometry loc buf as asize = UV.length as * sizeOf v n = fromIntegral $ dim $ toV v glBindBuffer GL_ARRAY_BUFFER buf - SV.unsafeWith (convertVec as) $ \ptr -> + liftIO $ SV.unsafeWith (convertVec as) $ \ptr -> glBufferData GL_ARRAY_BUFFER (fromIntegral asize) (castPtr ptr) GL_STATIC_DRAW glEnableVertexAttribArray loc glVertexAttribPointer loc n GL_FLOAT GL_FALSE 0 nullPtr @@ -131,17 +144,17 @@ drawVAO program vao mode num = liftIO $ do compileOGLShader - :: (MonadIO m, MonadError String m) + :: MonadIO m => ByteString -- ^ The shader source -> GLenum -- ^ The shader type (vertex, frag, etc) - -> m GLuint + -> m (Either String GLuint) -- ^ Either an error message or the generated shader handle. compileOGLShader src shType = do shader <- liftIO $ glCreateShader shType if shader == 0 - then throwError "Could not create shader" + then return $ Left "Could not create shader" else do success <- liftIO $ do withCString (B8.unpack src) $ \ptr -> @@ -166,17 +179,15 @@ compileOGLShader src shType = do , B8.unpack src , map (toEnum . fromEnum) infoLog ] - throwError err - else return shader + return $ Left err + else return $ Right shader compileOGLProgram - :: ( MonadIO m - , MonadError String m - ) + :: MonadIO m => [(String, Integer)] -> [GLuint] - -> m GLuint + -> m (Either String GLuint) compileOGLProgram attribs shaders = do (program, success) <- liftIO $ do program <- glCreateProgram @@ -194,20 +205,21 @@ compileOGLProgram attribs shaders = do return (program, success) if success == GL_FALSE - then do - err <- liftIO $ with (0 :: GLint) $ \ptr -> do - glGetProgramiv program GL_INFO_LOG_LENGTH ptr - logsize <- peek ptr - infoLog <- allocaArray (fromIntegral logsize) $ \logptr -> do - glGetProgramInfoLog program logsize nullPtr logptr - peekArray (fromIntegral logsize) logptr - return $ unlines [ "Could not link program" - , map (toEnum . fromEnum) infoLog - ] - throwError err + then liftIO $ with (0 :: GLint) $ \ptr -> do + glGetProgramiv program GL_INFO_LOG_LENGTH ptr + logsize <- peek ptr + infoLog <- allocaArray (fromIntegral logsize) $ \logptr -> do + glGetProgramInfoLog program logsize nullPtr logptr + peekArray (fromIntegral logsize) logptr + return + $ Left + $ unlines + [ "Could not link program" + , map (toEnum . fromEnum) infoLog + ] else do liftIO $ forM_ shaders glDeleteShader - return program + return $ Right program -------------------------------------------------------------------------------- @@ -233,25 +245,28 @@ class UniformValue a where -> m () -clearUniformUpdateError :: Show a => GLuint -> GLint -> a -> IO () +clearUniformUpdateError :: (MonadIO m, Show a) => GLuint -> GLint -> a -> m () clearUniformUpdateError prog loc val = glGetError >>= \case 0 -> return () e -> do let buf = replicate 256 ' ' - ident <- withCString buf + ident <- liftIO $ withCString buf $ \strptr -> with 0 $ \szptr -> do glGetActiveUniformName prog (fromIntegral loc) 256 szptr strptr sz <- peek szptr peekCAStringLen (strptr, fromIntegral sz) - putStrLn $ unwords [ "Could not update uniform" - , ident - , "with value" - , show val - , ", encountered error (" ++ show e ++ ")" - , show (GL_INVALID_OPERATION :: Integer, "invalid operation" :: String) - , show (GL_INVALID_VALUE :: Integer, "invalid value" :: String) - ] + liftIO + $ putStrLn + $ unwords + [ "Could not update uniform" + , ident + , "with value" + , show val + , ", encountered error (" ++ show e ++ ")" + , show (GL_INVALID_OPERATION :: Integer, "invalid operation" :: String) + , show (GL_INVALID_VALUE :: Integer, "invalid value" :: String) + ] assert False $ return () @@ -337,3 +352,16 @@ orthoProjection orthoProjection (V2 ww wh) = let (hw,hh) = (fromIntegral ww, fromIntegral wh) in ortho 0 hw hh 0 0 1 + + +boundingBox :: (Unbox a, Real a, Fractional a) => UV.Vector (V2 a) -> (V2 a, V2 a) +boundingBox vs + | UV.null vs = (0,0) + | otherwise = UV.foldl' f (br,tl) vs + where mn a = min a . realToFrac + mx a = max a . realToFrac + f (a, b) c = (mn <$> a <*> c, mx <$> b <*> c) + inf = 1/0 + ninf = (-1)/0 + tl = V2 ninf ninf + br = V2 inf inf diff --git a/src/Typograffiti/Glyph.hs b/src/Typograffiti/Glyph.hs index e73a579..1d46750 100644 --- a/src/Typograffiti/Glyph.hs +++ b/src/Typograffiti/Glyph.hs @@ -23,24 +23,24 @@ data GlyphSize = GlyphSizeByChar CharSize deriving (Show, Eq, Ord) -pixelWidth :: GlyphSize -> Int +pixelWidth :: GlyphSize -> Float pixelWidth (GlyphSizeInPixels w h) - | w == 0 = h - | otherwise = w + | w == 0 = fromIntegral h + | otherwise = fromIntegral w pixelWidth (GlyphSizeByChar (CharSize w h xdpi ydpi)) = let dpi = if xdpi == 0 then ydpi else xdpi sz = if w == 0 then h else w - in round $ fromIntegral sz * fromIntegral dpi / 72 + in fromIntegral sz * fromIntegral dpi / 72 -pixelHeight :: GlyphSize -> Int +pixelHeight :: GlyphSize -> Float pixelHeight (GlyphSizeInPixels w h) - | h == 0 = w - | otherwise = h + | h == 0 = fromIntegral w + | otherwise = fromIntegral h pixelHeight (GlyphSizeByChar (CharSize w h xdpi ydpi)) = let dpi = if ydpi == 0 then xdpi else ydpi sz = if h == 0 then w else h - in round $ fromIntegral sz * fromIntegral dpi / 72 + in fromIntegral sz * fromIntegral dpi / 72 -- | https://www.freetype.org/freetype2/docs/tutorial/step2.html -- 2.30.2