From c8e0b8e470f8fc4f994f2538f5f3c1bb66106a42 Mon Sep 17 00:00:00 2001 From: Schell Carl Scivally Date: Fri, 10 May 2019 13:58:55 -0700 Subject: [PATCH] More abstract (#6) * move stuff into subdirs * sdl version done * added cabal files because stack needs them, ugh * added cabal files because stack needs them, ugh * removed print statements --- .gitignore | 1 - .gitlab-ci.yml | 2 + src/Typograffiti.hs | 47 -- src/Typograffiti/Atlas.hs | 297 ------------- src/Typograffiti/Cache.hs | 362 ---------------- src/Typograffiti/Glyph.hs | 54 --- src/Typograffiti/Store.hs | 151 ------- src/Typograffiti/Utils.hs | 128 ------ stack.yaml | 7 +- test/Spec.hs | 4 +- typograffiti-core/ChangeLog.md | 3 + typograffiti-core/LICENSE | 30 ++ typograffiti-core/README.md | 1 + Setup.hs => typograffiti-core/Setup.hs | 0 typograffiti-core/app/Main.hs | 6 + typograffiti-core/package.yaml | 44 ++ typograffiti-core/src/Typograffiti.hs | 70 +++ typograffiti-core/src/Typograffiti/Atlas.hs | 67 +++ typograffiti-core/src/Typograffiti/Cache.hs | 247 +++++++++++ typograffiti-core/src/Typograffiti/Glyph.hs | 106 +++++ typograffiti-core/src/Typograffiti/Store.hs | 165 +++++++ .../src/Typograffiti/Transform.hs | 47 ++ typograffiti-core/stack.yaml | 67 +++ typograffiti-core/test/Spec.hs | 4 + typograffiti-core/typograffiti-core.cabal | 66 +++ typograffiti-freetype/ChangeLog.md | 3 + typograffiti-freetype/LICENSE | 30 ++ typograffiti-freetype/README.md | 1 + typograffiti-freetype/Setup.hs | 2 + typograffiti-freetype/package.yaml | 34 ++ .../src/Typograffiti/Freetype.hs | 405 ++++++++++++++++++ typograffiti-freetype/stack.yaml | 67 +++ typograffiti-freetype/test/Spec.hs | 2 + .../typograffiti-freetype.cabal | 44 ++ typograffiti-gl/Setup.hs | 2 + {app => typograffiti-gl/app}/Main.hs | 10 +- package.yaml => typograffiti-gl/package.yaml | 26 +- typograffiti-gl/src/Typograffiti/GL.hs | 21 + typograffiti-gl/src/Typograffiti/GL/Atlas.hs | 150 +++++++ typograffiti-gl/src/Typograffiti/GL/Cache.hs | 197 +++++++++ typograffiti-gl/src/Typograffiti/GL/Store.hs | 94 ++++ .../src/Typograffiti/GL/Transform.hs | 37 ++ .../src/Typograffiti/GL/Utils/OpenGL.hs | 18 +- typograffiti-gl/typograffiti-gl.cabal | 107 +++++ typograffiti-sdl/ChangeLog.md | 3 + typograffiti-sdl/LICENSE | 30 ++ typograffiti-sdl/README.md | 1 + typograffiti-sdl/Setup.hs | 2 + typograffiti-sdl/app/Main.hs | 119 +++++ typograffiti-sdl/package.yaml | 60 +++ typograffiti-sdl/src/Typograffiti/SDL.hs | 21 + .../src/Typograffiti/SDL/Atlas.hs | 144 +++++++ .../src/Typograffiti/SDL/Cache.hs | 172 ++++++++ .../src/Typograffiti/SDL/Store.hs | 103 +++++ .../src/Typograffiti/SDL/Transform.hs | 37 ++ typograffiti-sdl/stack.yaml | 67 +++ typograffiti-sdl/test/Spec.hs | 2 + typograffiti-sdl/typograffiti-sdl.cabal | 100 +++++ 58 files changed, 3011 insertions(+), 1076 deletions(-) delete mode 100644 src/Typograffiti.hs delete mode 100644 src/Typograffiti/Atlas.hs delete mode 100644 src/Typograffiti/Cache.hs delete mode 100644 src/Typograffiti/Glyph.hs delete mode 100644 src/Typograffiti/Store.hs delete mode 100644 src/Typograffiti/Utils.hs create mode 100644 typograffiti-core/ChangeLog.md create mode 100644 typograffiti-core/LICENSE create mode 100644 typograffiti-core/README.md rename Setup.hs => typograffiti-core/Setup.hs (100%) create mode 100644 typograffiti-core/app/Main.hs create mode 100644 typograffiti-core/package.yaml create mode 100644 typograffiti-core/src/Typograffiti.hs create mode 100644 typograffiti-core/src/Typograffiti/Atlas.hs create mode 100644 typograffiti-core/src/Typograffiti/Cache.hs create mode 100644 typograffiti-core/src/Typograffiti/Glyph.hs create mode 100644 typograffiti-core/src/Typograffiti/Store.hs create mode 100644 typograffiti-core/src/Typograffiti/Transform.hs create mode 100644 typograffiti-core/stack.yaml create mode 100644 typograffiti-core/test/Spec.hs create mode 100644 typograffiti-core/typograffiti-core.cabal create mode 100644 typograffiti-freetype/ChangeLog.md create mode 100644 typograffiti-freetype/LICENSE create mode 100644 typograffiti-freetype/README.md create mode 100644 typograffiti-freetype/Setup.hs create mode 100644 typograffiti-freetype/package.yaml create mode 100644 typograffiti-freetype/src/Typograffiti/Freetype.hs create mode 100644 typograffiti-freetype/stack.yaml create mode 100644 typograffiti-freetype/test/Spec.hs create mode 100644 typograffiti-freetype/typograffiti-freetype.cabal create mode 100644 typograffiti-gl/Setup.hs rename {app => typograffiti-gl/app}/Main.hs (88%) rename package.yaml => typograffiti-gl/package.yaml (75%) create mode 100644 typograffiti-gl/src/Typograffiti/GL.hs create mode 100644 typograffiti-gl/src/Typograffiti/GL/Atlas.hs create mode 100644 typograffiti-gl/src/Typograffiti/GL/Cache.hs create mode 100644 typograffiti-gl/src/Typograffiti/GL/Store.hs create mode 100644 typograffiti-gl/src/Typograffiti/GL/Transform.hs rename src/Typograffiti/GL.hs => typograffiti-gl/src/Typograffiti/GL/Utils/OpenGL.hs (96%) create mode 100644 typograffiti-gl/typograffiti-gl.cabal create mode 100644 typograffiti-sdl/ChangeLog.md create mode 100644 typograffiti-sdl/LICENSE create mode 100644 typograffiti-sdl/README.md create mode 100644 typograffiti-sdl/Setup.hs create mode 100644 typograffiti-sdl/app/Main.hs create mode 100644 typograffiti-sdl/package.yaml create mode 100644 typograffiti-sdl/src/Typograffiti/SDL.hs create mode 100644 typograffiti-sdl/src/Typograffiti/SDL/Atlas.hs create mode 100644 typograffiti-sdl/src/Typograffiti/SDL/Cache.hs create mode 100644 typograffiti-sdl/src/Typograffiti/SDL/Store.hs create mode 100644 typograffiti-sdl/src/Typograffiti/SDL/Transform.hs create mode 100644 typograffiti-sdl/stack.yaml create mode 100644 typograffiti-sdl/test/Spec.hs create mode 100644 typograffiti-sdl/typograffiti-sdl.cabal diff --git a/.gitignore b/.gitignore index 27b9e2e..95738f1 100644 --- a/.gitignore +++ b/.gitignore @@ -17,4 +17,3 @@ cabal.config .projectile TAGS *.#* -*.cabal diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index e74ada9..648a5ab 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -9,4 +9,6 @@ build: script: - apt-get update -y - stack setup + - stack install cabal-install - stack build + - stack haddock --haddock-deps --haddock-hyperlink-source diff --git a/src/Typograffiti.hs b/src/Typograffiti.hs deleted file mode 100644 index ccd5c37..0000000 --- a/src/Typograffiti.hs +++ /dev/null @@ -1,47 +0,0 @@ --- | --- Module: Typograffiti --- Copyright: (c) 2018 Schell Scivally --- License: MIT --- Maintainer: Schell Scivally --- --- 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 diff --git a/src/Typograffiti/Atlas.hs b/src/Typograffiti/Atlas.hs deleted file mode 100644 index c925473..0000000 --- a/src/Typograffiti/Atlas.hs +++ /dev/null @@ -1,297 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} --- | --- Module: Typograffiti.Atlas --- Copyright: (c) 2018 Schell Scivally --- License: MIT --- Maintainer: Schell Scivally --- --- 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) diff --git a/src/Typograffiti/Cache.hs b/src/Typograffiti/Cache.hs deleted file mode 100644 index 97a5244..0000000 --- a/src/Typograffiti/Cache.hs +++ /dev/null @@ -1,362 +0,0 @@ -{-# 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 --- --- 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);" - , "}" - ] - - -liftGL - :: ( MonadIO m - , MonadError TypograffitiError m - ) - => m (Either String a) - -> m a -liftGL n = do - let lft = liftEither . first TypograffitiErrorGL - n >>= lft - - --- | A default operation for allocating one word worth of geometry. This is "word" as in --- an English word, not a data type. -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 - 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 - } diff --git a/src/Typograffiti/Glyph.hs b/src/Typograffiti/Glyph.hs deleted file mode 100644 index 1d46750..0000000 --- a/src/Typograffiti/Glyph.hs +++ /dev/null @@ -1,54 +0,0 @@ -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) diff --git a/src/Typograffiti/Store.hs b/src/Typograffiti/Store.hs deleted file mode 100644 index 0e79f51..0000000 --- a/src/Typograffiti/Store.hs +++ /dev/null @@ -1,151 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} --- | --- Module: Typograffiti.Monad --- Copyright: (c) 2018 Schell Scivally --- License: MIT --- Maintainer: Schell Scivally --- --- A storage context an ops for rendering text with multiple fonts --- and sizes, hiding the details of the Atlas and WordCache. -module Typograffiti.Store where - - -import Control.Concurrent.STM (TMVar, atomically, newTMVar, putTMVar, - readTMVar, takeTMVar) -import Control.Monad.Except (MonadError (..), liftEither) -import Control.Monad.IO.Class (MonadIO (..)) -import Data.Map (Map) -import qualified Data.Map as M -import Data.Set (Set) -import qualified Data.Set as S -import Linear - - -import Typograffiti.Atlas -import Typograffiti.Cache -import Typograffiti.Glyph - - --- | A pre-rendered bit of text, ready to display given --- some post compilition transformations. Also contains --- the text size. -data RenderedText t m = RenderedText - { drawRenderedText :: t -> m () - , sizeOfRenderedText :: V2 Int - } - - -data Font t = Font - { fontAtlas :: Atlas - , fontWordCache :: WordCache t - } - - -data TextRenderingData t = TextRenderingData - { textRenderingDataAllocWord :: Atlas -> String -> IO (Either TypograffitiError (AllocatedRendering t)) - -- ^ The operation used to alloc a word. - -- Generate geometry, use a shader program, set uniforms, etc. - , textRenderingDataFontMap :: Map (FilePath, GlyphSize) (Font t) - -- ^ The cached fonts. - , textRenderingDataCharSet :: Set Char - -- ^ The character set to have available in all allocated Atlas types. - } - - --- | Stored fonts at specific sizes. -newtype FontStore t = FontStore - { unFontStore :: TMVar (TextRenderingData t)} - - -getTextRendering - :: ( MonadIO m - , MonadError TypograffitiError m - , Layout t - ) - => FontStore t - -- ^ The font store. - -> FilePath - -- ^ The path to the font to use - -- for rendering. - -> GlyphSize - -- ^ The size of the font glyphs. - -> String - -- ^ The string to render. - -> m (RenderedText t m) - -- ^ The rendered text, ready to draw to the screen. -getTextRendering store file sz str = do - let mvar = unFontStore store - s <- liftIO $ atomically $ readTMVar mvar - font <- case M.lookup (file, sz) $ textRenderingDataFontMap s of - Nothing -> allocFont store file sz - Just font -> return font - (draw, tsz, cache) <- - loadText - (\x y -> liftIO (textRenderingDataAllocWord s x y) >>= liftEither) - (fontAtlas font) - (fontWordCache font) - str - liftIO - $ atomically $ do - s1 <- takeTMVar mvar - let alterf Nothing = Just $ Font (fontAtlas font) cache - alterf (Just (Font atlas _)) = Just $ Font atlas cache - fontmap = M.alter alterf (file,sz) - $ textRenderingDataFontMap s1 - putTMVar mvar s1{ textRenderingDataFontMap = fontmap } - return RenderedText - { drawRenderedText = liftIO . draw - , sizeOfRenderedText = tsz - } - - -newDefaultFontStore - :: ( MonadIO m - , MonadError TypograffitiError m - , Integral i - ) - => IO (V2 i) - -> m (FontStore [TextTransform]) -newDefaultFontStore getDims = do - aw <- makeDefaultAllocateWord getDims - let dat = TextRenderingData - { textRenderingDataAllocWord = aw - , textRenderingDataFontMap = mempty - , textRenderingDataCharSet = S.fromList asciiChars - } - FontStore - <$> liftIO (atomically $ newTMVar dat) - - -allocFont - :: ( MonadIO m - , MonadError TypograffitiError m - , Layout t - ) - => FontStore t - -> FilePath - -> GlyphSize - -> m (Font t) -allocFont store file sz = do - let mvar = unFontStore store - s <- liftIO $ atomically $ takeTMVar mvar - atlas <- - allocAtlas - file - sz - $ S.toList - $ textRenderingDataCharSet s - let fontmap = textRenderingDataFontMap s - font = Font - { fontAtlas = atlas - , fontWordCache = mempty - } - liftIO - $ atomically - $ putTMVar mvar - $ s{ textRenderingDataFontMap = M.insert (file, sz) font fontmap } - return font diff --git a/src/Typograffiti/Utils.hs b/src/Typograffiti/Utils.hs deleted file mode 100644 index 3524ca5..0000000 --- a/src/Typograffiti/Utils.hs +++ /dev/null @@ -1,128 +0,0 @@ -{-# 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) diff --git a/stack.yaml b/stack.yaml index 6fc670a..65a84d9 100644 --- a/stack.yaml +++ b/stack.yaml @@ -19,7 +19,7 @@ # resolver: ./custom-snapshot.yaml # resolver: https://example.com/snapshots/2018-01-01.yaml #resolver: lts-12.10 -resolver: lts-13.4 +resolver: lts-13.18 # User packages to be built. # Various formats can be used as shown in the example below. @@ -35,7 +35,10 @@ resolver: lts-13.4 # - auto-update # - wai packages: -- . +- typograffiti-core +- typograffiti-freetype +- typograffiti-gl +- typograffiti-sdl # Dependency packages to be pulled from upstream that are not in the resolver # using the same syntax as the packages field. # (e.g., acme-missiles-0.3) diff --git a/test/Spec.hs b/test/Spec.hs index cd4753f..7f9bdcb 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,2 +1,4 @@ +import Test.DocTest (doctest) + main :: IO () -main = putStrLn "Test suite not yet implemented" +main = doctest ["src"] diff --git a/typograffiti-core/ChangeLog.md b/typograffiti-core/ChangeLog.md new file mode 100644 index 0000000..8d78dc6 --- /dev/null +++ b/typograffiti-core/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for typograffiti-core + +## Unreleased changes diff --git a/typograffiti-core/LICENSE b/typograffiti-core/LICENSE new file mode 100644 index 0000000..102126f --- /dev/null +++ b/typograffiti-core/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2019 + +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. diff --git a/typograffiti-core/README.md b/typograffiti-core/README.md new file mode 100644 index 0000000..b358aae --- /dev/null +++ b/typograffiti-core/README.md @@ -0,0 +1 @@ +# typograffiti-core diff --git a/Setup.hs b/typograffiti-core/Setup.hs similarity index 100% rename from Setup.hs rename to typograffiti-core/Setup.hs diff --git a/typograffiti-core/app/Main.hs b/typograffiti-core/app/Main.hs new file mode 100644 index 0000000..de1c1ab --- /dev/null +++ b/typograffiti-core/app/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import Lib + +main :: IO () +main = someFunc diff --git a/typograffiti-core/package.yaml b/typograffiti-core/package.yaml new file mode 100644 index 0000000..f8dd385 --- /dev/null +++ b/typograffiti-core/package.yaml @@ -0,0 +1,44 @@ +name: typograffiti-core +version: 0.1.0.0 +github: "githubuser/typograffiti-core" +license: BSD3 +author: "Author name here" +maintainer: "example@example.com" +copyright: "2019 Author name here" + +extra-source-files: +- README.md +- ChangeLog.md + +# Metadata used when publishing your package +# synopsis: Short description of your package +# category: Web + +# To avoid duplicated efforts in documentation and dealing with the +# complications of embedding Haddock markup inside cabal files, it is +# common to point users to the README.md file. +description: Please see the README on GitHub at + +dependencies: +- base >= 4.7 && < 5 +- containers >= 0.6 +- linear >= 1.20 +- mtl >= 2.2 +- pretty-show >= 1.9 +- stm >= 2.5 + + +library: + source-dirs: src + +tests: + typograffiti-core-test: + main: Spec.hs + source-dirs: test + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - typograffiti-core + - doctest diff --git a/typograffiti-core/src/Typograffiti.hs b/typograffiti-core/src/Typograffiti.hs new file mode 100644 index 0000000..222cca6 --- /dev/null +++ b/typograffiti-core/src/Typograffiti.hs @@ -0,0 +1,70 @@ +-- | +-- Module: Typograffiti +-- Copyright: (c) 2019 Schell Scivally +-- License: MIT +-- Maintainer: Schell Scivally +-- +-- This module provides the abstract functionality of a cached font atlas. +module Typograffiti + ( + -- * $glyphs + GlyphSize (..) + , CharSize (..) + , charGlyphAction + -- * $atlas + , Atlas (..) + , asciiChars + -- * $cache + , WordCache (..) + , AllocatedRendering (..) + , loadWords + , unloadMissingWords + -- * $store + , Store + , RenderedGlyphs (..) + , GlyphRenderingData (..) + , getRendering + -- * Transforming allocated renderings + , Transform (..) + , move + , moveV2 + , scale + , scaleV2 + , rotate + ) where + +import Typograffiti.Atlas +import Typograffiti.Cache +import Typograffiti.Glyph +import Typograffiti.Store +import Typograffiti.Transform + +-- | $glyphs + +-- | $atlas +-- Typograffiti is in plain terms a cache of caches. Its core is the `Atlas`, +-- which is a collection of rasterized glyphs. These modules don't make any +-- assumptions as to what a glyph really is, though, which means you can use +-- Typograffiti for more than just rendering text. Indeed Typograffiti is great +-- for rendering anything that can be represented by contiguous strings. For +-- example - in tile-based games we often see the same formations again and again +-- where tiles repeat a given pattern. If these patterns can be recognized and +-- broken up into contiguous, two dimensional lists, then Typograffiti can cache +-- the renderings of these patterns for you, greatly improving your rendering +-- framerate. + +-- | To keep things as general as possible this package abstracts out two +-- important concepts - rasterization and the rendering itself. Most low level +-- functions will take rasterization or rendering functions as arguments and +-- the low level types will have type variables representing the details of these +-- abstractions. + +-- | If you simply want to use Typograffiti to display TTF fonts without writing +-- your own rasterizer or rendering functions I suggest you use the +-- typograffiti-freetype package (which provides freetype glyph rasterization) +-- along with either typograffiti-sdl or typograffiti-gl (which each provide +-- rendering services). + +-- | $cache Collections of rasterized strings + +-- | $store Collections of WordCaches for each file at a certain size diff --git a/typograffiti-core/src/Typograffiti/Atlas.hs b/typograffiti-core/src/Typograffiti/Atlas.hs new file mode 100644 index 0000000..4f8f269 --- /dev/null +++ b/typograffiti-core/src/Typograffiti/Atlas.hs @@ -0,0 +1,67 @@ +-- | +-- Module: Typograffiti.Atlas +-- Copyright: (c) 2019 Schell Scivally +-- License: MIT +-- Maintainer: Schell Scivally +-- +-- This module provides a font-character atlas to use in font rendering with +-- a pluggable backend. +-- +module Typograffiti.Atlas where + +import Data.IntMap (IntMap) +import Linear + +import Typograffiti.Glyph + + +-------------------------------------------------------------------------------- +-- Atlas +-------------------------------------------------------------------------------- + + +-- | An atlas holds a texture/bitmap that contains glyphs, as well as a map of +-- those glyphs measurements. +data Atlas tex rs + = Atlas + { atlasTexture :: tex + -- ^ The rasterized glyphs themselves + , atlasResources :: rs + -- ^ Any other resources needed by the atlas + , atlasTextureSize :: V2 Int + -- ^ The size of the texture in pixels + , atlasMetrics :: IntMap GlyphMetrics + -- ^ A mapping of glyph index to its metrics + , atlasGlyphSize :: GlyphSize + -- ^ The maximum width of any glyphs in the atlas + , atlasFilePath :: FilePath + -- ^ The location this texture was loaded from + } + + +--emptyAtlas :: FT_Library -> FT_Face -> GLuint -> Atlas +--emptyAtlas lib fce t = Atlas t 0 lib fce mempty (GlyphSizeInPixels 0 0) "" + + +-- | A helper type for keeping track of rasterized glyphs. +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 + + +-- | A string containing all standard ASCII characters. +-- This is often passed as the 'String' parameter in 'allocAtlas'. +asciiChars :: String +asciiChars = map toEnum [32..126] diff --git a/typograffiti-core/src/Typograffiti/Cache.hs b/typograffiti-core/src/Typograffiti/Cache.hs new file mode 100644 index 0000000..c9448ba --- /dev/null +++ b/typograffiti-core/src/Typograffiti/Cache.hs @@ -0,0 +1,247 @@ +-- | +-- 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 fast, interactive rendering. You can use the defaultCache or provide your +-- own. +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Typograffiti.Cache where + +import Control.Monad (foldM) +import Control.Monad.Except (MonadError (..)) +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Foldable (traverse_) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (fromMaybe) +import Linear (V2 (..)) + +import Typograffiti.Atlas +import Typograffiti.Glyph + + +-------------------------------------------------------------------------------- +-- Allocating things and storing them +-------------------------------------------------------------------------------- + +-- | 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. +data AllocatedRendering tfrm tex + = AllocatedRendering + { arTextures :: [tex] + -- ^ This rendering cached as a texture. + , arDraw :: tfrm -> IO () + -- ^ Draw the text with some transformation in some monad. + , arRelease :: IO () + -- ^ Release the allocated draw function in some monad. + , arSizes :: [V2 Int] + -- ^ The size (in pixels) of the drawn text. + } + + +arFirstSizeMaybe :: AllocatedRendering tfrm tex -> Maybe (V2 Int) +arFirstSizeMaybe ar = case arSizes ar of + sz:_ -> Just sz + _ -> Nothing + + +instance Semigroup (AllocatedRendering tfrm tex) where + (<>) a b = + AllocatedRendering + { arDraw = \ts -> traverse_ (`arDraw` ts) [a, b] + , arTextures = arTextures a <> arTextures b + , arRelease = traverse_ arRelease [a, b] + , arSizes = arSizes a <> arSizes b + } + + +instance Monoid (AllocatedRendering tfrm tex) where + mempty = + AllocatedRendering + { arDraw = const $ return () + , arTextures = [] + , arRelease = return () + , arSizes = [] + } + + +-- | A map of lists of things (ie tiles, characters) to allocated renderings. +-- In the case of rasterizing fonts 'a' is a character. +-- In the case of rasterizing a spritesheet 'a' is a tile or frame. +newtype WordCache a tfrm tex + = WordCache + { unWordCache :: Map [a] (AllocatedRendering tfrm tex) } + deriving (Semigroup, Monoid) + + +-- | Load a list of "words" into the WordCache. +-- For example: +-- +-- @preloadWords allocWord atlas cache $ words "this is my string to render"@ +preloadWords + :: ( MonadIO m + , MonadError String m + , Ord a + ) + => (Atlas tex rs -> [a] -> m (AllocatedRendering tfrm tex)) + -- ^ Operation used to allocate a word. + -> Atlas tex rs + -- ^ The character atlas that holds our letters, which is used to generate + -- the word geometry. + -> WordCache a tfrm tex + -- ^ The atlas to load the words into. + -> [[a]] + -- ^ The list of words to load + -> m (WordCache a tfrm tex) +preloadWords f atlas (WordCache cache) = + fmap WordCache + . foldM loadWord cache + 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 + , Ord a + ) + => WordCache a tfrm tex + -- ^ The WordCache to unload words from. + -> [[a]] + -- ^ The source words. + -> m (WordCache a tfrm tex) +unloadMissingWords (WordCache cache) strs = do + let ws = M.fromList $ zip strs (repeat ()) + missing = M.difference cache ws + retain = M.difference cache missing + liftIO + $ sequence_ + $ arRelease <$> missing + return + $ WordCache retain + + +-- | To store all our rendering configuration data. +data RenderHelper tfrm a tex + = RenderHelper + { renderHelperTranslate :: tfrm -> V2 Float -> tfrm + , renderHelperMkAction :: a -> GlyphAction + , renderHelperCache :: WordCache a tfrm tex + , renderHelperSpace :: V2 Int + } + + +renderWord + :: Ord a + => RenderHelper tfrm a tex + -> tfrm + -> V2 Int + -> [a] + -> IO () +renderWord _ _ _ [] = return () +renderWord + helper@(RenderHelper translate mkAction cache (V2 spacew spaceh)) + t + v@(V2 x y) + gs@(c:cs) = + + case mkAction c of + GlyphActionNewline -> renderWord helper t (V2 0 (y + spaceh)) cs + GlyphActionSpace -> renderWord helper t (V2 (x + spacew) y) cs + GlyphActionRender -> do + let word = takeWhile (isRenderGlyph mkAction) gs + rest = drop (length word) gs + case M.lookup word $ unWordCache cache of + Nothing -> renderWord helper t v rest + Just ar -> do + let t1 = translate t $ fromIntegral <$> v + V2 w _ = fromMaybe 0 $ arFirstSizeMaybe ar + pen = V2 (x + fromIntegral w) y + arDraw ar t1 + renderWord helper t pen rest + + +measureString + :: Ord a + => RenderHelper tfrm a tex + -> (V2 Int, V2 Int) + -> [a] + -> (V2 Int, V2 Int) +measureString _ xywh [] = xywh +measureString + helper@(RenderHelper _ mkAction cache (V2 spacew spaceh)) + (V2 x y, V2 w h) + gs@(c:cs) = + case mkAction c of + GlyphActionSpace -> + let nx = x + spacew + in measureString helper (V2 nx y, V2 (max w nx) y) cs + GlyphActionNewline -> + let ny = y + spaceh + in measureString helper (V2 x ny, V2 w (max h ny)) cs + GlyphActionRender -> + let word = takeWhile (isRenderGlyph mkAction) gs + rest = drop (length word) gs + n = case M.lookup word $ unWordCache cache of + Nothing -> (V2 x y, V2 w h) + Just ar -> let V2 ww _ = fromMaybe 0 $ arFirstSizeMaybe ar + nx = x + ww + in (V2 nx y, V2 (max w nx) y) + in measureString helper n rest + + +-- | Load the given glyph string into the given WordCache using the given monadic +-- rendering and transform operations. +loadWords + :: forall m e a tfrm tex rs. + ( MonadIO m + , MonadError String m + , Ord a + ) + => (tfrm -> V2 Float -> tfrm) + -- ^ A pure function for translating a transform. + -> (a -> GlyphAction) + -- ^ A pure function to determine an action the renderer should take based on + -- the current glyph. For strings this should be 'charGlyphAction'. + -> (Atlas tex rs -> [a] -> m (AllocatedRendering tfrm tex)) + -- ^ Monadic operation used to allocate a word. + -> Atlas tex rs + -- ^ The character atlas that holds our letters. + -> WordCache a tfrm tex + -- ^ The WordCache to load AllocatedRenderings into. + -> [a] + -- ^ The string to render. + -- This string may contain newlines, which will be respected. + -> m (tfrm -> IO (), V2 Int, WordCache a tfrm tex) + -- ^ Returns a function for rendering the text, the size of the text and the + -- new WordCache with the allocated renderings of the text. +loadWords translate mkAction f atlas wc str = do + -- preload the words into the word cache first + wc1 <- + preloadWords + f + atlas + wc + $ breakWords mkAction str + + let spacew = round $ pixelWidth $ atlasGlyphSize atlas + glyphh = pixelHeight $ atlasGlyphSize atlas + spaceh = round glyphh + helper = + RenderHelper + translate + mkAction + wc1 + (V2 spacew spaceh) + rr t = renderWord helper t 0 str + V2 szw szh = snd $ measureString helper (0,0) str + return (rr, V2 szw (max spaceh szh), wc1) diff --git a/typograffiti-core/src/Typograffiti/Glyph.hs b/typograffiti-core/src/Typograffiti/Glyph.hs new file mode 100644 index 0000000..57bf451 --- /dev/null +++ b/typograffiti-core/src/Typograffiti/Glyph.hs @@ -0,0 +1,106 @@ +module Typograffiti.Glyph where + + +import Linear (V2) + + +-- | 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 + + +-- | Knowledge about a file's set of glyphs. +-- https://www.freetype.org/freetype2/docs/tutorial/step2.html +data GlyphMetrics + = GlyphMetrics + { glyphTexBB :: (V2 Int, V2 Int) + -- ^ The bounding box around the glyph + , glyphTexSize :: V2 Int + -- ^ The total texture size + , glyphSize :: V2 Int + -- ^ One glyph's size + , glyphHoriBearing :: V2 Int + , glyphVertBearing :: V2 Int + , glyphAdvance :: V2 Int + } deriving (Show, Eq) + + +-- | An action that should be taken by the renderer depending on the glyph. +-- This is used to represent rendering spaces and newlines in strings, since +-- those glyphs (' ' and '\n') don't have any real rendering steps and instead +-- cause the renderer to jump through 2d space. +data GlyphAction + = GlyphActionNewline + -- ^ This glyph action causes the renderer to return to its starting x and + -- drop down y by the glyph height. + | GlyphActionSpace + -- ^ This glyph action causes the renderer to jump right in x by the glyph + -- width without rendering. + | GlyphActionRender + -- ^ This glyph action causes the renderer to render the glyph and jump right + -- by the glyph's advance. + deriving (Eq) + + +-- | Determine the GlyphAction based on Char. +charGlyphAction :: Char -> GlyphAction +charGlyphAction '\n' = GlyphActionNewline +charGlyphAction ' ' = GlyphActionSpace +charGlyphAction _ = GlyphActionRender + + +isWhiteSpace :: (a -> GlyphAction) -> a -> Bool +isWhiteSpace = ((/= GlyphActionRender) .) + + +isRenderGlyph :: (a -> GlyphAction) -> a -> Bool +isRenderGlyph = ((== GlyphActionRender) .) + + +-- | Break a list of glyphs into whitespace separated lists. +-- +-- >>> breakWords charGlyphAction "this is a string" +-- ["this","is","a","string"] +breakWords :: (a -> GlyphAction) -> [a] -> [[a]] +breakWords mkAction = + uncurry (:) + . foldr accum ([], []) + where + accum c (w, ws) = + if isWhiteSpace mkAction c + then ([], w:ws) + else (c:w, ws) diff --git a/typograffiti-core/src/Typograffiti/Store.hs b/typograffiti-core/src/Typograffiti/Store.hs new file mode 100644 index 0000000..d4e8f71 --- /dev/null +++ b/typograffiti-core/src/Typograffiti/Store.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | +-- Module: Typograffiti.Monad +-- Copyright: (c) 2018 Schell Scivally +-- License: MIT +-- Maintainer: Schell Scivally +-- +-- A storage context an ops for rendering text with multiple fonts +-- and sizes, hiding the details of the Atlas and WordCache. +module Typograffiti.Store where + + +import Control.Concurrent.STM (TMVar, atomically, 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 RenderedGlyphs tfrm m + = RenderedGlyphs + { drawRenderedGlyphs :: tfrm -> m () + , sizeOfRenderedGlyphs :: V2 Int + } + + +-- | A cache of words and rasterized glyphs. +-- +-- * 'tex' is the type of the rasterized bitmap containing glyphs +-- * 'rs' is the resource type the rasterizer maintains +-- * 'tfrm' is the kind of transformation that can be applied to allocated +-- renderings +-- * 'a' is the type of the glyph +data Dictionary tex rs a tfrm + = Dictionary + { dictAtlas :: Atlas tex rs + , dictWordCache :: WordCache a tfrm tex + } + + +-- | All the data needed to render contiguous sets of glyphs quickly. +-- +-- * 'tex' is the type of the rasterized bitmap containing glyphs +-- * 'rs' is the resource type the rasterizer maintains +-- * 'tfrm' is the kind of transformation that can be applied to allocated +-- renderings +-- * 'a' is the type of the glyph +-- * 'e' is the type of extended errors that can be thrown, see TypograffitiError +data GlyphRenderingData tex rs tfrm a + = GlyphRenderingData + { glyphRenderingDataAllocWord + :: Atlas tex rs + -> [a] + -> IO (Either String (AllocatedRendering tfrm tex)) + -- ^ The operation used to alloc a word. + -- Generate geometry, use a shader program, set uniforms, etc. + , glyphRenderingDataDictMap :: Map (FilePath, GlyphSize) (Dictionary tex rs a tfrm) + -- ^ The cached fonts. + , glyphRenderingDataGlyphSet :: Set a + -- ^ The default glyph set to have available in all allocated Atlases. + } + + +-- | Stored GlyphRenderingData +newtype Store tex rs tfrm a + = Store + { unStore :: TMVar (GlyphRenderingData tex rs tfrm a) } + + +-- | Return +getRendering + :: ( MonadIO m + , MonadError String m + , Ord a + ) + => (FilePath -> GlyphSize -> [a] -> m (Atlas tex rs)) + -- ^ Monadic action to allocate a fresh Atlas. + -> (tfrm -> V2 Float -> tfrm) + -- ^ Pure function for translating a transform. + -> (a -> GlyphAction) + -- ^ Pure function for determining the action a glyph has on the renderer. + -> Store tex rs tfrm a + -- ^ The dictionary store. + -> FilePath + -- ^ The path to the font/glyph file (whatever that may be) to use for rendering. + -> GlyphSize + -- ^ The size of the glyphs. + -> [a] + -- ^ The glyphs to render. + -> m (RenderedGlyphs tfrm m) + -- ^ The rendered glyphs, ready to draw to the screen. +getRendering allocAtlas translate mkAction store file sz str = do + let mvar = unStore store + s <- liftIO $ atomically $ readTMVar mvar + dict <- case M.lookup (file, sz) $ glyphRenderingDataDictMap s of + Nothing -> allocDictionary allocAtlas store file sz + Just dict -> return dict + (draw, tsz, cache) <- + loadWords + translate + mkAction + (\x y -> liftIO (glyphRenderingDataAllocWord s x y) >>= liftEither) + (dictAtlas dict) + (dictWordCache dict) + str + liftIO + $ atomically $ do + s1 <- takeTMVar mvar + let alterf Nothing = Just $ Dictionary (dictAtlas dict) cache + alterf (Just dict1) = Just $ Dictionary (dictAtlas dict1) cache + fontmap = M.alter alterf (file, sz) + $ glyphRenderingDataDictMap s1 + putTMVar mvar s1{ glyphRenderingDataDictMap = fontmap } + return RenderedGlyphs + { drawRenderedGlyphs = liftIO . draw + , sizeOfRenderedGlyphs = tsz + } + + +allocDictionary + :: ( MonadIO m + , MonadError String m + , Ord a + ) + => (FilePath -> GlyphSize -> [a] -> m (Atlas tex rs)) + -> Store tex rs tfrm a + -> FilePath + -> GlyphSize + -> m (Dictionary tex rs a tfrm) +allocDictionary allocAtlas store file sz = do + let mvar = unStore store + s <- liftIO $ atomically $ takeTMVar mvar + atlas <- + allocAtlas + file + sz + $ S.toList + $ glyphRenderingDataGlyphSet s + let fontmap = glyphRenderingDataDictMap s + font = + Dictionary + { dictAtlas = atlas + , dictWordCache = mempty + } + liftIO + $ atomically + $ putTMVar mvar + $ s{ glyphRenderingDataDictMap = M.insert (file, sz) font fontmap } + return font diff --git a/typograffiti-core/src/Typograffiti/Transform.hs b/typograffiti-core/src/Typograffiti/Transform.hs new file mode 100644 index 0000000..ef590dd --- /dev/null +++ b/typograffiti-core/src/Typograffiti/Transform.hs @@ -0,0 +1,47 @@ +-- | Types for transforming allocated renderings. +module Typograffiti.Transform where + +import Linear (V2 (..)) + + +data Affine + = AffineTranslate (V2 Float) + | AffineScale (V2 Float) + | AffineRotate Float + + +data Transform a + = TransformAffine Affine + | Transform a + + +moveV2 :: V2 Float -> Transform a +moveV2 = + TransformAffine + . AffineTranslate + + +move :: Float -> Float -> Transform a +move x y = + TransformAffine + $ AffineTranslate + $ V2 x y + + +scaleV2 :: V2 Float -> Transform a +scaleV2 = + TransformAffine + . AffineScale + + +scale :: Float -> Float -> Transform a +scale x y = + TransformAffine + $ AffineScale + $ V2 x y + + +rotate :: Float -> Transform a +rotate = + TransformAffine + . AffineRotate diff --git a/typograffiti-core/stack.yaml b/typograffiti-core/stack.yaml new file mode 100644 index 0000000..655c575 --- /dev/null +++ b/typograffiti-core/stack.yaml @@ -0,0 +1,67 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# https://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# resolver: lts-3.5 +# resolver: nightly-2015-09-21 +# resolver: ghc-7.10.2 +# +# The location of a snapshot can be provided as a file or url. Stack assumes +# a snapshot provided as a file might change, whereas a url resource does not. +# +# resolver: ./custom-snapshot.yaml +# resolver: https://example.com/snapshots/2018-01-01.yaml +resolver: + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/13/18.yaml + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# subdirs: +# - auto-update +# - wai +packages: +- . +# Dependency packages to be pulled from upstream that are not in the resolver. +# These entries can reference officially published versions as well as +# forks / in-progress versions pinned to a git hash. For example: +# +# extra-deps: +# - acme-missiles-0.3 +# - git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# +# extra-deps: [] + +# Override default flag values for local packages and extra-deps +# flags: {} + +# Extra package databases containing global packages +# extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=1.10" +# +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor diff --git a/typograffiti-core/test/Spec.hs b/typograffiti-core/test/Spec.hs new file mode 100644 index 0000000..7f9bdcb --- /dev/null +++ b/typograffiti-core/test/Spec.hs @@ -0,0 +1,4 @@ +import Test.DocTest (doctest) + +main :: IO () +main = doctest ["src"] diff --git a/typograffiti-core/typograffiti-core.cabal b/typograffiti-core/typograffiti-core.cabal new file mode 100644 index 0000000..c98110e --- /dev/null +++ b/typograffiti-core/typograffiti-core.cabal @@ -0,0 +1,66 @@ +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: d44950f7c2f4ad96c6adddea9f1431d75f598d8034834dd16205890831bf2a30 + +name: typograffiti-core +version: 0.1.0.0 +description: Please see the README on GitHub at +homepage: https://github.com/githubuser/typograffiti-core#readme +bug-reports: https://github.com/githubuser/typograffiti-core/issues +author: Author name here +maintainer: example@example.com +copyright: 2019 Author name here +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/githubuser/typograffiti-core + +library + exposed-modules: + Typograffiti + Typograffiti.Atlas + Typograffiti.Cache + Typograffiti.Glyph + Typograffiti.Store + Typograffiti.Transform + other-modules: + Paths_typograffiti_core + hs-source-dirs: + src + build-depends: + base >=4.7 && <5 + , containers >=0.6 + , linear >=1.20 + , mtl >=2.2 + , pretty-show >=1.9 + , stm >=2.5 + default-language: Haskell2010 + +test-suite typograffiti-core-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_typograffiti_core + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5 + , containers >=0.6 + , doctest + , linear >=1.20 + , mtl >=2.2 + , pretty-show >=1.9 + , stm >=2.5 + , typograffiti-core + default-language: Haskell2010 diff --git a/typograffiti-freetype/ChangeLog.md b/typograffiti-freetype/ChangeLog.md new file mode 100644 index 0000000..55dc45a --- /dev/null +++ b/typograffiti-freetype/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for typograffiti-freetype + +## Unreleased changes diff --git a/typograffiti-freetype/LICENSE b/typograffiti-freetype/LICENSE new file mode 100644 index 0000000..102126f --- /dev/null +++ b/typograffiti-freetype/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2019 + +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. diff --git a/typograffiti-freetype/README.md b/typograffiti-freetype/README.md new file mode 100644 index 0000000..0278dba --- /dev/null +++ b/typograffiti-freetype/README.md @@ -0,0 +1 @@ +# typograffiti-freetype diff --git a/typograffiti-freetype/Setup.hs b/typograffiti-freetype/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/typograffiti-freetype/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/typograffiti-freetype/package.yaml b/typograffiti-freetype/package.yaml new file mode 100644 index 0000000..3aadd4f --- /dev/null +++ b/typograffiti-freetype/package.yaml @@ -0,0 +1,34 @@ +name: typograffiti-freetype +version: 0.1.0.0 +github: "githubuser/typograffiti-freetype" +license: BSD3 +author: "Author name here" +maintainer: "example@example.com" +copyright: "2019 Author name here" + +extra-source-files: +- README.md +- ChangeLog.md + +# Metadata used when publishing your package +# synopsis: Short description of your package +# category: Web + +# To avoid duplicated efforts in documentation and dealing with the +# complications of embedding Haddock markup inside cabal files, it is +# common to point users to the README.md file. +description: Please see the README on GitHub at + +dependencies: +- base >= 4.7 && < 5 +- containers +- freetype2 +- linear +- mtl +- typograffiti-core +- vector + +library: + source-dirs: src + ghc-options: + - -Wall diff --git a/typograffiti-freetype/src/Typograffiti/Freetype.hs b/typograffiti-freetype/src/Typograffiti/Freetype.hs new file mode 100644 index 0000000..aca709c --- /dev/null +++ b/typograffiti-freetype/src/Typograffiti/Freetype.hs @@ -0,0 +1,405 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +module Typograffiti.Freetype + ( -- * Helpers for building freetype backends + measure + , atlasLibrary + , atlasFontFace + , emptyAtlas + , makeCharQuad + , asciiChars + , stringTris + , stringQuads + , quadsBounds + , boundingBox + -- * Freetype stuff... + , module FT + , FreeTypeT + , FreeTypeIO + , FT_Glyph_Metrics + , getFreetypeChar + , getAdvance + , getCharIndex + , getLibrary + , getKerning + , glyphFormatString + , hasKerning + , loadChar + , loadGlyph + , newFace + , setCharSize + , setPixelSizes + , withFreeType + , runFreeType +) where + +import Control.Monad (unless) +import Control.Monad.Except +import Control.Monad.IO.Class (MonadIO, + liftIO) +import Control.Monad.State.Strict +import Data.IntMap.Strict (IntMap) +import qualified Data.IntMap.Strict as IM +import Data.Vector.Unboxed (Unbox) +import qualified Data.Vector.Unboxed as UV +import Foreign as FT hiding + (void) +import Foreign.C.String as FT +import Graphics.Rendering.FreeType.Internal as FT +import Graphics.Rendering.FreeType.Internal.Bitmap as FT +import Graphics.Rendering.FreeType.Internal.Face as FT hiding + (generic) +import Graphics.Rendering.FreeType.Internal.GlyphMetrics (FT_Glyph_Metrics) +import Graphics.Rendering.FreeType.Internal.GlyphSlot as FT +import Graphics.Rendering.FreeType.Internal.Library as FT +import Graphics.Rendering.FreeType.Internal.PrimitiveTypes as FT +import Graphics.Rendering.FreeType.Internal.Vector as FT +import Linear (V2 (..)) + +import Typograffiti.Atlas (Atlas (..), + AtlasMeasure (..)) +import Typograffiti.Glyph (GlyphMetrics (..), + GlyphSize (..)) + + +type FreeTypeT m = ExceptT FT_Error (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 FT_Error (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 e + else fmap (,lib) <$> evalStateT (runExceptT f) lib + +withFreeType :: MonadIO m => Maybe FT_Library -> FreeTypeT m a -> m (Either FT_Error 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) + + +-------------------------------------------------------------------------------- +-- +-------------------------------------------------------------------------------- + + +atlasLibrary :: Atlas tex (FT_Library, FT_Face) -> FT_Library +atlasLibrary = fst . atlasResources + + +atlasFontFace :: Atlas tex (FT_Library, FT_Face) -> FT_Face +atlasFontFace = snd . atlasResources + + +emptyAtlas :: FT_Library -> FT_Face -> tex -> Atlas tex (FT_Library, FT_Face) +emptyAtlas lib fce t = Atlas t (lib, fce) 0 mempty (GlyphSizeInPixels 0 0) "" + + +getFreetypeChar + :: MonadIO m + => Atlas tex (FT_Library, FT_Face) + -> Char + -> FreeTypeT m (FT_Bitmap, FT_Glyph_Metrics) +getFreetypeChar atlas char = do + -- Load the char + loadChar + (atlasFontFace atlas) + (fromIntegral $ fromEnum char) + ft_LOAD_RENDER + -- Get the slot and bitmap + slot <- + liftIO + $ peek + $ glyph + $ atlasFontFace atlas + (,) + <$> liftIO (peek $ bitmap slot) + <*> liftIO (peek $ metrics slot) + + + +-- | 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 + -- The amount of spacing between glyphs rendered into the atlas's + -- texture. + spacing = 1 + -- 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 $ FT.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) + + +type Tri a = (a, a, a) +type V2UVTri = Tri (V2 Float, V2 Float) +type TriQuad = (V2UVTri, V2UVTri) + + +-- | Construct the geometry needed to render the given character. +makeCharQuad + :: ( MonadIO m + , MonadError String m + ) + => Atlas tex (FT_Library, FT_Face) + -- ^ 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 (TriQuad, 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 atlas) + $ getCharIndex (atlasFontFace atlas) ichar + let mndx = either (const Nothing) Just eNdx + px <- case (,,) <$> mndx <*> mLast <*> Just useKerning of + Just (ndx,lndx,True) -> do + e <- withFreeType (Just $ atlasLibrary atlas) $ + getKerning (atlasFontFace atlas) lndx ndx ft_KERNING_DEFAULT + return + $ either + (const penx) + ((+penx) . floor . (* (0.015625 :: Double)) . fromIntegral . fst) + e + _ -> return $ fromIntegral penx + case IM.lookup ichar $ atlasMetrics atlas of + Nothing -> throwError $ "No glyph metrics for glyph: " ++ show 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 atlas + 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 tri1 = (tl, tr, br) + tri2 = (tl, br, bl) + let V2 ax _ = glyphAdvance + return ((tri1, tri2), 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] + + +stringGeom + :: forall m b tex + . ( MonadIO m + , MonadError String m + , Unbox b + ) + => (TriQuad -> UV.Vector b) + -- ^ The function used to expand a quad. + -> Atlas tex (FT_Library, FT_Face) + -- ^ The font atlas. + -> Bool + -- ^ Whether or not to use kerning. + -> String + -- ^ The string. + -> m (UV.Vector b) +stringGeom f atlas useKerning str = do + tqs <- UV.unfoldrM gen (0, Nothing, str) + return $ UV.concatMap f tqs + where + gen + :: (Int, Maybe FT_UInt, String) + -> m (Maybe (TriQuad, (Int, Maybe FT_UInt, String))) + gen (_, _, []) = return Nothing + gen (penx, mndx, c:chars) = do + (triquad, newPenx, newMndx) <- makeCharQuad atlas useKerning penx mndx c + return $ Just (triquad, (newPenx, newMndx, chars)) + + +-- | A bounding box represented by the top left and bottom right points. +type Quad = (V2 Float, V2 Float) + + +-- | Generate the geometry of the given string in (pos, uv) pairs, where each +-- three pairs make a triangle. +stringTris + :: ( MonadIO m + , MonadError String m + ) + => Atlas tex (FT_Library, FT_Face) + -- ^ The font atlas. + -> Bool + -- ^ Whether or not to use kerning. + -> String + -- ^ The string. + -> m (UV.Vector (V2 Float, V2 Float)) +stringTris = + stringGeom + $ \((tl, tr, br), (_tl, _br, bl)) -> + UV.fromList [ tl, tr, br, _tl, _br, bl ] + + +-- | Generate the geometry of the given string in (quad, quad) pairs, where each +-- quad is (top left, bottom right) points of the quad. +stringQuads + :: ( MonadIO m + , MonadError String m + ) + => Atlas tex (FT_Library, FT_Face) + -- ^ The font atlas. + -> Bool + -- ^ Whether or not to use kerning. + -> String + -- ^ The string. + -> m (UV.Vector (Quad, Quad)) + -- ^ A vector of quad pairs, where each pair is (destination quad, source quad) +stringQuads = + stringGeom + $ \((tl, _tr, br), _) -> + UV.singleton ((fst tl, fst br), (snd tl, snd br)) + + +-- | TODO: calculate the size in `stringGeom`. +quadsBounds + :: UV.Vector (Quad, Quad) + -> (V2 Float, V2 Float) +quadsBounds = + boundingBox + . UV.concatMap (\(tl, br) -> UV.fromList [tl, br]) + . fst + . UV.unzip + + +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/typograffiti-freetype/stack.yaml b/typograffiti-freetype/stack.yaml new file mode 100644 index 0000000..3d2263c --- /dev/null +++ b/typograffiti-freetype/stack.yaml @@ -0,0 +1,67 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# https://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# resolver: lts-3.5 +# resolver: nightly-2015-09-21 +# resolver: ghc-7.10.2 +# +# The location of a snapshot can be provided as a file or url. Stack assumes +# a snapshot provided as a file might change, whereas a url resource does not. +# +# resolver: ./custom-snapshot.yaml +# resolver: https://example.com/snapshots/2018-01-01.yaml +resolver: + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/13/20.yaml + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# subdirs: +# - auto-update +# - wai +packages: +- . +# Dependency packages to be pulled from upstream that are not in the resolver. +# These entries can reference officially published versions as well as +# forks / in-progress versions pinned to a git hash. For example: +# +# extra-deps: +# - acme-missiles-0.3 +# - git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# +# extra-deps: [] + +# Override default flag values for local packages and extra-deps +# flags: {} + +# Extra package databases containing global packages +# extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=1.10" +# +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor diff --git a/typograffiti-freetype/test/Spec.hs b/typograffiti-freetype/test/Spec.hs new file mode 100644 index 0000000..cd4753f --- /dev/null +++ b/typograffiti-freetype/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented" diff --git a/typograffiti-freetype/typograffiti-freetype.cabal b/typograffiti-freetype/typograffiti-freetype.cabal new file mode 100644 index 0000000..22ad0b6 --- /dev/null +++ b/typograffiti-freetype/typograffiti-freetype.cabal @@ -0,0 +1,44 @@ +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: 67114a0594e636405ae0281a4db338883e5cbdf4d0f1fa5c2f7eba5eacda0434 + +name: typograffiti-freetype +version: 0.1.0.0 +description: Please see the README on GitHub at +homepage: https://github.com/githubuser/typograffiti-freetype#readme +bug-reports: https://github.com/githubuser/typograffiti-freetype/issues +author: Author name here +maintainer: example@example.com +copyright: 2019 Author name here +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/githubuser/typograffiti-freetype + +library + exposed-modules: + Typograffiti.Freetype + other-modules: + Paths_typograffiti_freetype + hs-source-dirs: + src + ghc-options: -Wall + build-depends: + base >=4.7 && <5 + , containers + , freetype2 + , linear + , mtl + , typograffiti-core + , vector + default-language: Haskell2010 diff --git a/typograffiti-gl/Setup.hs b/typograffiti-gl/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/typograffiti-gl/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/typograffiti-gl/app/Main.hs similarity index 88% rename from app/Main.hs rename to typograffiti-gl/app/Main.hs index a307808..63cf9bf 100644 --- a/app/Main.hs +++ b/typograffiti-gl/app/Main.hs @@ -12,18 +12,18 @@ import Graphics.GL import SDL hiding (rotate) import System.FilePath (()) -import Typograffiti +import Typograffiti.GL myTextStuff :: ( MonadIO m - , MonadError TypograffitiError m + , MonadError String m ) => Window -> m () myTextStuff w = do let ttfName = "assets" "Lora-Regular.ttf" store <- newDefaultFontStore (get $ windowSize w) - RenderedText draw size <- + RenderedGlyphs draw size <- getTextRendering store ttfName @@ -33,7 +33,7 @@ myTextStuff w = do , "This is a test of the emergency word system." , "Quit at any time." ] - liftIO $ print ("text size", size) + liftIO $ print ("text size" :: String, size) fix $ \loop -> do events <- fmap eventPayload @@ -46,6 +46,8 @@ myTextStuff w = do glViewport 0 0 (fromIntegral dw) (fromIntegral dh) draw [move 20 32, rotate (pi / 4), color 1 0 1 1, alpha 0.5] + --draw [move 100 100, color 1 1 1 1, scale 2 2] + draw [move 100 100] glSwapWindow w unless (QuitEvent `elem` events) loop diff --git a/package.yaml b/typograffiti-gl/package.yaml similarity index 75% rename from package.yaml rename to typograffiti-gl/package.yaml index 3386f16..555fb24 100644 --- a/package.yaml +++ b/typograffiti-gl/package.yaml @@ -1,5 +1,5 @@ -name: typograffiti -version: 0.1.0.3 +name: typograffiti-gl +version: 0.2.0.0 github: "schell/typograffiti" license: BSD3 author: "Schell Scivally" @@ -10,8 +10,7 @@ extra-source-files: - README.md - ChangeLog.md -# Metadata used when publishing your package -synopsis: Just let me draw nice text already +synopsis: Just let me draw nice text already! category: Graphics # To avoid duplicated efforts in documentation and dealing with the @@ -24,15 +23,10 @@ description: This is a text rendering library that uses OpenGL one of the biggest hurdles in Haskell graphics programming - and it shouldn't be! - Typograffiti includes an MTL style typeclass and a + typograffiti-gl includes an MTL style typeclass and a default monad transformer. It does not assume you are using any specific windowing solution. It does assume - you are using OpenGL 3.3+. - - Pull requests are very welcome :) - - See https://github.com/schell/typograffiti/blob/master/app/Main.hs - for an example. + you are using OpenGL 3.3+ and have freetype2 installed. dependencies: - base >= 4.7 && < 5 @@ -46,12 +40,14 @@ dependencies: - stm >= 2.5 - template-haskell >= 2.14 - vector >= 0.12 +- typograffiti-core +- typograffiti-freetype library: source-dirs: src executables: - typograffiti-exe: + typograffiti-gl-exe: main: Main.hs source-dirs: app ghc-options: @@ -61,8 +57,8 @@ executables: dependencies: - filepath >= 1.4 - pretty-show >= 1.9 - - sdl2 >= 2.4.1 - - typograffiti + - sdl2 >= 2.4 + - typograffiti-gl tests: @@ -74,4 +70,4 @@ tests: - -rtsopts - -with-rtsopts=-N dependencies: - - typograffiti + - typograffiti-gl diff --git a/typograffiti-gl/src/Typograffiti/GL.hs b/typograffiti-gl/src/Typograffiti/GL.hs new file mode 100644 index 0000000..df9e306 --- /dev/null +++ b/typograffiti-gl/src/Typograffiti/GL.hs @@ -0,0 +1,21 @@ +-- | Provides easy freetype2 and OpenGL based font rendering with a nice Haskell +-- interface. +module Typograffiti.GL + ( + module Typograffiti + , newDefaultFontStore + , getTextRendering + , color + , colorV4 + , alpha + , allocAtlas + , loadText + , makeDefaultAllocateWord + ) where + +import Typograffiti + +import Typograffiti.GL.Atlas +import Typograffiti.GL.Cache +import Typograffiti.GL.Store +import Typograffiti.GL.Transform diff --git a/typograffiti-gl/src/Typograffiti/GL/Atlas.hs b/typograffiti-gl/src/Typograffiti/GL/Atlas.hs new file mode 100644 index 0000000..71cd473 --- /dev/null +++ b/typograffiti-gl/src/Typograffiti/GL/Atlas.hs @@ -0,0 +1,150 @@ +-- | +-- Module: Typograffiti.Atlas +-- Copyright: (c) 2018 Schell Scivally +-- License: MIT +-- Maintainer: Schell Scivally +-- +-- This module provides a font-character atlas to use in font rendering with +-- opengl. +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +module Typograffiti.GL.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.Atlas (Atlas (..), AtlasMeasure (..), + emptyAM) +import Typograffiti.Glyph (CharSize (..), + GlyphMetrics (..), + GlyphSize (..)) + +import Typograffiti.Freetype +import Typograffiti.GL.Utils.OpenGL + + +-------------------------------------------------------------------------------- +-- Atlas +-------------------------------------------------------------------------------- + + +type GLAtlas + = Atlas GLuint (FT_Library, FT_Face) + + +texturize + :: IntMap (V2 Int) + -> Atlas GLuint (FT_Library, FT_Face) + -> Char + -> FreeTypeIO (Atlas GLuint (FT_Library, FT_Face)) +texturize xymap atlas char + | Just pos@(V2 x y) <- IM.lookup (fromEnum char) xymap = do + (bmp, ftms) <- getFreetypeChar atlas char + -- 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) + -- 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 atlas) } + + | 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 String 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 GLuint (FT_Library, FT_Face)) +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 . ("Cannot alloc atlas: " ++) . show) + (return . fst) + e + + +-- | Releases all resources associated with the given 'Atlas'. +freeAtlas :: MonadIO m => Atlas GLuint (FT_Library, FT_Face) -> m () +freeAtlas a = liftIO $ do + _ <- ft_Done_FreeType (atlasLibrary a) + -- _ <- unloadMissingWords a "" + with (atlasTexture a) $ \ptr -> glDeleteTextures 1 ptr diff --git a/typograffiti-gl/src/Typograffiti/GL/Cache.hs b/typograffiti-gl/src/Typograffiti/GL/Cache.hs new file mode 100644 index 0000000..ac423fd --- /dev/null +++ b/typograffiti-gl/src/Typograffiti/GL/Cache.hs @@ -0,0 +1,197 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | Provides a method of caching rendererd text, making it suitable +-- for interactive rendering. +module Typograffiti.GL.Cache where + +import Control.Monad.Except (MonadError (..), liftEither, + runExceptT) +import Control.Monad.IO.Class (MonadIO (..)) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as B8 +import qualified Data.Vector.Unboxed as UV +import Foreign.Marshal.Array +import Graphics.GL +import Linear + +import qualified Typograffiti as Core +import Typograffiti.Atlas (Atlas (..)) +import Typograffiti.Cache (AllocatedRendering (..), + WordCache) +import Typograffiti.Transform (Affine (..), Transform (..)) + +import Typograffiti.Freetype (FT_Face, FT_Library, boundingBox, stringTris) +import Typograffiti.GL.Transform (Multiply (..), TextTransform, + translate) +import Typograffiti.GL.Utils.OpenGL (bufferGeometry, + compileOGLProgram, + compileOGLShader, drawVAO, + getUniformLocation, mat4Rotate, + mat4Scale, mat4Translate, + newBoundVAO, newBuffer, + orthoProjection, updateUniform, + withBoundTextures) + + +-- | Load the given text into the given WordCache using the given monadic +-- rendering and transform operations. +-- This is a specialized version of Typograffiti.Cache.loadText. +loadText + :: ( MonadIO m + , MonadError String m + ) + => ( Atlas GLuint (FT_Library, FT_Face) + -> String + -> m (AllocatedRendering [TextTransform] GLuint) + ) + -- ^ Monadic operation used to allocate a word. + -> Atlas GLuint (FT_Library, FT_Face) + -- ^ The character atlas that holds our letters. + -> WordCache Char [TextTransform] GLuint + -- ^ The WordCache to load AllocatedRenderings into. + -> String + -- ^ The string to render. + -- This string may contain newlines, which will be respected. + -> m ([TextTransform] -> IO (), V2 Int, WordCache Char [TextTransform] GLuint) + -- ^ Returns a function for rendering the text, the size of the text and the + -- new WordCache with the allocated renderings of the text. +loadText = Core.loadWords translate Core.charGlyphAction + + +transformToUniforms + :: [TextTransform] + -> (M44 Float, V4 Float) +transformToUniforms = foldl toUniform (identity, 1.0) + where toUniform (mv, clr) (Transform (Multiply c)) = + (mv, clr * c) + toUniform (mv, clr) (TransformAffine s) = + let mv1 = case s of + AffineTranslate (V2 x y) -> + mv !*! mat4Translate (V3 x y 0) + AffineScale (V2 x y) -> + mv !*! mat4Scale (V3 x y 1) + AffineRotate 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);" + , "}" + ] + + +liftGL + :: ( MonadIO m + , MonadError String m + ) + => m (Either String a) + -> m a +liftGL m = m >>= liftEither + + +-- | A default operation for allocating one word worth of geometry. This is "word" as in +-- an English word, not a data type. +makeDefaultAllocateWord + :: ( MonadIO m + , MonadError String 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 GLuint (FT_Library, FT_Face) + -> String + -> IO (Either String (AllocatedRendering [TextTransform] GLuint)) + ) +makeDefaultAllocateWord getContextSize = do + let position = 0 + uv = 1 + 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 + , arTextures = [] + , arRelease = release + , arSizes = [round <$> size] + } diff --git a/typograffiti-gl/src/Typograffiti/GL/Store.hs b/typograffiti-gl/src/Typograffiti/GL/Store.hs new file mode 100644 index 0000000..5240f6e --- /dev/null +++ b/typograffiti-gl/src/Typograffiti/GL/Store.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | A storage context and operations for rendering text with multiple fonts +-- and sizes. +module Typograffiti.GL.Store where + + +import Control.Concurrent.STM (atomically, newTMVar) +import Control.Monad.Except (MonadError (..)) +import Control.Monad.IO.Class (MonadIO (..)) +import qualified Data.Set as S +import Linear + + +import Typograffiti (GlyphRenderingData (..), + GlyphSize, RenderedGlyphs, + Transform) +import qualified Typograffiti as Core +import Typograffiti.Store (Dictionary, Store (..)) + +import Typograffiti.Freetype (FT_Face, FT_Library) +import Typograffiti.GL.Atlas (allocAtlas) +import Typograffiti.GL.Cache (makeDefaultAllocateWord) +import Typograffiti.GL.Transform (Multiply, TextTransform, + translate) +import Typograffiti.GL.Utils.OpenGL (GLuint) + + +-- | A pre-rendered bit of text, ready to display given +-- some post compilition transformations. Also contains +-- the text size. +type RenderedText = RenderedGlyphs [TextTransform] + + +-- | A cache of words and rasterised glyphs +type Font = Dictionary GLuint (FT_Library, FT_Face) Char [Transform Multiply] + + +-- | All the data needed to render TTF font text quickly. +type TextRenderingData + = GlyphRenderingData + GLuint + (FT_Library, FT_Face) + [TextTransform] + + +-- | Stored fonts at specific sizes. +type FontStore = + Store + GLuint + (FT_Library, FT_Face) + [TextTransform] + Char + + +getTextRendering + :: ( MonadIO m + , MonadError String m + ) + => FontStore + -- ^ 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 m) + -- ^ The rendered text, ready to draw to the screen. +getTextRendering = + Core.getRendering allocAtlas translate Core.charGlyphAction + + +newDefaultFontStore + :: ( MonadIO m + , MonadError String m + , Integral i + ) + => IO (V2 i) + -> m FontStore +newDefaultFontStore getDims = do + aw <- makeDefaultAllocateWord getDims + let dat = + GlyphRenderingData + { glyphRenderingDataAllocWord = aw + , glyphRenderingDataDictMap = mempty + , glyphRenderingDataGlyphSet = S.fromList Core.asciiChars + } + Store + <$> liftIO (atomically $ newTMVar dat) diff --git a/typograffiti-gl/src/Typograffiti/GL/Transform.hs b/typograffiti-gl/src/Typograffiti/GL/Transform.hs new file mode 100644 index 0000000..54fdd0e --- /dev/null +++ b/typograffiti-gl/src/Typograffiti/GL/Transform.hs @@ -0,0 +1,37 @@ +module Typograffiti.GL.Transform where + +import Linear (V2 (..), V4 (..)) + +import Typograffiti.Transform (Transform (..), move) + + +newtype Multiply + = Multiply (V4 Float) + + +type TextTransform + = Transform Multiply + + +color :: Float -> Float -> Float -> Float -> TextTransform +color r g b a = + Transform + $ Multiply + $ V4 r g b a + + +colorV4 :: V4 Float -> TextTransform +colorV4 = + Transform + . Multiply + + +alpha :: Float -> TextTransform +alpha = + Transform + . Multiply + . V4 1 1 1 + + +translate :: [TextTransform] -> V2 Float -> [TextTransform] +translate ts (V2 x y) = ts ++ [move x y] diff --git a/src/Typograffiti/GL.hs b/typograffiti-gl/src/Typograffiti/GL/Utils/OpenGL.hs similarity index 96% rename from src/Typograffiti/GL.hs rename to typograffiti-gl/src/Typograffiti/GL/Utils/OpenGL.hs index 7c260e8..dc7df5e 100644 --- a/src/Typograffiti/GL.hs +++ b/typograffiti-gl/src/Typograffiti/GL/Utils/OpenGL.hs @@ -1,7 +1,10 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} -module Typograffiti.GL where +module Typograffiti.GL.Utils.OpenGL + ( module Typograffiti.GL.Utils.OpenGL + , GLuint + ) where import Control.Exception (assert) import Control.Monad (forM_, replicateM, when) @@ -352,16 +355,3 @@ 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/typograffiti-gl/typograffiti-gl.cabal b/typograffiti-gl/typograffiti-gl.cabal new file mode 100644 index 0000000..5538b2b --- /dev/null +++ b/typograffiti-gl/typograffiti-gl.cabal @@ -0,0 +1,107 @@ +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: 429fd143b06721f85e57717f0bb392d9cfe55e6833986908cd2bec2494f1c996 + +name: typograffiti-gl +version: 0.2.0.0 +synopsis: Just let me draw nice text already! +description: This is a text rendering library that uses OpenGL and freetype2 to render TTF font strings quickly. It is fast enough to render large chunks of text in real time. This library exists because text rendering is one of the biggest hurdles in Haskell graphics programming - and it shouldn't be! + typograffiti-gl includes an MTL style typeclass and a default monad transformer. It does not assume you are using any specific windowing solution. It does assume you are using OpenGL 3.3+ and have freetype2 installed. +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 +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.GL + Typograffiti.GL.Atlas + Typograffiti.GL.Cache + Typograffiti.GL.Store + Typograffiti.GL.Transform + Typograffiti.GL.Utils.OpenGL + other-modules: + Paths_typograffiti_gl + hs-source-dirs: + src + build-depends: + base >=4.7 && <5 + , bytestring >=0.10 + , containers >=0.6 + , freetype2 >=0.1 + , gl >=0.8 + , linear >=1.20 + , mtl >=2.2 + , pretty-show >=1.9 + , stm >=2.5 + , template-haskell >=2.14 + , typograffiti-core + , typograffiti-freetype + , vector >=0.12 + default-language: Haskell2010 + +executable typograffiti-gl-exe + main-is: Main.hs + other-modules: + Paths_typograffiti_gl + hs-source-dirs: + app + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5 + , bytestring >=0.10 + , containers >=0.6 + , filepath >=1.4 + , freetype2 >=0.1 + , gl >=0.8 + , linear >=1.20 + , mtl >=2.2 + , pretty-show >=1.9 + , sdl2 >=2.4 + , stm >=2.5 + , template-haskell >=2.14 + , typograffiti-core + , typograffiti-freetype + , typograffiti-gl + , vector >=0.12 + default-language: Haskell2010 + +test-suite typograffiti-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_typograffiti_gl + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5 + , bytestring >=0.10 + , containers >=0.6 + , freetype2 >=0.1 + , gl >=0.8 + , linear >=1.20 + , mtl >=2.2 + , pretty-show >=1.9 + , stm >=2.5 + , template-haskell >=2.14 + , typograffiti-core + , typograffiti-freetype + , typograffiti-gl + , vector >=0.12 + default-language: Haskell2010 diff --git a/typograffiti-sdl/ChangeLog.md b/typograffiti-sdl/ChangeLog.md new file mode 100644 index 0000000..cd99ced --- /dev/null +++ b/typograffiti-sdl/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for typograffiti-sdl + +## Unreleased changes diff --git a/typograffiti-sdl/LICENSE b/typograffiti-sdl/LICENSE new file mode 100644 index 0000000..102126f --- /dev/null +++ b/typograffiti-sdl/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2019 + +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. diff --git a/typograffiti-sdl/README.md b/typograffiti-sdl/README.md new file mode 100644 index 0000000..60bda3f --- /dev/null +++ b/typograffiti-sdl/README.md @@ -0,0 +1 @@ +# typograffiti-sdl diff --git a/typograffiti-sdl/Setup.hs b/typograffiti-sdl/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/typograffiti-sdl/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/typograffiti-sdl/app/Main.hs b/typograffiti-sdl/app/Main.hs new file mode 100644 index 0000000..fa01f0d --- /dev/null +++ b/typograffiti-sdl/app/Main.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Control.Concurrent.STM (atomically, putTMVar, takeTMVar) +import Control.Monad (unless, foldM_) +import Control.Monad.Except (MonadError, runExceptT) +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Function (fix) +import qualified Data.Map as M +import Linear (V2 (..), V4 (..)) +import SDL (Renderer, ($=)) +import qualified SDL +import System.FilePath (()) + +import Typograffiti.SDL +import Typograffiti.Store + + +myTextStuff + :: ( MonadIO m + , MonadError String m + ) + => Renderer + -> m () +myTextStuff r = do + let ttfName = "assets" "Lora-Regular.ttf" + glyphSz = GlyphSizeInPixels 16 16 + store <- newDefaultFontStore r + RenderedGlyphs draw size <- + getTextRendering + r + store + ttfName + glyphSz + $ unlines + [ "Hey there!" + , "This is a test of the emergency word system." + , "Quit at any time." + ] + + liftIO $ print ("text size" :: String, size) + + fix $ \loop -> do + events <- fmap SDL.eventPayload + <$> SDL.pollEvents + + SDL.rendererDrawColor r $= V4 175 175 175 255 + SDL.clear r + + --s@(GlyphRenderingData _ dict _) <- + -- liftIO + -- $ atomically + -- $ takeTMVar + -- $ unStore store + + --case M.lookup (ttfName, glyphSz) dict of + -- Nothing -> return () + -- Just (Dictionary atlas cache) -> do + -- SDL.copy + -- r + -- (atlasTexture atlas) + -- Nothing + -- $ Just + -- $ SDL.Rectangle + -- 0 + -- $ fromIntegral + -- <$> atlasTextureSize atlas + + -- let V2 _ startingY = atlasTextureSize atlas + -- renderTex y ar = do + -- case (arTextures ar, arSizes ar) of + -- (tex:_, sz@(V2 _ szy):_) -> do + -- SDL.copy + -- r + -- tex + -- Nothing + -- $ Just + -- $ SDL.Rectangle + -- (SDL.P $ fromIntegral <$> V2 0 y) + -- $ fromIntegral + -- <$> sz + -- return $ y + szy + -- (_, _) -> return y + -- foldM_ + -- renderTex + -- startingY + -- $ M.elems + -- $ unWordCache cache + + --liftIO + -- $ atomically + -- $ putTMVar + -- (unStore store) + -- s + + draw [move 100 100, color 1.0 0 0 1.0] + draw [move 100 120, color 1.0 1.0 1.0 1.0] + + SDL.present r + unless (SDL.QuitEvent `elem` events) loop + + +main :: IO () +main = do + SDL.initializeAll + + let wcfg = SDL.defaultWindow + { SDL.windowInitialSize = V2 640 480 } + rcfg = SDL.defaultRenderer + { SDL.rendererType = SDL.AcceleratedVSyncRenderer } + + w <- SDL.createWindow "Typograffiti SDL" wcfg + r <- SDL.createRenderer w (-1) rcfg + + SDL.rendererDrawBlendMode r $= SDL.BlendAlphaBlend + + runExceptT (myTextStuff r) + >>= either (fail . show) return diff --git a/typograffiti-sdl/package.yaml b/typograffiti-sdl/package.yaml new file mode 100644 index 0000000..4b16414 --- /dev/null +++ b/typograffiti-sdl/package.yaml @@ -0,0 +1,60 @@ +name: typograffiti-sdl +version: 0.1.0.0 +github: "githubuser/typograffiti-sdl" +license: BSD3 +author: "Author name here" +maintainer: "example@example.com" +copyright: "2019 Author name here" + +extra-source-files: +- README.md +- ChangeLog.md + +# Metadata used when publishing your package +# synopsis: Short description of your package +# category: Web + +# To avoid duplicated efforts in documentation and dealing with the +# complications of embedding Haddock markup inside cabal files, it is +# common to point users to the README.md file. +description: Please see the README on GitHub at + +dependencies: +- base >= 4.7 && < 5 +- bytestring +- containers +- freetype2 +- lens +- linear +- mtl +- sdl2 +- stm +- typograffiti-core +- typograffiti-freetype +- vector + +library: + source-dirs: src + +executables: + typograffiti-sdl-exe: + main: Main.hs + source-dirs: app + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - typograffiti-sdl + - filepath + +tests: + typograffiti-sdl-test: + main: Spec.hs + source-dirs: test + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - typograffiti-sdl diff --git a/typograffiti-sdl/src/Typograffiti/SDL.hs b/typograffiti-sdl/src/Typograffiti/SDL.hs new file mode 100644 index 0000000..e1b9d84 --- /dev/null +++ b/typograffiti-sdl/src/Typograffiti/SDL.hs @@ -0,0 +1,21 @@ +-- | Provides easy freetype2 and SDL based font rendering with a nice Haskell +-- interface. +module Typograffiti.SDL + ( + module Typograffiti + , newDefaultFontStore + , newFontStoreWithGlyphs + , getTextRendering + , color + , colorV4 + , alpha + , allocAtlas + , loadText + , makeDefaultAllocateWord + ) where + +import Typograffiti +import Typograffiti.SDL.Atlas +import Typograffiti.SDL.Cache +import Typograffiti.SDL.Store +import Typograffiti.SDL.Transform diff --git a/typograffiti-sdl/src/Typograffiti/SDL/Atlas.hs b/typograffiti-sdl/src/Typograffiti/SDL/Atlas.hs new file mode 100644 index 0000000..390714c --- /dev/null +++ b/typograffiti-sdl/src/Typograffiti/SDL/Atlas.hs @@ -0,0 +1,144 @@ +-- | +-- This module provides a font-character atlas to use in font rendering with +-- sdl2's built in 2d renderer. +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +module Typograffiti.SDL.Atlas where + +import Control.Monad +import Control.Monad.Except (MonadError (..)) +import Control.Monad.IO.Class +import qualified Data.ByteString as BS +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.Rendering.FreeType.Internal.Bitmap as BM +import Graphics.Rendering.FreeType.Internal.GlyphMetrics as GM +import Linear +import SDL (Renderer, + Texture, + ($=)) +import qualified SDL + +import Typograffiti.Atlas (Atlas (..), AtlasMeasure (..), + emptyAM) +import Typograffiti.Freetype +import Typograffiti.Glyph (CharSize (..), + GlyphMetrics (..), + GlyphSize (..)) + + +-------------------------------------------------------------------------------- +-- Atlas +-------------------------------------------------------------------------------- + + +type SDLAtlas + = Atlas Texture (FT_Library, FT_Face) + + +texturize + :: Texture + -> IntMap (V2 Int) + -> Atlas Texture (FT_Library, FT_Face) + -> Char + -> FreeTypeIO (Atlas Texture (FT_Library, FT_Face)) +texturize tex xymap atlas char + | Just pos@(V2 x y) <- IM.lookup (fromEnum char) xymap = do + (bmp, ftms) <- getFreetypeChar atlas char + -- Update our texture by adding the bitmap + let dest = SDL.Rectangle (SDL.P pos) (fromIntegral <$> V2 (BM.width bmp) (rows bmp)) + bytes <- + liftIO + $ BS.packCStringLen (BM.buffer bmp, fromIntegral $ BM.width bmp * rows bmp) + let rgbaBytes = + flip BS.concatMap + bytes + $ \val -> foldr BS.cons BS.empty [val,255,255,255] + unless (BM.pitch bmp == 0) + $ void + $ SDL.updateTexture + tex + (Just $ fromIntegral <$> dest) + rgbaBytes + (BM.width bmp * 4) + -- 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 atlas) } + + | 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'. Glyph texturization only +-- happens once. +allocAtlas + :: ( MonadIO m + , MonadError String m + ) + => Renderer + -- ^ The SDL 2d renderer. + -> 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 Texture (FT_Library, FT_Face)) +allocAtlas r 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 <- + SDL.createTexture + r + SDL.RGBA8888 + SDL.TextureAccessStreaming + (fromIntegral <$> V2 w h) + --SDL.textureBlendMode t $= SDL.BlendAlphaBlend + lib <- getLibrary + atlas <- foldM (texturize t xymap) (emptyAtlas lib fce t) str + return + atlas{ atlasTextureSize = V2 w h + , atlasGlyphSize = gs + , atlasFilePath = fontFilePath + } + + either + (throwError . ("Cannot alloc atlas: " ++) . show) + (return . fst) + e + + +-- | Releases all resources associated with the given 'Atlas'. +freeAtlas :: MonadIO m => Atlas Texture (FT_Library, FT_Face) -> m () +freeAtlas a = liftIO $ do + _ <- ft_Done_FreeType (atlasLibrary a) + -- _ <- unloadMissingWords a "" + SDL.destroyTexture (atlasTexture a) diff --git a/typograffiti-sdl/src/Typograffiti/SDL/Cache.hs b/typograffiti-sdl/src/Typograffiti/SDL/Cache.hs new file mode 100644 index 0000000..0c109ca --- /dev/null +++ b/typograffiti-sdl/src/Typograffiti/SDL/Cache.hs @@ -0,0 +1,172 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | Provides a method of caching rendererd text, making it suitable +-- for interactive rendering. +module Typograffiti.SDL.Cache where + +import Control.Lens ((^.)) +import Control.Monad (when) +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.Foldable (for_) +import qualified Data.Vector.Mutable as MV +import qualified Data.Vector.Unboxed as UV +import Data.Word (Word8) +import Foreign.Marshal.Array +import Linear +import SDL (Point (..), Rectangle (..), + Renderer, Texture, ($=)) +import qualified SDL + +import qualified Typograffiti as Core +import Typograffiti.Atlas (Atlas (..)) +import Typograffiti.Cache (AllocatedRendering (..), WordCache) +import Typograffiti.Transform (Affine (..), Transform (..)) + +import Typograffiti.Freetype (FT_Face, FT_Library, boundingBox, + makeCharQuad, quadsBounds, + stringQuads) +import Typograffiti.SDL.Transform (Multiply (..), TextTransform, + translate) + + +-- | Load the given text into the given WordCache using the given monadic +-- rendering and transform operations. +-- This is a specialized version of Typograffiti.Cache.loadText. +loadText + :: ( MonadIO m + , MonadError String m + ) + => ( Atlas Texture (FT_Library, FT_Face) + -> String + -> m (AllocatedRendering [TextTransform] Texture) + ) + -- ^ Monadic operation used to allocate a word. + -> Atlas Texture (FT_Library, FT_Face) + -- ^ The character atlas that holds our letters. + -> WordCache Char [TextTransform] Texture + -- ^ The WordCache to load AllocatedRenderings into. + -> String + -- ^ The string to render. + -- This string may contain newlines, which will be respected. + -> m ([TextTransform] -> IO (), V2 Int, WordCache Char [TextTransform] Texture) + -- ^ Returns a function for rendering the text, the size of the text and the + -- new WordCache with the allocated renderings of the text. +loadText = Core.loadWords translate Core.charGlyphAction + + +transformToUnits + :: [TextTransform] + -> (V2 Float, V2 Float, Float, V4 Float) +transformToUnits = foldl toUnit (0, 1, 0, 1) + where + toUnit (t, s, r, clr) (Transform (Multiply c)) = + (t, s, r, clr * c) + toUnit (t, s, r, c) (TransformAffine a) = + case a of + AffineTranslate v -> (t + v, s, r, c) + AffineScale sc -> (t, s * sc, r, c) + AffineRotate rt -> (t, s, r + rt, c) + + +liftSDL + :: ( MonadIO m + , MonadError String m + ) + => m (Either String a) + -> m a +liftSDL n = n >>= liftEither + + +quad2Rectangle + :: Integral a + => (V2 Float, V2 Float) + -> Rectangle a +quad2Rectangle (tl, br) = + Rectangle + (P $ round <$> tl) + (abs . round <$> br - tl) + + +-- | A default operation for allocating one word worth of geometry. This is "word" as in +-- an English word, not a data type. +makeDefaultAllocateWord + :: ( MonadIO m + , MonadError String m + ) + => Renderer + -> m (Atlas Texture (FT_Library, FT_Face) + -> String + -> IO (Either String (AllocatedRendering [TextTransform] Texture)) + ) +makeDefaultAllocateWord r = return $ \atlas -> \case + "" -> return $ Right mempty + string -> do + -- Generate our string geometry + runExceptT (stringQuads atlas True string) >>= \case + Left err -> return $ Left err + Right quads -> do + let (tl, br) = quadsBounds quads + (sz@(V2 _ szh)) = br - tl + tex <- + SDL.createTexture + r + SDL.RGBA8888 + SDL.TextureAccessTarget + (round <$> sz) + -- Bind the texture as the renderer's target, + -- draw the word into our texture, then unbind + SDL.textureBlendMode tex $= SDL.BlendAlphaBlend + prev <- SDL.get $ SDL.rendererRenderTarget r + SDL.rendererRenderTarget r $= Just tex + UV.forM_ quads $ \((destTL, destBR), (srcTL, srcBR)) -> do + -- The source quads are in percentages of the total texture size, + -- so we have to convert them + let cvtSrc = (* (fromIntegral <$> atlasTextureSize atlas)) + srcRect = quad2Rectangle (cvtSrc srcTL, cvtSrc srcBR) + cvtDest v = V2 (v ^. _x) (sz ^. _y + v ^. _y - br ^. _y) + destRect = quad2Rectangle (cvtDest destTL, cvtDest destBR) + SDL.copy + r + (atlasTexture atlas) + (Just srcRect) + (Just destRect) + SDL.rendererRenderTarget r $= prev + -- Return a draw function and a release function + let draw :: [TextTransform] -> IO () + draw ts = do + let (trns, scl, rot, clr) = transformToUnits ts + pos = trns + tl + color :: V4 Word8 = floor . (* 255.0) . (/ 1.0) <$> clr + SDL.textureColorMod tex $= color ^. _xyz + SDL.textureAlphaMod tex $= color ^. _w + SDL.copyEx + r + tex + (Just + $ SDL.Rectangle 0 + $ round <$> sz + ) + (Just + $ SDL.Rectangle + (SDL.P $ round <$> pos) + $ round <$> scl * sz + ) + (realToFrac rot) + (Just $ (P $ round <$> pos)) + (V2 False False) + release = SDL.destroyTexture tex + return + $ Right AllocatedRendering + { arDraw = draw + , arTextures = [tex] + , arRelease = release + , arSizes = [round <$> sz] + } diff --git a/typograffiti-sdl/src/Typograffiti/SDL/Store.hs b/typograffiti-sdl/src/Typograffiti/SDL/Store.hs new file mode 100644 index 0000000..6b2f35a --- /dev/null +++ b/typograffiti-sdl/src/Typograffiti/SDL/Store.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | A storage context and operations for rendering text with multiple fonts +-- and sizes. +module Typograffiti.SDL.Store where + + +import Control.Concurrent.STM (atomically, newTMVar) +import Control.Monad.Except (MonadError (..)) +import Control.Monad.IO.Class (MonadIO (..)) +import qualified Data.Set as S +import Linear +import SDL (Texture, Renderer) +import qualified SDL + +import Typograffiti (GlyphRenderingData (..), GlyphSize, + RenderedGlyphs, Transform) +import qualified Typograffiti as Core +import Typograffiti.Freetype (FT_Face, FT_Library) +import Typograffiti.SDL.Atlas (allocAtlas) +import Typograffiti.SDL.Cache (makeDefaultAllocateWord) +import Typograffiti.SDL.Transform (Multiply, TextTransform, translate) +import Typograffiti.Store (Dictionary, Store (..)) + + +-- | A pre-rendered bit of text, ready to display given +-- some post compilition transformations. Also contains +-- the text size. +type RenderedText = RenderedGlyphs [TextTransform] + + +-- | A cache of words and rasterised glyphs +type Font = Dictionary Texture (FT_Library, FT_Face) Char [Transform Multiply] + + +-- | All the data needed to render TTF font text quickly. +type TextRenderingData + = GlyphRenderingData + Texture + (FT_Library, FT_Face) + [TextTransform] + + +-- | Stored fonts at specific sizes. +type FontStore = + Store + Texture + (FT_Library, FT_Face) + [TextTransform] + Char + + +getTextRendering + :: ( MonadIO m + , MonadError String m + ) + => Renderer + -- ^ The SDL 2d renderer. + -> FontStore + -- ^ 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 m) + -- ^ The rendered text, ready to draw to the screen. +getTextRendering r = + Core.getRendering (allocAtlas r) translate Core.charGlyphAction + + +newFontStoreWithGlyphs + :: ( MonadIO m + , MonadError String m + ) + => String + -> Renderer + -> m FontStore +newFontStoreWithGlyphs glyphs r = do + aw <- makeDefaultAllocateWord r + let dat = + GlyphRenderingData + { glyphRenderingDataAllocWord = aw + , glyphRenderingDataDictMap = mempty + , glyphRenderingDataGlyphSet = S.fromList glyphs + } + Store + <$> liftIO (atomically $ newTMVar dat) + + +newDefaultFontStore + :: ( MonadIO m + , MonadError String m + ) + => Renderer + -> m FontStore +newDefaultFontStore = + newFontStoreWithGlyphs Core.asciiChars diff --git a/typograffiti-sdl/src/Typograffiti/SDL/Transform.hs b/typograffiti-sdl/src/Typograffiti/SDL/Transform.hs new file mode 100644 index 0000000..a3c98cb --- /dev/null +++ b/typograffiti-sdl/src/Typograffiti/SDL/Transform.hs @@ -0,0 +1,37 @@ +module Typograffiti.SDL.Transform where + +import Linear (V2 (..), V4 (..)) + +import Typograffiti.Transform (Transform (..), move) + + +newtype Multiply + = Multiply (V4 Float) + + +type TextTransform + = Transform Multiply + + +color :: Float -> Float -> Float -> Float -> TextTransform +color r g b a = + Transform + $ Multiply + $ V4 r g b a + + +colorV4 :: V4 Float -> TextTransform +colorV4 = + Transform + . Multiply + + +alpha :: Float -> TextTransform +alpha = + Transform + . Multiply + . V4 1 1 1 + + +translate :: [TextTransform] -> V2 Float -> [TextTransform] +translate ts (V2 x y) = ts ++ [move x y] diff --git a/typograffiti-sdl/stack.yaml b/typograffiti-sdl/stack.yaml new file mode 100644 index 0000000..3d2263c --- /dev/null +++ b/typograffiti-sdl/stack.yaml @@ -0,0 +1,67 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# https://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# resolver: lts-3.5 +# resolver: nightly-2015-09-21 +# resolver: ghc-7.10.2 +# +# The location of a snapshot can be provided as a file or url. Stack assumes +# a snapshot provided as a file might change, whereas a url resource does not. +# +# resolver: ./custom-snapshot.yaml +# resolver: https://example.com/snapshots/2018-01-01.yaml +resolver: + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/13/20.yaml + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# subdirs: +# - auto-update +# - wai +packages: +- . +# Dependency packages to be pulled from upstream that are not in the resolver. +# These entries can reference officially published versions as well as +# forks / in-progress versions pinned to a git hash. For example: +# +# extra-deps: +# - acme-missiles-0.3 +# - git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# +# extra-deps: [] + +# Override default flag values for local packages and extra-deps +# flags: {} + +# Extra package databases containing global packages +# extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=1.10" +# +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor diff --git a/typograffiti-sdl/test/Spec.hs b/typograffiti-sdl/test/Spec.hs new file mode 100644 index 0000000..cd4753f --- /dev/null +++ b/typograffiti-sdl/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented" diff --git a/typograffiti-sdl/typograffiti-sdl.cabal b/typograffiti-sdl/typograffiti-sdl.cabal new file mode 100644 index 0000000..a2593e9 --- /dev/null +++ b/typograffiti-sdl/typograffiti-sdl.cabal @@ -0,0 +1,100 @@ +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: bdfeac5eb7d40c7ecbc877ad9fb391c7c84007d3d69d3cfe98569eb621e4a520 + +name: typograffiti-sdl +version: 0.1.0.0 +description: Please see the README on GitHub at +homepage: https://github.com/githubuser/typograffiti-sdl#readme +bug-reports: https://github.com/githubuser/typograffiti-sdl/issues +author: Author name here +maintainer: example@example.com +copyright: 2019 Author name here +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/githubuser/typograffiti-sdl + +library + exposed-modules: + Typograffiti.SDL + Typograffiti.SDL.Atlas + Typograffiti.SDL.Cache + Typograffiti.SDL.Store + Typograffiti.SDL.Transform + other-modules: + Paths_typograffiti_sdl + hs-source-dirs: + src + build-depends: + base >=4.7 && <5 + , bytestring + , containers + , freetype2 + , lens + , linear + , mtl + , sdl2 + , stm + , typograffiti-core + , typograffiti-freetype + , vector + default-language: Haskell2010 + +executable typograffiti-sdl-exe + main-is: Main.hs + other-modules: + Paths_typograffiti_sdl + hs-source-dirs: + app + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5 + , bytestring + , containers + , filepath + , freetype2 + , lens + , linear + , mtl + , sdl2 + , stm + , typograffiti-core + , typograffiti-freetype + , typograffiti-sdl + , vector + default-language: Haskell2010 + +test-suite typograffiti-sdl-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_typograffiti_sdl + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5 + , bytestring + , containers + , freetype2 + , lens + , linear + , mtl + , sdl2 + , stm + , typograffiti-core + , typograffiti-freetype + , typograffiti-sdl + , vector + default-language: Haskell2010 -- 2.30.2