M app/Main.hs => app/Main.hs +104 -78
@@ 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
M src/Typograffiti.hs => src/Typograffiti.hs +6 -102
@@ 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)
M src/Typograffiti/Atlas.hs => src/Typograffiti/Atlas.hs +4 -66
@@ 7,7 7,7 @@
-- License: MIT
-- Maintainer: Schell Scivally <schell@takt.com>
--
--- 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
A src/Typograffiti/Cache.hs => src/Typograffiti/Cache.hs +165 -0
@@ 0,0 1,165 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+-- |
+-- Module: Typograffiti.Cache
+-- Copyright: (c) 2018 Schell Scivally
+-- License: MIT
+-- Maintainer: Schell Scivally <schell@takt.com>
+--
+-- 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)
M src/Typograffiti/GL.hs => src/Typograffiti/GL.hs +85 -57
@@ 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
M src/Typograffiti/Glyph.hs => src/Typograffiti/Glyph.hs +8 -8
@@ 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