typograffiti (empty) → 0.1.0.0
raw patch · 14 files changed
+1609/−0 lines, 14 filesdep +basedep +bytestringdep +containerssetup-changed
Dependencies added: base, bytestring, containers, filepath, freetype2, gl, linear, mtl, pretty-show, sdl2, stm, template-haskell, typograffiti, vector
Files
- ChangeLog.md +3/−0
- LICENSE +30/−0
- README.md +6/−0
- Setup.hs +2/−0
- app/Main.hs +70/−0
- src/Typograffiti.hs +47/−0
- src/Typograffiti/Atlas.hs +297/−0
- src/Typograffiti/Cache.hs +350/−0
- src/Typograffiti/GL.hs +367/−0
- src/Typograffiti/Glyph.hs +54/−0
- src/Typograffiti/Store.hs +151/−0
- src/Typograffiti/Utils.hs +128/−0
- test/Spec.hs +2/−0
- typograffiti.cabal +102/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for typograffiti++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Author name here (c) 2018++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Author name here nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,6 @@+# typograffiti+Typograffiti aims to make working with text in multimedia applications easy.++## requirements+* opengl 3.x+* freetype 2.x
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Main where++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 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++ let openGL = defaultOpenGL+ { glProfile = Core Debug 3 3 }+ wcfg = defaultWindow+ { windowInitialSize = V2 640 480+ , windowOpenGL = Just openGL+ , windowResizable = True+ }++ w <- createWindow "Typograffiti" wcfg+ _ <- glCreateContext w++ runExceptT (myTextStuff w)+ >>= either (fail . show) return
+ src/Typograffiti.hs view
@@ -0,0 +1,47 @@+-- |+-- Module: Typograffiti+-- Copyright: (c) 2018 Schell Scivally+-- License: MIT+-- Maintainer: Schell Scivally <schell@takt.com>+--+-- This module provides easy freetype2-based font rendering with a nice+-- Haskell interface.+module Typograffiti+ (+ -- * 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
+ src/Typograffiti/Atlas.hs view
@@ -0,0 +1,297 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeApplications #-}+-- |+-- Module: Typograffiti.Atlas+-- Copyright: (c) 2018 Schell Scivally+-- License: MIT+-- Maintainer: Schell Scivally <schell@takt.com>+--+-- This module provides a font-character atlas to use in font rendering with+-- opengl.+--+module Typograffiti.Atlas where++import Control.Monad+import Control.Monad.Except (MonadError (..))+import Control.Monad.IO.Class+import Data.IntMap (IntMap)+import qualified Data.IntMap as IM+import Data.Vector.Unboxed (Vector)+import qualified Data.Vector.Unboxed as UV+import Foreign.Marshal.Utils (with)+import Graphics.GL.Core32+import Graphics.GL.Types+import Graphics.Rendering.FreeType.Internal.Bitmap as BM+import Graphics.Rendering.FreeType.Internal.GlyphMetrics as GM+import Linear++import Typograffiti.GL+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)+++--------------------------------------------------------------------------------+-- Atlas+--------------------------------------------------------------------------------+++data Atlas = Atlas { atlasTexture :: GLuint+ , atlasTextureSize :: V2 Int+ , atlasLibrary :: FT_Library+ , atlasFontFace :: FT_Face+ , atlasMetrics :: IntMap GlyphMetrics+ , atlasGlyphSize :: GlyphSize+ , atlasFilePath :: FilePath+ }+++emptyAtlas :: FT_Library -> FT_Face -> GLuint -> Atlas+emptyAtlas lib fce t = Atlas t 0 lib fce mempty (GlyphSizeInPixels 0 0) ""+++data AtlasMeasure = AM { amWH :: V2 Int+ , amXY :: V2 Int+ , rowHeight :: Int+ } deriving (Show, Eq)+++emptyAM :: AtlasMeasure+emptyAM = AM 0 (V2 1 1) 0+++-- | The amount of spacing between glyphs rendered into the atlas's texture.+spacing :: Int+spacing = 1+++-- | Extract the measurements of a character in the FT_Face and append it to+-- the given AtlasMeasure.+measure+ :: FT_Face+ -> Int+ -> (IntMap AtlasMeasure, AtlasMeasure)+ -> Char+ -> FreeTypeIO (IntMap AtlasMeasure, AtlasMeasure)+measure fce maxw (prev, am@AM{..}) char+ -- Skip chars that have already been measured+ | fromEnum char `IM.member` prev = return (prev, am)+ | otherwise = do+ let V2 x y = amXY+ V2 w h = amWH+ -- Load the char, replacing the glyph according to+ -- https://www.freetype.org/freetype2/docs/tutorial/step1.html+ loadChar fce (fromIntegral $ fromEnum char) ft_LOAD_RENDER+ -- Get the glyph slot+ slot <- liftIO $ peek $ glyph fce+ -- Get the bitmap+ bmp <- liftIO $ peek $ bitmap slot+ let bw = fromIntegral $ BM.width bmp+ bh = fromIntegral $ rows bmp+ gotoNextRow = (x + bw + spacing) >= maxw+ rh = if gotoNextRow then 0 else max bh rowHeight+ nx = if gotoNextRow then 0 else x + bw + spacing+ nw = max w (x + bw + spacing)+ nh = max h (y + rh + spacing)+ ny = if gotoNextRow then nh else y+ am1 = AM { amWH = V2 nw nh+ , amXY = V2 nx ny+ , rowHeight = rh+ }+ return (IM.insert (fromEnum char) am prev, am1)+++texturize :: IntMap (V2 Int) -> Atlas -> Char -> FreeTypeIO Atlas+texturize xymap atlas@Atlas{..} char+ | Just pos@(V2 x y) <- IM.lookup (fromEnum char) xymap = do+ -- Load the char+ loadChar atlasFontFace (fromIntegral $ fromEnum char) ft_LOAD_RENDER+ -- Get the slot and bitmap+ 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)+ -- Get the glyph metrics+ ftms <- liftIO $ peek $ metrics slot+ -- Add the metrics to the atlas+ let vecwh = fromIntegral <$> V2 (BM.width bmp) (rows bmp)+ canon = floor @Double @Int . (* 0.015625) . fromIntegral+ vecsz = canon <$> V2 (GM.width ftms) (GM.height ftms)+ vecxb = canon <$> V2 (horiBearingX ftms) (horiBearingY ftms)+ vecyb = canon <$> V2 (vertBearingX ftms) (vertBearingY ftms)+ vecad = canon <$> V2 (horiAdvance ftms) (vertAdvance ftms)+ mtrcs = GlyphMetrics { glyphTexBB = (pos, pos + vecwh)+ , glyphTexSize = vecwh+ , glyphSize = vecsz+ , glyphHoriBearing = vecxb+ , glyphVertBearing = vecyb+ , glyphAdvance = vecad+ }+ return atlas{ atlasMetrics = IM.insert (fromEnum char) mtrcs atlasMetrics }++ | otherwise = do+ liftIO $ putStrLn "could not find xy"+ return atlas++-- | Allocate a new 'Atlas'.+-- When creating a new 'Atlas' you must pass all the characters that you+-- might need during the life of the 'Atlas'. Character texturization only+-- happens once.+allocAtlas+ :: ( MonadIO m+ , MonadError TypograffitiError m+ )+ => FilePath+ -- ^ Path to the font file to use for this Atlas.+ -> GlyphSize+ -- ^ Size of glyphs in this Atlas.+ -> String+ -- ^ The characters to include in this 'Atlas'.+ -> m Atlas+allocAtlas fontFilePath gs str = do+ e <- liftIO $ runFreeType $ do+ fce <- newFace fontFilePath+ case gs of+ GlyphSizeInPixels w h -> setPixelSizes fce w h+ GlyphSizeByChar (CharSize w h dpix dpiy) -> setCharSize fce w h dpix dpiy++ (amMap, am) <- foldM (measure fce 512) (mempty, emptyAM) str++ let V2 w h = amWH am+ xymap :: IntMap (V2 Int)+ xymap = amXY <$> amMap++ t <- liftIO $ do+ t <- allocAndActivateTex GL_TEXTURE0+ glPixelStorei GL_UNPACK_ALIGNMENT 1+ withCString (replicate (w * h) $ toEnum 0) $+ glTexImage2D GL_TEXTURE_2D 0 GL_RED (fromIntegral w) (fromIntegral h)+ 0 GL_RED GL_UNSIGNED_BYTE . castPtr+ return t++ lib <- getLibrary+ atlas <- foldM (texturize xymap) (emptyAtlas lib fce t) str++ glGenerateMipmap GL_TEXTURE_2D+ glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_REPEAT+ glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_REPEAT+ glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR+ glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR+ glBindTexture GL_TEXTURE_2D 0+ glPixelStorei GL_UNPACK_ALIGNMENT 4+ return+ atlas{ atlasTextureSize = V2 w h+ , atlasGlyphSize = gs+ , atlasFilePath = fontFilePath+ }++ either+ (throwError . TypograffitiErrorFreetype "cannot alloc atlas")+ (return . fst)+ e+++-- | Releases all resources associated with the given 'Atlas'.+freeAtlas :: MonadIO m => Atlas -> m ()+freeAtlas a = liftIO $ do+ _ <- ft_Done_FreeType (atlasLibrary a)+ -- _ <- unloadMissingWords a ""+ with (atlasTexture a) $ \ptr -> glDeleteTextures 1 ptr+++-- | Construct the geometry needed to render the given character.+makeCharQuad+ :: ( MonadIO m+ , MonadError TypograffitiError m+ )+ => Atlas+ -- ^ The atlas that contains the metrics for the given character.+ -> Bool+ -- ^ Whether or not to use kerning.+ -> Int+ -- ^ The current "pen position".+ -> Maybe FT_UInt+ -- ^ The freetype index of the previous character, if available.+ -> Char+ -- ^ The character to generate geometry for.+ -> m (Vector (V2 Float, V2 Float), Int, Maybe FT_UInt)+ -- ^ Returns the generated geometry (position in 2-space and UV parameters),+ -- the next pen position and the freetype index of the given character, if+ -- available.+makeCharQuad Atlas{..} useKerning penx mLast char = do+ let ichar = fromEnum char+ eNdx <- withFreeType (Just atlasLibrary) $ getCharIndex atlasFontFace ichar+ let mndx = either (const Nothing) Just eNdx+ px <- case (,,) <$> mndx <*> mLast <*> Just useKerning of+ Just (ndx,lndx,True) -> do+ e <- withFreeType (Just atlasLibrary) $+ getKerning atlasFontFace lndx ndx ft_KERNING_DEFAULT+ return $ either (const penx) ((+penx) . floor . (* 0.015625) . fromIntegral . fst) e+ _ -> return $ fromIntegral penx+ case IM.lookup ichar atlasMetrics of+ Nothing -> throwError $ TypograffitiErrorNoGlyphMetricsForChar char+ Just GlyphMetrics{..} -> do+ let V2 dx dy = fromIntegral <$> glyphHoriBearing+ x = fromIntegral px + dx+ y = -dy+ V2 w h = fromIntegral <$> glyphSize+ V2 aszW aszH = fromIntegral <$> atlasTextureSize+ V2 texL texT = fromIntegral <$> fst glyphTexBB+ V2 texR texB = fromIntegral <$> snd glyphTexBB++ tl = (V2 x y , V2 (texL/aszW) (texT/aszH))+ tr = (V2 (x+w) y , V2 (texR/aszW) (texT/aszH))+ br = (V2 (x+w) (y+h), V2 (texR/aszW) (texB/aszH))+ bl = (V2 x (y+h), V2 (texL/aszW) (texB/aszH))+ let vs = UV.fromList [ tl, tr, br+ , tl, br, bl+ ]+ let V2 ax _ = glyphAdvance+ return (vs, px + ax, mndx)+++-- | A string containing all standard ASCII characters.+-- This is often passed as the 'String' parameter in 'allocAtlas'.+asciiChars :: String+asciiChars = map toEnum [32..126]+++-- | Generate the geometry of the given string.+stringTris+ :: ( MonadIO m+ , MonadError TypograffitiError m+ )+ => Atlas+ -- ^ The font atlas.+ -> Bool+ -- ^ Whether or not to use kerning.+ -> String+ -- ^ The string.+ -> m (Vector (V2 Float, V2 Float))+stringTris atlas useKerning str = do+ (vs, _, _) <- foldM gen (mempty, 0, Nothing) str+ return $ UV.concat vs+ where gen (vs, penx, mndx) c = do+ (newVs, newPenx, newMndx) <- makeCharQuad atlas useKerning penx mndx c+ return (vs ++ [newVs], newPenx, newMndx)
+ src/Typograffiti/Cache.hs view
@@ -0,0 +1,350 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# 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 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 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+++-- | 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 = AllocatedRendering+ { arDraw :: t -> IO ()+ -- ^ Draw the text with some transformation in some monad.+ , arRelease :: IO ()+ -- ^ Release the allocated draw function in some monad.+ , arSize :: V2 Int+ -- ^ The size (in pixels) of the drawn text.+ }+++newtype WordCache t = WordCache+ { unWordCache :: Map String (AllocatedRendering t) }+ deriving (Semigroup, Monoid)+++-- | Load a string of words into the WordCache.+loadWords+ :: ( 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+ -- ^ The atlas to load the words into.+ -> String+ -- ^ The string of words to load, with each word separated by spaces.+ -> 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 =+ flip (M.insert word) wm <$> f atlas word+++-- | Unload any words from the cache that are not contained in the source string.+unloadMissingWords+ :: MonadIO m+ => WordCache t+ -- ^ The WordCache to unload words from.+ -> String+ -- ^ The source string.+ -> 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+ liftIO+ $ 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.+ ( 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+ -- ^ The WordCache to load AllocatedRenderings into.+ -> String+ -- ^ The string to render.+ -- This string may contain newlines, which will be respected.+ -> 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 str = do+ wc1@(WordCache cache) <- 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 -> 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 cache 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 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) =+ 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)+++--------------------------------------------------------------------------------+-- 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+ )+ => 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+ -> IO (Either TypograffitiError (AllocatedRendering [TextTransform]))+ )+makeDefaultAllocateWord getContextSize = do+ 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+ 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+ }
+ src/Typograffiti/GL.hs view
@@ -0,0 +1,367 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+module Typograffiti.GL where++import Control.Exception (assert)+import Control.Monad (forM_, when, replicateM)+import Control.Monad.IO.Class (MonadIO (..))+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as B8+import qualified Data.Foldable as F+import qualified Data.Vector.Storable as SV+import Data.Vector.Unboxed (Unbox)+import qualified Data.Vector.Unboxed as UV+import Foreign.C.String (peekCAStringLen, withCString)+import Foreign.Marshal.Array+import Foreign.Marshal.Utils+import Foreign.Ptr+import Foreign.Storable+import GHC.TypeLits (KnownNat)+import Graphics.GL.Core32+import Graphics.GL.Types+import Linear+import Linear.V (Finite, Size, dim, toV)+++allocAndActivateTex :: MonadIO m => GLenum -> m GLuint+allocAndActivateTex u = do+ [t] <- liftIO $ allocaArray 1 $ \ptr -> do+ glGenTextures 1 ptr+ peekArray 1 ptr+ glActiveTexture u+ glBindTexture GL_TEXTURE_2D t+ return t+++clearErrors :: MonadIO m => String -> m ()+clearErrors str = do+ err' <- glGetError+ when (err' /= 0) $ do+ liftIO $ putStrLn $ unwords [str, show err']+ assert False $ return ()+++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+++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.+-- The type variable 'f' should be V0, V1, V2, V3 or V4.+bufferGeometry+ :: ( Foldable f+ , Unbox (f Float)+ , Storable (f Float)+ , Finite f+ , KnownNat (Size f)+ , MonadIO m+ )+ => GLuint+ -- ^ The attribute location.+ -> GLuint+ -- ^ The buffer identifier.+ -> UV.Vector (f Float)+ -- ^ The geometry to buffer.+ -> m ()+bufferGeometry loc buf as+ | UV.null as = return ()+ | otherwise = do+ let v = UV.head as+ asize = UV.length as * sizeOf v+ n = fromIntegral $ dim $ toV v+ glBindBuffer GL_ARRAY_BUFFER buf+ 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+ clearErrors "bufferGeometry"+++convertVec+ :: (Unbox (f Float), Foldable f) => UV.Vector (f Float) -> SV.Vector GLfloat+convertVec =+ SV.convert . UV.map realToFrac . UV.concatMap (UV.fromList . F.toList)+++-- | Binds the given textures to GL_TEXTURE0, GL_TEXTURE1, ... in ascending+-- order of the texture unit, runs the IO action and then unbinds the textures.+withBoundTextures :: MonadIO m => [GLuint] -> m a -> m a+withBoundTextures ts f = do+ liftIO $ mapM_ (uncurry bindTex) (zip ts [GL_TEXTURE0 ..])+ a <- f+ liftIO $ glBindTexture GL_TEXTURE_2D 0+ return a+ where bindTex tex u = glActiveTexture u >> glBindTexture GL_TEXTURE_2D tex+++drawVAO+ :: MonadIO m+ => GLuint+ -- ^ The program+ -> GLuint+ -- ^ The vao+ -> GLenum+ -- ^ The draw mode+ -> GLsizei+ -- ^ The number of vertices to draw+ -> m ()+drawVAO program vao mode num = liftIO $ do+ glUseProgram program+ glBindVertexArray vao+ clearErrors "drawBuffer:glBindVertex"+ glDrawArrays mode 0 num+ clearErrors "drawBuffer:glDrawArrays"+++compileOGLShader+ :: MonadIO m+ => ByteString+ -- ^ The shader source+ -> GLenum+ -- ^ The shader type (vertex, frag, etc)+ -> 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 return $ Left "Could not create shader"+ else do+ success <- liftIO $ do+ withCString (B8.unpack src) $ \ptr ->+ with ptr $ \ptrptr -> glShaderSource shader 1 ptrptr nullPtr++ glCompileShader shader+ with (0 :: GLint) $ \ptr -> do+ glGetShaderiv shader GL_COMPILE_STATUS ptr+ peek ptr++ if success == GL_FALSE+ then do+ err <- liftIO $ do+ infoLog <- with (0 :: GLint) $ \ptr -> do+ glGetShaderiv shader GL_INFO_LOG_LENGTH ptr+ logsize <- peek ptr+ allocaArray (fromIntegral logsize) $ \logptr -> do+ glGetShaderInfoLog shader logsize nullPtr logptr+ peekArray (fromIntegral logsize) logptr++ return $ unlines [ "Could not compile shader:"+ , B8.unpack src+ , map (toEnum . fromEnum) infoLog+ ]+ return $ Left err+ else return $ Right shader+++compileOGLProgram+ :: MonadIO m+ => [(String, Integer)]+ -> [GLuint]+ -> m (Either String GLuint)+compileOGLProgram attribs shaders = do+ (program, success) <- liftIO $ do+ program <- glCreateProgram+ forM_ shaders (glAttachShader program)+ forM_ attribs+ $ \(name, loc) ->+ withCString name+ $ glBindAttribLocation program+ $ fromIntegral loc+ glLinkProgram program++ success <- with (0 :: GLint) $ \ptr -> do+ glGetProgramiv program GL_LINK_STATUS ptr+ peek ptr+ return (program, success)++ if success == GL_FALSE+ 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 $ Right program+++--------------------------------------------------------------------------------+-- Uniform marshaling functions+--------------------------------------------------------------------------------+++getUniformLocation :: MonadIO m => GLuint -> String -> m GLint+getUniformLocation program ident = liftIO+ $ withCString ident+ $ glGetUniformLocation program+++class UniformValue a where+ updateUniform+ :: MonadIO m+ => GLuint+ -- ^ The program+ -> GLint+ -- ^ The uniform location+ -> a+ -- ^ The value.+ -> m ()+++clearUniformUpdateError :: (MonadIO m, Show a) => GLuint -> GLint -> a -> m ()+clearUniformUpdateError prog loc val = glGetError >>= \case+ 0 -> return ()+ e -> do+ let buf = replicate 256 ' '+ ident <- liftIO $ withCString buf+ $ \strptr -> with 0+ $ \szptr -> do+ glGetActiveUniformName prog (fromIntegral loc) 256 szptr strptr+ sz <- peek szptr+ peekCAStringLen (strptr, fromIntegral sz)+ 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 ()+++instance UniformValue Bool where+ updateUniform p loc bool = liftIO $ do+ glUniform1i loc $ if bool then 1 else 0+ clearUniformUpdateError p loc bool++instance UniformValue Int where+ updateUniform p loc enum = liftIO $ do+ glUniform1i loc $ fromIntegral $ fromEnum enum+ clearUniformUpdateError p loc enum++instance UniformValue Float where+ updateUniform p loc float = liftIO $ do+ glUniform1f loc $ realToFrac float+ clearUniformUpdateError p loc float++instance UniformValue Double where+ updateUniform p loc d = liftIO $ do+ glUniform1f loc $ realToFrac d+ clearUniformUpdateError p loc d++instance UniformValue (V2 Float) where+ updateUniform p loc v = liftIO $ do+ let V2 x y = fmap realToFrac v+ glUniform2f loc x y+ clearUniformUpdateError p loc v++instance UniformValue (V3 Float) where+ updateUniform p loc v = liftIO $ do+ let V3 x y z = fmap realToFrac v+ glUniform3f loc x y z+ clearUniformUpdateError p loc v++instance UniformValue (V4 Float) where+ updateUniform p loc v = liftIO $ do+ let (V4 r g b a) = realToFrac <$> v+ glUniform4f loc r g b a+ clearUniformUpdateError p loc v++instance UniformValue (M44 Float) where+ updateUniform p loc val = liftIO $ do+ with val $ glUniformMatrix4fv loc 1 GL_TRUE . castPtr+ clearUniformUpdateError p loc val++instance UniformValue (V2 Int) where+ updateUniform p loc v = liftIO $ do+ let V2 x y = fmap fromIntegral v+ glUniform2i loc x y+ clearUniformUpdateError p loc v++instance UniformValue (Int,Int) where+ updateUniform p loc = updateUniform p loc . uncurry V2+++--------------------------------------------------------------------------------+-- Matrix helpers+--------------------------------------------------------------------------------+++mat4Translate :: Num a => V3 a -> M44 a+mat4Translate = mkTransformationMat identity+++mat4Rotate :: (Num a, Epsilon a, Floating a) => a -> V3 a -> M44 a+mat4Rotate phi v = mkTransformation (axisAngle v phi) (V3 0 0 0)+++mat4Scale :: Num a => V3 a -> M44 a+mat4Scale (V3 x y z) =+ V4 (V4 x 0 0 0)+ (V4 0 y 0 0)+ (V4 0 0 z 0)+ (V4 0 0 0 1)+++orthoProjection+ :: Integral a+ => V2 a+ -- ^ The window width and height+ -> M44 Float+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
+ src/Typograffiti/Glyph.hs view
@@ -0,0 +1,54 @@+module Typograffiti.Glyph where+++import Linear+++-- | The size of one freetype font character.+-- https://www.freetype.org/freetype2/docs/tutorial/step1.html#section-5+data CharSize = CharSize+ { charSizeWidth :: Int+ -- ^ Width of a character specified in 1/64 of points.+ , charSizeHeight :: Int+ -- ^ Height of a character specified in 1/64 of points.+ , charSizeWidthDPI :: Int+ -- ^ Horizontal device resolution+ , charSizeHeightDPI :: Int+ -- ^ Vertical device resolution+ } deriving (Show, Eq, Ord)+++data GlyphSize = GlyphSizeByChar CharSize+ | GlyphSizeInPixels Int Int+ deriving (Show, Eq, Ord)+++pixelWidth :: GlyphSize -> Float+pixelWidth (GlyphSizeInPixels w h)+ | 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 fromIntegral sz * fromIntegral dpi / 72+++pixelHeight :: GlyphSize -> Float+pixelHeight (GlyphSizeInPixels w 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 fromIntegral sz * fromIntegral dpi / 72+++-- | https://www.freetype.org/freetype2/docs/tutorial/step2.html+data GlyphMetrics = GlyphMetrics+ { glyphTexBB :: (V2 Int, V2 Int)+ , glyphTexSize :: V2 Int+ , glyphSize :: V2 Int+ , glyphHoriBearing :: V2 Int+ , glyphVertBearing :: V2 Int+ , glyphAdvance :: V2 Int+ } deriving (Show, Eq)
+ src/Typograffiti/Store.hs view
@@ -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
+ src/Typograffiti/Utils.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TupleSections #-}+module Typograffiti.Utils (+ module FT+ , FreeTypeT+ , FreeTypeIO+ , getAdvance+ , getCharIndex+ , getLibrary+ , getKerning+ , glyphFormatString+ , hasKerning+ , loadChar+ , loadGlyph+ , newFace+ , setCharSize+ , setPixelSizes+ , withFreeType+ , runFreeType+) where++import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Except+import Control.Monad.State.Strict+import Control.Monad (unless)+import Graphics.Rendering.FreeType.Internal as FT+import Graphics.Rendering.FreeType.Internal.PrimitiveTypes as FT+import Graphics.Rendering.FreeType.Internal.Library as FT+import Graphics.Rendering.FreeType.Internal.FaceType as FT+import Graphics.Rendering.FreeType.Internal.Face as FT hiding (generic)+import Graphics.Rendering.FreeType.Internal.GlyphSlot as FT+import Graphics.Rendering.FreeType.Internal.Bitmap as FT+import Graphics.Rendering.FreeType.Internal.Vector as FT+import Foreign as FT+import Foreign.C.String as FT++-- TODO: Tease out the correct way to handle errors.+-- They're kinda thrown all willy nilly.++type FreeTypeT m = ExceptT String (StateT FT_Library m)+type FreeTypeIO = FreeTypeT IO+++glyphFormatString :: FT_Glyph_Format -> String+glyphFormatString fmt+ | fmt == ft_GLYPH_FORMAT_COMPOSITE = "ft_GLYPH_FORMAT_COMPOSITE"+ | fmt == ft_GLYPH_FORMAT_OUTLINE = "ft_GLYPH_FORMAT_OUTLINE"+ | fmt == ft_GLYPH_FORMAT_PLOTTER = "ft_GLYPH_FORMAT_PLOTTER"+ | fmt == ft_GLYPH_FORMAT_BITMAP = "ft_GLYPH_FORMAT_BITMAP"+ | otherwise = "ft_GLYPH_FORMAT_NONE"+++liftE :: MonadIO m => String -> IO (Either FT_Error a) -> FreeTypeT m a+liftE msg f = liftIO f >>= \case+ Left e -> fail $ unwords [msg, show e]+ Right a -> return a+++runIOErr :: MonadIO m => String -> IO FT_Error -> FreeTypeT m ()+runIOErr msg f = do+ e <- liftIO f+ unless (e == 0) $ fail $ unwords [msg, show e]+++runFreeType :: MonadIO m => FreeTypeT m a -> m (Either String (a, FT_Library))+runFreeType f = do+ (e,lib) <- liftIO $ alloca $ \p -> do+ e <- ft_Init_FreeType p+ lib <- peek p+ return (e,lib)+ if e /= 0+ then do+ _ <- liftIO $ ft_Done_FreeType lib+ return $ Left $ "Error initializing FreeType2:" ++ show e+ else fmap (,lib) <$> evalStateT (runExceptT f) lib++withFreeType :: MonadIO m => Maybe FT_Library -> FreeTypeT m a -> m (Either String a)+withFreeType Nothing f = runFreeType f >>= \case+ Left e -> return $ Left e+ Right (a,lib) -> do+ _ <- liftIO $ ft_Done_FreeType lib+ return $ Right a+withFreeType (Just lib) f = evalStateT (runExceptT f) lib++getLibrary :: MonadIO m => FreeTypeT m FT_Library+getLibrary = lift get++newFace :: MonadIO m => FilePath -> FreeTypeT m FT_Face+newFace fp = do+ ft <- lift get+ liftE "ft_New_Face" $ withCString fp $ \str ->+ alloca $ \ptr -> ft_New_Face ft str 0 ptr >>= \case+ 0 -> Right <$> peek ptr+ e -> return $ Left e++setCharSize :: (MonadIO m, Integral i) => FT_Face -> i -> i -> i -> i -> FreeTypeT m ()+setCharSize ff w h dpix dpiy = runIOErr "ft_Set_Char_Size" $+ ft_Set_Char_Size ff (fromIntegral w) (fromIntegral h)+ (fromIntegral dpix) (fromIntegral dpiy)++setPixelSizes :: (MonadIO m, Integral i) => FT_Face -> i -> i -> FreeTypeT m ()+setPixelSizes ff w h =+ runIOErr "ft_Set_Pixel_Sizes" $ ft_Set_Pixel_Sizes ff (fromIntegral w) (fromIntegral h)++getCharIndex :: (MonadIO m, Integral i)+ => FT_Face -> i -> FreeTypeT m FT_UInt+getCharIndex ff ndx = liftIO $ ft_Get_Char_Index ff $ fromIntegral ndx++loadGlyph :: MonadIO m => FT_Face -> FT_UInt -> FT_Int32 -> FreeTypeT m ()+loadGlyph ff fg flags = runIOErr "ft_Load_Glyph" $ ft_Load_Glyph ff fg flags++loadChar :: MonadIO m => FT_Face -> FT_ULong -> FT_Int32 -> FreeTypeT m ()+loadChar ff char flags = runIOErr "ft_Load_Char" $ ft_Load_Char ff char flags++hasKerning :: MonadIO m => FT_Face -> FreeTypeT m Bool+hasKerning = liftIO . ft_HAS_KERNING++getKerning :: MonadIO m => FT_Face -> FT_UInt -> FT_UInt -> FT_Kerning_Mode -> FreeTypeT m (Int,Int)+getKerning ff prevNdx curNdx flags = liftE "ft_Get_Kerning" $ alloca $ \ptr ->+ ft_Get_Kerning ff prevNdx curNdx (fromIntegral flags) ptr >>= \case+ 0 -> do FT_Vector vx vy <- peek ptr+ return $ Right (fromIntegral vx, fromIntegral vy)+ e -> return $ Left e++getAdvance :: MonadIO m => FT_GlyphSlot -> FreeTypeT m (Int,Int)+getAdvance slot = do+ FT_Vector vx vy <- liftIO $ peek $ advance slot+ return (fromIntegral vx, fromIntegral vy)
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"
+ typograffiti.cabal view
@@ -0,0 +1,102 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.30.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: b6bda4deeb70ae65eaeeb1801fcc763f81f9474cdd3e74d8ab791b5e0bf4b539++name: typograffiti+version: 0.1.0.0+synopsis: Display TTF fonts in OpenGL. Includes caching for fast rendering.+description: Please see the README on GitHub at <https://github.com/githubuser/typograffiti#readme>+category: Graphics+homepage: https://github.com/schell/typograffiti#readme+bug-reports: https://github.com/schell/typograffiti/issues+author: Schell Scivally+maintainer: schell@takt.com+copyright: 2018 Schell Scivally+license: BSD3+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ ChangeLog.md++source-repository head+ type: git+ location: https://github.com/schell/typograffiti++library+ exposed-modules:+ Typograffiti+ Typograffiti.Atlas+ Typograffiti.Cache+ Typograffiti.GL+ Typograffiti.Glyph+ Typograffiti.Store+ Typograffiti.Utils+ other-modules:+ Paths_typograffiti+ hs-source-dirs:+ src+ build-depends:+ base >=4.7 && <5+ , bytestring+ , containers+ , freetype2+ , gl+ , linear+ , mtl+ , pretty-show+ , stm+ , template-haskell+ , vector+ default-language: Haskell2010++executable typograffiti-exe+ main-is: Main.hs+ other-modules:+ Paths_typograffiti+ hs-source-dirs:+ app+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4.7 && <5+ , bytestring+ , containers+ , filepath+ , freetype2+ , gl+ , linear+ , mtl+ , pretty-show+ , sdl2+ , stm+ , template-haskell+ , typograffiti+ , vector+ default-language: Haskell2010++test-suite typograffiti-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Paths_typograffiti+ hs-source-dirs:+ test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4.7 && <5+ , bytestring+ , containers+ , freetype2+ , gl+ , linear+ , mtl+ , pretty-show+ , stm+ , template-haskell+ , typograffiti+ , vector+ default-language: Haskell2010