~alcinnz/Typograffiti

c8e0b8e470f8fc4f994f2538f5f3c1bb66106a42 — Schell Carl Scivally 5 years ago 01bae44 
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
patch browse 
57 files changed, 2963 insertions(+), 1028 deletions(-)

M .gitignore
M .gitlab-ci.yml
D src/Typograffiti.hs
D src/Typograffiti/Atlas.hs
D src/Typograffiti/Cache.hs
D src/Typograffiti/Store.hs
D src/Typograffiti/Utils.hs
M stack.yaml
M test/Spec.hs
A typograffiti-core/ChangeLog.md
A typograffiti-core/LICENSE
A typograffiti-core/README.md
R Setup.hs => typograffiti-core/Setup.hs
A typograffiti-core/app/Main.hs
A typograffiti-core/package.yaml
A typograffiti-core/src/Typograffiti.hs
A typograffiti-core/src/Typograffiti/Atlas.hs
A typograffiti-core/src/Typograffiti/Cache.hs
R src/Typograffiti/Glyph.hs => typograffiti-core/src/Typograffiti/Glyph.hs
A typograffiti-core/src/Typograffiti/Store.hs
A typograffiti-core/src/Typograffiti/Transform.hs
A typograffiti-core/stack.yaml
A typograffiti-core/test/Spec.hs
A typograffiti-core/typograffiti-core.cabal
A typograffiti-freetype/ChangeLog.md
A typograffiti-freetype/LICENSE
A typograffiti-freetype/README.md
A typograffiti-freetype/Setup.hs
A typograffiti-freetype/package.yaml
A typograffiti-freetype/src/Typograffiti/Freetype.hs
A typograffiti-freetype/stack.yaml
A typograffiti-freetype/test/Spec.hs
A typograffiti-freetype/typograffiti-freetype.cabal
A typograffiti-gl/Setup.hs
R app/Main.hs => typograffiti-gl/app/Main.hs
R package.yaml => typograffiti-gl/package.yaml
A typograffiti-gl/src/Typograffiti/GL.hs
A typograffiti-gl/src/Typograffiti/GL/Atlas.hs
A typograffiti-gl/src/Typograffiti/GL/Cache.hs
A typograffiti-gl/src/Typograffiti/GL/Store.hs
A typograffiti-gl/src/Typograffiti/GL/Transform.hs
R src/Typograffiti/GL.hs => typograffiti-gl/src/Typograffiti/GL/Utils/OpenGL.hs
A typograffiti-gl/typograffiti-gl.cabal
A typograffiti-sdl/ChangeLog.md
A typograffiti-sdl/LICENSE
A typograffiti-sdl/README.md
A typograffiti-sdl/Setup.hs
A typograffiti-sdl/app/Main.hs
A typograffiti-sdl/package.yaml
A typograffiti-sdl/src/Typograffiti/SDL.hs
A typograffiti-sdl/src/Typograffiti/SDL/Atlas.hs
A typograffiti-sdl/src/Typograffiti/SDL/Cache.hs
A typograffiti-sdl/src/Typograffiti/SDL/Store.hs
A typograffiti-sdl/src/Typograffiti/SDL/Transform.hs
A typograffiti-sdl/stack.yaml
A typograffiti-sdl/test/Spec.hs
A typograffiti-sdl/typograffiti-sdl.cabal

M .gitignore => .gitignore +0 -1
@@ 17,4 17,3 @@ cabal.config
.projectile
TAGS
*.#*
*.cabal


M .gitlab-ci.yml => .gitlab-ci.yml +2 -0
@@ 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


D src/Typograffiti.hs => src/Typograffiti.hs +0 -47
@@ 1,47 0,0 @@
-- |
-- Module:     Typograffiti
-- Copyright:  (c) 2018 Schell Scivally
-- License:    MIT
-- Maintainer: Schell Scivally <schell@takt.com>
--
-- This module provides easy freetype2-based font rendering with a nice
-- Haskell interface.
module Typograffiti
  (
  -- * Some simple default text rendering operations
    RenderedText (..)
  , TextRenderingData (..)
  , FontStore
  , newDefaultFontStore
  , getTextRendering
  -- * Transforming rendered text
  , TextTransform (..)
  -- TODO Vector variants of the transformation helpers.
  -- i.e. moveV2, scaleV2, colorV4
  , move
  , scale
  , rotate
  , color
  , alpha
  , Layout (..)
  -- * Getting low
  , allocAtlas
  , loadText
  , unloadMissingWords
  , stringTris
  , makeDefaultAllocateWord
  , asciiChars
  -- * Types
  , GlyphSize (..)
  , CharSize (..)
  , Atlas (..)
  , WordCache (..)
  , AllocatedRendering (..)
  -- * Errors
  , TypograffitiError (..)
  ) where

import           Typograffiti.Atlas
import           Typograffiti.Cache
import           Typograffiti.Glyph
import           Typograffiti.Store


D src/Typograffiti/Atlas.hs => src/Typograffiti/Atlas.hs +0 -297
@@ 1,297 0,0 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards  #-}
{-# LANGUAGE TypeApplications #-}
-- |
-- Module:     Typograffiti.Atlas
-- Copyright:  (c) 2018 Schell Scivally
-- License:    MIT
-- Maintainer: Schell Scivally <schell@takt.com>
--
-- This module provides a font-character atlas to use in font rendering with
-- opengl.
--
module Typograffiti.Atlas where

import           Control.Monad
import           Control.Monad.Except                              (MonadError (..))
import           Control.Monad.IO.Class
import           Data.IntMap                                       (IntMap)
import qualified Data.IntMap                                       as IM
import           Data.Vector.Unboxed                               (Vector)
import qualified Data.Vector.Unboxed                               as UV
import           Foreign.Marshal.Utils                             (with)
import           Graphics.GL.Core32
import           Graphics.GL.Types
import           Graphics.Rendering.FreeType.Internal.Bitmap       as BM
import           Graphics.Rendering.FreeType.Internal.GlyphMetrics as GM
import           Linear

import           Typograffiti.GL
import           Typograffiti.Glyph
import           Typograffiti.Utils



data TypograffitiError =
    TypograffitiErrorNoGlyphMetricsForChar Char
  -- ^ The are no glyph metrics for this character. This probably means
  -- the character has not been loaded into the atlas.
  | TypograffitiErrorFreetype String String
  -- ^ There was a problem while interacting with the freetype2 library.
  | TypograffitiErrorGL String
  -- ^ There was a problem while interacting with OpenGL.
  deriving (Show, Eq)


--------------------------------------------------------------------------------
-- Atlas
--------------------------------------------------------------------------------


data Atlas = Atlas { atlasTexture     :: GLuint
                   , atlasTextureSize :: V2 Int
                   , atlasLibrary     :: FT_Library
                   , atlasFontFace    :: FT_Face
                   , atlasMetrics     :: IntMap GlyphMetrics
                   , atlasGlyphSize   :: GlyphSize
                   , atlasFilePath    :: FilePath
                   }


emptyAtlas :: FT_Library -> FT_Face -> GLuint -> Atlas
emptyAtlas lib fce t = Atlas t 0 lib fce mempty (GlyphSizeInPixels 0 0) ""


data AtlasMeasure = AM { amWH      :: V2 Int
                       , amXY      :: V2 Int
                       , rowHeight :: Int
                       } deriving (Show, Eq)


emptyAM :: AtlasMeasure
emptyAM = AM 0 (V2 1 1) 0


-- | The amount of spacing between glyphs rendered into the atlas's texture.
spacing :: Int
spacing = 1


-- | Extract the measurements of a character in the FT_Face and append it to
-- the given AtlasMeasure.
measure
  :: FT_Face
  -> Int
  -> (IntMap AtlasMeasure, AtlasMeasure)
  -> Char
  -> FreeTypeIO (IntMap AtlasMeasure, AtlasMeasure)
measure fce maxw (prev, am@AM{..}) char
  -- Skip chars that have already been measured
  | fromEnum char `IM.member` prev = return (prev, am)
  | otherwise = do
    let V2 x y = amXY
        V2 w h = amWH
    -- Load the char, replacing the glyph according to
    -- https://www.freetype.org/freetype2/docs/tutorial/step1.html
    loadChar fce (fromIntegral $ fromEnum char) ft_LOAD_RENDER
    -- Get the glyph slot
    slot <- liftIO $ peek $ glyph fce
    -- Get the bitmap
    bmp <- liftIO $ peek $ bitmap slot
    let bw = fromIntegral $ BM.width bmp
        bh = fromIntegral $ rows bmp
        gotoNextRow = (x + bw + spacing) >= maxw
        rh = if gotoNextRow then 0 else max bh rowHeight
        nx = if gotoNextRow then 0 else x + bw + spacing
        nw = max w (x + bw + spacing)
        nh = max h (y + rh + spacing)
        ny = if gotoNextRow then nh else y
        am1 = AM { amWH = V2 nw nh
                 , amXY = V2 nx ny
                 , rowHeight = rh
                 }
    return (IM.insert (fromEnum char) am prev, am1)


texturize :: IntMap (V2 Int) -> Atlas -> Char -> FreeTypeIO Atlas
texturize xymap atlas@Atlas{..} char
  | Just pos@(V2 x y) <- IM.lookup (fromEnum char) xymap = do
    -- Load the char
    loadChar atlasFontFace (fromIntegral $ fromEnum char) ft_LOAD_RENDER
    -- Get the slot and bitmap
    slot  <- liftIO $ peek $ glyph atlasFontFace
    bmp   <- liftIO $ peek $ bitmap slot
    -- Update our texture by adding the bitmap
    glTexSubImage2D
      GL_TEXTURE_2D
      0
      (fromIntegral x)
      (fromIntegral y)
      (fromIntegral $ BM.width bmp)
      (fromIntegral $ rows bmp)
      GL_RED
      GL_UNSIGNED_BYTE
      (castPtr $ buffer bmp)
    -- Get the glyph metrics
    ftms  <- liftIO $ peek $ metrics slot
    -- Add the metrics to the atlas
    let vecwh = fromIntegral <$> V2 (BM.width bmp) (rows bmp)
        canon = floor @Double @Int . (* 0.015625) . fromIntegral
        vecsz = canon <$> V2 (GM.width ftms) (GM.height ftms)
        vecxb = canon <$> V2 (horiBearingX ftms) (horiBearingY ftms)
        vecyb = canon <$> V2 (vertBearingX ftms) (vertBearingY ftms)
        vecad = canon <$> V2 (horiAdvance ftms) (vertAdvance ftms)
        mtrcs = GlyphMetrics { glyphTexBB = (pos, pos + vecwh)
                             , glyphTexSize = vecwh
                             , glyphSize = vecsz
                             , glyphHoriBearing = vecxb
                             , glyphVertBearing = vecyb
                             , glyphAdvance = vecad
                             }
    return atlas{ atlasMetrics = IM.insert (fromEnum char) mtrcs atlasMetrics }

  | otherwise = do
    liftIO $ putStrLn "could not find xy"
    return atlas

-- | Allocate a new 'Atlas'.
-- When creating a new 'Atlas' you must pass all the characters that you
-- might need during the life of the 'Atlas'. Character texturization only
-- happens once.
allocAtlas
  :: ( MonadIO m
     , MonadError TypograffitiError m
     )
  => FilePath
  -- ^ Path to the font file to use for this Atlas.
  -> GlyphSize
  -- ^ Size of glyphs in this Atlas.
  -> String
  -- ^ The characters to include in this 'Atlas'.
  -> m Atlas
allocAtlas fontFilePath gs str = do
  e <- liftIO $ runFreeType $ do
    fce <- newFace fontFilePath
    case gs of
      GlyphSizeInPixels w h -> setPixelSizes fce w h
      GlyphSizeByChar (CharSize w h dpix dpiy) -> setCharSize fce w h dpix dpiy

    (amMap, am) <- foldM (measure fce 512) (mempty, emptyAM) str

    let V2 w h = amWH am
        xymap :: IntMap (V2 Int)
        xymap  = amXY <$> amMap

    t <- liftIO $ do
      t <- allocAndActivateTex GL_TEXTURE0
      glPixelStorei GL_UNPACK_ALIGNMENT 1
      withCString (replicate (w * h) $ toEnum 0) $
        glTexImage2D GL_TEXTURE_2D 0 GL_RED (fromIntegral w) (fromIntegral h)
                     0 GL_RED GL_UNSIGNED_BYTE . castPtr
      return t

    lib   <- getLibrary
    atlas <- foldM (texturize xymap) (emptyAtlas lib fce t) str

    glGenerateMipmap GL_TEXTURE_2D
    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_REPEAT
    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_REPEAT
    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR
    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR
    glBindTexture GL_TEXTURE_2D 0
    glPixelStorei GL_UNPACK_ALIGNMENT 4
    return
      atlas{ atlasTextureSize = V2 w h
           , atlasGlyphSize = gs
           , atlasFilePath = fontFilePath
           }

  either
    (throwError . TypograffitiErrorFreetype "cannot alloc atlas")
    (return . fst)
    e


-- | Releases all resources associated with the given 'Atlas'.
freeAtlas :: MonadIO m => Atlas -> m ()
freeAtlas a = liftIO $ do
  _ <- ft_Done_FreeType (atlasLibrary a)
  -- _ <- unloadMissingWords a ""
  with (atlasTexture a) $ \ptr -> glDeleteTextures 1 ptr


-- | Construct the geometry needed to render the given character.
makeCharQuad
  :: ( MonadIO m
     , MonadError TypograffitiError m
     )
  => Atlas
  -- ^ The atlas that contains the metrics for the given character.
  -> Bool
  -- ^ Whether or not to use kerning.
  -> Int
  -- ^ The current "pen position".
  -> Maybe FT_UInt
  -- ^ The freetype index of the previous character, if available.
  -> Char
  -- ^ The character to generate geometry for.
  -> m (Vector (V2 Float, V2 Float), Int, Maybe FT_UInt)
  -- ^ Returns the generated geometry (position in 2-space and UV parameters),
  -- the next pen position and the freetype index of the given character, if
  -- available.
makeCharQuad Atlas{..} useKerning penx mLast char = do
  let ichar = fromEnum char
  eNdx <- withFreeType (Just atlasLibrary) $ getCharIndex atlasFontFace ichar
  let mndx = either (const Nothing) Just eNdx
  px <- case (,,) <$> mndx <*> mLast <*> Just useKerning of
    Just (ndx,lndx,True) -> do
      e <- withFreeType (Just atlasLibrary) $
        getKerning atlasFontFace lndx ndx ft_KERNING_DEFAULT
      return $ either (const penx) ((+penx) . floor . (* 0.015625) . fromIntegral . fst) e
    _  -> return $ fromIntegral penx
  case IM.lookup ichar atlasMetrics of
    Nothing -> throwError $ TypograffitiErrorNoGlyphMetricsForChar char
    Just GlyphMetrics{..} -> do
      let V2 dx dy = fromIntegral <$> glyphHoriBearing
          x = fromIntegral px + dx
          y = -dy
          V2 w h = fromIntegral <$> glyphSize
          V2 aszW aszH = fromIntegral <$> atlasTextureSize
          V2 texL texT = fromIntegral <$> fst glyphTexBB
          V2 texR texB = fromIntegral <$> snd glyphTexBB

          tl = (V2 x      y   , V2 (texL/aszW) (texT/aszH))
          tr = (V2 (x+w)  y   , V2 (texR/aszW) (texT/aszH))
          br = (V2 (x+w) (y+h), V2 (texR/aszW) (texB/aszH))
          bl = (V2 x     (y+h), V2 (texL/aszW) (texB/aszH))
      let vs = UV.fromList [ tl, tr, br
                           , tl, br, bl
                           ]
      let V2 ax _ = glyphAdvance
      return (vs, px + ax, mndx)


-- | A string containing all standard ASCII characters.
-- This is often passed as the 'String' parameter in 'allocAtlas'.
asciiChars :: String
asciiChars = map toEnum [32..126]


-- | Generate the geometry of the given string.
stringTris
  :: ( MonadIO m
     , MonadError TypograffitiError m
     )
  => Atlas
  -- ^ The font atlas.
  -> Bool
  -- ^ Whether or not to use kerning.
  -> String
  -- ^ The string.
  -> m (Vector (V2 Float, V2 Float))
stringTris atlas useKerning str = do
  (vs, _, _) <- foldM gen (mempty, 0, Nothing) str
  return $ UV.concat vs
  where gen (vs, penx, mndx) c = do
          (newVs, newPenx, newMndx) <- makeCharQuad atlas useKerning penx mndx c
          return (vs ++ [newVs], newPenx, newMndx)


D src/Typograffiti/Cache.hs => src/Typograffiti/Cache.hs +0 -362
@@ 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 <schell@takt.com>
--
-- This module provides a method of caching rendererd text, making it suitable
-- for interactive rendering. You can use the defaultCache or provide your own.
--
module Typograffiti.Cache where

import           Control.Monad          (foldM)
import           Control.Monad.Except   (MonadError (..), liftEither,
                                         runExceptT)
import           Control.Monad.IO.Class (MonadIO (..))
import           Data.Bifunctor         (first)
import           Data.ByteString        (ByteString)
import qualified Data.ByteString.Char8  as B8
import qualified Data.IntMap            as IM
import           Data.Map               (Map)
import qualified Data.Map               as M
import           Data.Maybe             (fromMaybe)
import qualified Data.Vector.Unboxed    as UV
import           Foreign.Marshal.Array
import           Graphics.GL
import           Linear

import           Typograffiti.Atlas
import           Typograffiti.GL
import           Typograffiti.Glyph


-- | Generic operations for text layout.
class Layout t where
  translate :: t -> V2 Float -> t


-- | Holds an allocated draw function for some amount of text. The function
-- takes one parameter that can be used to transform the text in various ways.
-- This type is generic and can be used to take advantage of your own font
-- rendering shaders.
data AllocatedRendering t = AllocatedRendering
  { arDraw    :: t -> IO ()
    -- ^ Draw the text with some transformation in some monad.
  , arRelease :: IO ()
    -- ^ Release the allocated draw function in some monad.
  , arSize    :: V2 Int
    -- ^ The size (in pixels) of the drawn text.
  }


newtype WordCache t = WordCache
  { unWordCache :: Map String (AllocatedRendering t) }
  deriving (Semigroup, Monoid)


-- | Load a string of words into the WordCache.
loadWords
  :: ( MonadIO m
     , MonadError TypograffitiError m
     )
  => (Atlas -> String -> m (AllocatedRendering t))
  -- ^ Operation used to allocate a word.
  -> Atlas
  -- ^ The character atlas that holds our letters, which is used to generate
  -- the word geometry.
  -> WordCache t
  -- ^ The atlas to load the words into.
  -> String
  -- ^ The string of words to load, with each word separated by spaces.
  -> m (WordCache t)
loadWords f atlas (WordCache cache) str =
  WordCache
    <$> foldM loadWord cache (words str)
  where loadWord wm word
          | M.member word wm = return wm
          | otherwise =
              flip (M.insert word) wm <$> f atlas word


-- | Unload any words from the cache that are not contained in the source string.
unloadMissingWords
  :: MonadIO m
  => WordCache t
  -- ^ The WordCache to unload words from.
  -> String
  -- ^ The source string.
  -> m (WordCache t)
unloadMissingWords (WordCache cache) str = do
  let ws      = M.fromList $ zip (words str) (repeat ())
      missing = M.difference cache ws
      retain  = M.difference cache missing
  liftIO
    $ sequence_
    $ arRelease <$> missing
  return $ WordCache retain


-- | Constructs a 'Renderer2' from the given color and string. The 'WordMap'
-- record of the given 'Atlas' is used to construct the string geometry, greatly
-- improving performance and allowing longer strings to be compiled and renderered
-- in real time. To create a new 'Atlas' see 'allocAtlas'.
--
-- Note that since word geometries are stored in the 'Atlas' 'WordMap' and multiple
-- renderers can reference the same 'Atlas', the returned 'Renderer2' contains a
-- clean up operation that does nothing. It is expected that the programmer
-- will call 'freeAtlas' manually when the 'Atlas' is no longer needed.
loadText
  :: forall m t.
     ( MonadIO m
     , MonadError TypograffitiError m
     , Layout t
     )
  => (Atlas -> String -> m (AllocatedRendering t))
  -- ^ Operation used to allocate a word.
  -> Atlas
  -- ^ The character atlas that holds our letters.
  -> WordCache t
  -- ^ The WordCache to load AllocatedRenderings into.
  -> String
  -- ^ The string to render.
  -- This string may contain newlines, which will be respected.
  -> m (t -> IO (), V2 Int, WordCache t)
  -- ^ Returns a function for rendering the text, the size of the text and the
  -- new WordCache with the allocated renderings of the text.
loadText f atlas wc str = do
  wc1@(WordCache cache) <- loadWords f atlas wc str
  let glyphw  = round $ pixelWidth $ atlasGlyphSize atlas
      spacew  :: Int
      spacew  = fromMaybe glyphw $ do
        metrcs <- IM.lookup (fromEnum ' ') $ atlasMetrics atlas
        let V2 x _ = glyphAdvance metrcs
        return x
      glyphh = pixelHeight $ atlasGlyphSize atlas
      spaceh = round glyphh
      isWhiteSpace c = c == ' ' || c == '\n' || c == '\t'
      renderWord :: t -> V2 Int -> String -> IO ()
      renderWord _ _ ""       = return ()
      renderWord t (V2 _ y) ('\n':cs) = renderWord t (V2 0 (y + spaceh)) cs
      renderWord t (V2 x y) (' ':cs)  = renderWord t (V2 (x + spacew) y) cs
      renderWord t v@(V2 x y) cs               = do
        let word = takeWhile (not . isWhiteSpace) cs
            rest = drop (length word) cs
        case M.lookup word cache of
          Nothing -> renderWord t v rest
          Just ar -> do
            let t1 = translate t $ fromIntegral <$> v
                V2 w _ = arSize ar
                pen = V2 (x + fromIntegral w) y
            arDraw ar t1
            renderWord t pen rest
      rr t = renderWord t 0 str
      measureString :: (V2 Int, V2 Int) -> String -> (V2 Int, V2 Int)
      measureString xywh ""                    = xywh
      measureString (V2 x y, V2 w _) (' ':cs)  =
        let nx = x + spacew in measureString (V2 nx y, V2 (max w nx) y) cs
      measureString (V2 x y, V2 w h) ('\n':cs) =
        let ny = y + spaceh in measureString (V2 x ny, V2 w (max h ny)) cs
      measureString (V2 x y, V2 w h) cs        =
        let word = takeWhile (not . isWhiteSpace) cs
            rest = drop (length word) cs
            n    = case M.lookup word cache of
                    Nothing -> (V2 x y, V2 w h)
                    Just ar -> let V2 ww _ = arSize ar
                                   nx      = x + ww
                                in (V2 nx y, V2 (max w nx) y)
        in measureString n rest
      V2 szw szh = snd $ measureString (0,0) str
  return (rr, V2 szw (max spaceh szh), wc1)


--------------------------------------------------------------------------------
-- Default word allocation
--------------------------------------------------------------------------------


data SpatialTransform = SpatialTransformTranslate (V2 Float)
                      | SpatialTransformScale (V2 Float)
                      | SpatialTransformRotate Float


data TextTransform = TextTransformMultiply (V4 Float)
                   | TextTransformSpatial SpatialTransform


move :: Float -> Float -> TextTransform
move x y =
  TextTransformSpatial
  $ SpatialTransformTranslate
  $ V2 x y


scale :: Float -> Float -> TextTransform
scale x y =
  TextTransformSpatial
  $ SpatialTransformScale
  $ V2 x y


rotate :: Float -> TextTransform
rotate =
  TextTransformSpatial
  . SpatialTransformRotate


color :: Float -> Float -> Float -> Float -> TextTransform
color r g b a =
  TextTransformMultiply
  $ V4 r g b a


alpha :: Float -> TextTransform
alpha =
  TextTransformMultiply
  . V4 1 1 1


instance Layout [TextTransform] where
  translate ts (V2 x y) = ts ++ [move x y]


transformToUniforms
  :: [TextTransform]
  -> (M44 Float, V4 Float)
transformToUniforms = foldl toUniform (identity, 1.0)
  where toUniform (mv, clr) (TextTransformMultiply c) =
          (mv, clr * c)
        toUniform (mv, clr) (TextTransformSpatial s) =
          let mv1 = case s of
                SpatialTransformTranslate (V2 x y) ->
                  mv !*! mat4Translate (V3 x y 0)
                SpatialTransformScale (V2 x y) ->
                  mv !*! mat4Scale (V3 x y 1)
                SpatialTransformRotate r ->
                  mv !*! mat4Rotate r (V3 0 0 1)
          in (mv1, clr)


vertexShader :: ByteString
vertexShader = B8.pack $ unlines
  [ "#version 330 core"
  , "uniform mat4 projection;"
  , "uniform mat4 modelview;"
  , "in vec2 position;"
  , "in vec2 uv;"
  , "out vec2 fuv;"
  , "void main () {"
  , "  fuv = uv;"
  , "  gl_Position = projection * modelview * vec4(position.xy, 0.0, 1.0);"
  , "}"
  ]


fragmentShader :: ByteString
fragmentShader = B8.pack $ unlines
  [ "#version 330 core"
  , "in vec2 fuv;"
  , "out vec4 fcolor;"
  , "uniform sampler2D tex;"
  , "uniform vec4 mult_color;"
  , "void main () {"
  , "  vec4 tcolor = texture(tex, fuv);"
  , "  fcolor = vec4(mult_color.rgb, mult_color.a * tcolor.r);"
  , "}"
  ]


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
              }


D src/Typograffiti/Store.hs => src/Typograffiti/Store.hs +0 -151
@@ 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 <schell@takt.com>
--
-- A storage context an ops for rendering text with multiple fonts
-- and sizes, hiding the details of the Atlas and WordCache.
module Typograffiti.Store where


import           Control.Concurrent.STM (TMVar, atomically, newTMVar, putTMVar,
                                         readTMVar, takeTMVar)
import           Control.Monad.Except   (MonadError (..), liftEither)
import           Control.Monad.IO.Class (MonadIO (..))
import           Data.Map               (Map)
import qualified Data.Map               as M
import           Data.Set               (Set)
import qualified Data.Set               as S
import           Linear


import           Typograffiti.Atlas
import           Typograffiti.Cache
import           Typograffiti.Glyph


-- | A pre-rendered bit of text, ready to display given
-- some post compilition transformations. Also contains
-- the text size.
data RenderedText t m = RenderedText
  { drawRenderedText   :: t -> m ()
  , sizeOfRenderedText :: V2 Int
  }


data Font t = Font
  { fontAtlas     :: Atlas
  , fontWordCache :: WordCache t
  }


data TextRenderingData t = TextRenderingData
  { textRenderingDataAllocWord :: Atlas -> String -> IO (Either TypograffitiError (AllocatedRendering t))
  -- ^ The operation used to alloc a word.
  -- Generate geometry, use a shader program, set uniforms, etc.
  , textRenderingDataFontMap   :: Map (FilePath, GlyphSize) (Font t)
  -- ^ The cached fonts.
  , textRenderingDataCharSet   :: Set Char
  -- ^ The character set to have available in all allocated Atlas types.
  }


-- | Stored fonts at specific sizes.
newtype FontStore t = FontStore
  { unFontStore :: TMVar (TextRenderingData t)}


getTextRendering
  :: ( MonadIO m
     , MonadError TypograffitiError m
     , Layout t
     )
  => FontStore t
  -- ^ The font store.
  -> FilePath
  -- ^ The path to the font to use
  -- for rendering.
  -> GlyphSize
  -- ^ The size of the font glyphs.
  -> String
  -- ^ The string to render.
  -> m (RenderedText t m)
  -- ^ The rendered text, ready to draw to the screen.
getTextRendering store file sz str = do
  let mvar = unFontStore store
  s    <- liftIO $ atomically $ readTMVar mvar
  font <- case M.lookup (file, sz) $ textRenderingDataFontMap s of
    Nothing   -> allocFont store file sz
    Just font -> return font
  (draw, tsz, cache) <-
    loadText
      (\x y -> liftIO (textRenderingDataAllocWord s x y) >>= liftEither)
      (fontAtlas font)
      (fontWordCache font)
      str
  liftIO
    $ atomically $ do
      s1 <- takeTMVar mvar
      let alterf Nothing               = Just $ Font (fontAtlas font) cache
          alterf (Just (Font atlas _)) = Just $ Font atlas cache
          fontmap = M.alter alterf (file,sz)
            $ textRenderingDataFontMap s1
      putTMVar mvar s1{ textRenderingDataFontMap = fontmap }
  return RenderedText
    { drawRenderedText   = liftIO . draw
    , sizeOfRenderedText = tsz
    }


newDefaultFontStore
  :: ( MonadIO m
     , MonadError TypograffitiError m
     , Integral i
     )
  => IO (V2 i)
  -> m (FontStore [TextTransform])
newDefaultFontStore getDims = do
  aw <- makeDefaultAllocateWord getDims
  let dat = TextRenderingData
        { textRenderingDataAllocWord = aw
        , textRenderingDataFontMap   = mempty
        , textRenderingDataCharSet   = S.fromList asciiChars
        }
  FontStore
    <$> liftIO (atomically $ newTMVar dat)


allocFont
  :: ( MonadIO m
     , MonadError TypograffitiError m
     , Layout t
     )
  => FontStore t
  -> FilePath
  -> GlyphSize
  -> m (Font t)
allocFont store file sz = do
  let mvar = unFontStore store
  s     <- liftIO $ atomically $ takeTMVar mvar
  atlas <-
    allocAtlas
      file
      sz
      $ S.toList
      $ textRenderingDataCharSet s
  let fontmap = textRenderingDataFontMap s
      font = Font
        { fontAtlas     = atlas
        , fontWordCache = mempty
        }
  liftIO
    $ atomically
    $ putTMVar mvar
    $ s{ textRenderingDataFontMap = M.insert (file, sz) font fontmap }
  return font


D src/Typograffiti/Utils.hs => src/Typograffiti/Utils.hs +0 -128
@@ 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)


M stack.yaml => stack.yaml +5 -2
@@ 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)


M test/Spec.hs => test/Spec.hs +3 -1
@@ 1,2 1,4 @@
import Test.DocTest (doctest)

main :: IO ()
main = putStrLn "Test suite not yet implemented"
main = doctest ["src"]


A typograffiti-core/ChangeLog.md => typograffiti-core/ChangeLog.md +3 -0
@@ 0,0 1,3 @@
# Changelog for typograffiti-core

## Unreleased changes


A typograffiti-core/LICENSE => typograffiti-core/LICENSE +30 -0
@@ 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.


A typograffiti-core/README.md => typograffiti-core/README.md +1 -0
@@ 0,0 1,1 @@
# typograffiti-core


R Setup.hs => typograffiti-core/Setup.hs +0 -0
A typograffiti-core/app/Main.hs => typograffiti-core/app/Main.hs +6 -0
@@ 0,0 1,6 @@
module Main where

import Lib

main :: IO ()
main = someFunc


A typograffiti-core/package.yaml => typograffiti-core/package.yaml +44 -0
@@ 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 <https://github.com/githubuser/typograffiti-core#readme>

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


A typograffiti-core/src/Typograffiti.hs => typograffiti-core/src/Typograffiti.hs +70 -0
@@ 0,0 1,70 @@
-- |
-- Module:     Typograffiti
-- Copyright:  (c) 2019 Schell Scivally
-- License:    MIT
-- Maintainer: Schell Scivally <schell@formation.ai>
--
-- 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


A typograffiti-core/src/Typograffiti/Atlas.hs => typograffiti-core/src/Typograffiti/Atlas.hs +67 -0
@@ 0,0 1,67 @@
-- |
-- Module:     Typograffiti.Atlas
-- Copyright:  (c) 2019 Schell Scivally
-- License:    MIT
-- Maintainer: Schell Scivally <schell@takt.com>
--
-- 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]


A typograffiti-core/src/Typograffiti/Cache.hs => typograffiti-core/src/Typograffiti/Cache.hs +247 -0
@@ 0,0 1,247 @@
-- |
-- Module:     Typograffiti.Cache
-- Copyright:  (c) 2018 Schell Scivally
-- License:    MIT
-- Maintainer: Schell Scivally <schell@takt.com>
--
-- This module provides a method of caching rendererd text, making it suitable
-- for 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)


R src/Typograffiti/Glyph.hs => typograffiti-core/src/Typograffiti/Glyph.hs +58 -6
@@ 1,17 1,17 @@
module Typograffiti.Glyph where


import Linear
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
  { charSizeWidth     :: Int
    -- ^ Width of a character specified in 1/64 of points.
  , charSizeHeight :: Int
  , charSizeHeight    :: Int
    -- ^ Height of a character specified in 1/64 of points.
  , charSizeWidthDPI :: Int
  , charSizeWidthDPI  :: Int
    -- ^ Horizontal device resolution
  , charSizeHeightDPI :: Int
    -- ^ Vertical device resolution


@@ 43,12 43,64 @@ pixelHeight (GlyphSizeByChar (CharSize w h xdpi ydpi)) =
  in fromIntegral sz * fromIntegral dpi / 72


-- | https://www.freetype.org/freetype2/docs/tutorial/step2.html
data GlyphMetrics = GlyphMetrics
-- | 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)


A typograffiti-core/src/Typograffiti/Store.hs => typograffiti-core/src/Typograffiti/Store.hs +165 -0
@@ 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 <schell@takt.com>
--
-- A storage context an ops for rendering text with multiple fonts
-- and sizes, hiding the details of the Atlas and WordCache.
module Typograffiti.Store where


import           Control.Concurrent.STM (TMVar, atomically, 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


A typograffiti-core/src/Typograffiti/Transform.hs => typograffiti-core/src/Typograffiti/Transform.hs +47 -0
@@ 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


A typograffiti-core/stack.yaml => typograffiti-core/stack.yaml +67 -0
@@ 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


A typograffiti-core/test/Spec.hs => typograffiti-core/test/Spec.hs +4 -0
@@ 0,0 1,4 @@
import Test.DocTest (doctest)

main :: IO ()
main = doctest ["src"]


A typograffiti-core/typograffiti-core.cabal => typograffiti-core/typograffiti-core.cabal +66 -0
@@ 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 <https://github.com/githubuser/typograffiti-core#readme>
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


A typograffiti-freetype/ChangeLog.md => typograffiti-freetype/ChangeLog.md +3 -0
@@ 0,0 1,3 @@
# Changelog for typograffiti-freetype

## Unreleased changes


A typograffiti-freetype/LICENSE => typograffiti-freetype/LICENSE +30 -0
@@ 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.


A typograffiti-freetype/README.md => typograffiti-freetype/README.md +1 -0
@@ 0,0 1,1 @@
# typograffiti-freetype


A typograffiti-freetype/Setup.hs => typograffiti-freetype/Setup.hs +2 -0
@@ 0,0 1,2 @@
import Distribution.Simple
main = defaultMain


A typograffiti-freetype/package.yaml => typograffiti-freetype/package.yaml +34 -0
@@ 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 <https://github.com/githubuser/typograffiti-freetype#readme>

dependencies:
- base >= 4.7 && < 5
- containers
- freetype2
- linear
- mtl
- typograffiti-core
- vector

library:
  source-dirs: src
  ghc-options:
  - -Wall


A typograffiti-freetype/src/Typograffiti/Freetype.hs => typograffiti-freetype/src/Typograffiti/Freetype.hs +405 -0
@@ 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


A typograffiti-freetype/stack.yaml => typograffiti-freetype/stack.yaml +67 -0
@@ 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


A typograffiti-freetype/test/Spec.hs => typograffiti-freetype/test/Spec.hs +2 -0
@@ 0,0 1,2 @@
main :: IO ()
main = putStrLn "Test suite not yet implemented"


A typograffiti-freetype/typograffiti-freetype.cabal => typograffiti-freetype/typograffiti-freetype.cabal +44 -0
@@ 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 <https://github.com/githubuser/typograffiti-freetype#readme>
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


A typograffiti-gl/Setup.hs => typograffiti-gl/Setup.hs +2 -0
@@ 0,0 1,2 @@
import Distribution.Simple
main = defaultMain


R app/Main.hs => typograffiti-gl/app/Main.hs +6 -4
@@ 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


R package.yaml => typograffiti-gl/package.yaml +11 -15
@@ 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


A typograffiti-gl/src/Typograffiti/GL.hs => typograffiti-gl/src/Typograffiti/GL.hs +21 -0
@@ 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


A typograffiti-gl/src/Typograffiti/GL/Atlas.hs => typograffiti-gl/src/Typograffiti/GL/Atlas.hs +150 -0
@@ 0,0 1,150 @@
-- |
-- Module:     Typograffiti.Atlas
-- Copyright:  (c) 2018 Schell Scivally
-- License:    MIT
-- Maintainer: Schell Scivally <schell@takt.com>
--
-- This module provides a font-character atlas to use in font rendering with
-- opengl.
{-# 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


A typograffiti-gl/src/Typograffiti/GL/Cache.hs => typograffiti-gl/src/Typograffiti/GL/Cache.hs +197 -0
@@ 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]
              }


A typograffiti-gl/src/Typograffiti/GL/Store.hs => typograffiti-gl/src/Typograffiti/GL/Store.hs +94 -0
@@ 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)


A typograffiti-gl/src/Typograffiti/GL/Transform.hs => typograffiti-gl/src/Typograffiti/GL/Transform.hs +37 -0
@@ 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]


R src/Typograffiti/GL.hs => typograffiti-gl/src/Typograffiti/GL/Utils/OpenGL.hs +4 -14
@@ 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


A typograffiti-gl/typograffiti-gl.cabal => typograffiti-gl/typograffiti-gl.cabal +107 -0
@@ 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


A typograffiti-sdl/ChangeLog.md => typograffiti-sdl/ChangeLog.md +3 -0
@@ 0,0 1,3 @@
# Changelog for typograffiti-sdl

## Unreleased changes


A typograffiti-sdl/LICENSE => typograffiti-sdl/LICENSE +30 -0
@@ 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.


A typograffiti-sdl/README.md => typograffiti-sdl/README.md +1 -0
@@ 0,0 1,1 @@
# typograffiti-sdl


A typograffiti-sdl/Setup.hs => typograffiti-sdl/Setup.hs +2 -0
@@ 0,0 1,2 @@
import Distribution.Simple
main = defaultMain


A typograffiti-sdl/app/Main.hs => typograffiti-sdl/app/Main.hs +119 -0
@@ 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


A typograffiti-sdl/package.yaml => typograffiti-sdl/package.yaml +60 -0
@@ 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 <https://github.com/githubuser/typograffiti-sdl#readme>

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


A typograffiti-sdl/src/Typograffiti/SDL.hs => typograffiti-sdl/src/Typograffiti/SDL.hs +21 -0
@@ 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


A typograffiti-sdl/src/Typograffiti/SDL/Atlas.hs => typograffiti-sdl/src/Typograffiti/SDL/Atlas.hs +144 -0
@@ 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)


A typograffiti-sdl/src/Typograffiti/SDL/Cache.hs => typograffiti-sdl/src/Typograffiti/SDL/Cache.hs +172 -0
@@ 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]
              }


A typograffiti-sdl/src/Typograffiti/SDL/Store.hs => typograffiti-sdl/src/Typograffiti/SDL/Store.hs +103 -0
@@ 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


A typograffiti-sdl/src/Typograffiti/SDL/Transform.hs => typograffiti-sdl/src/Typograffiti/SDL/Transform.hs +37 -0
@@ 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]


A typograffiti-sdl/stack.yaml => typograffiti-sdl/stack.yaml +67 -0
@@ 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


A typograffiti-sdl/test/Spec.hs => typograffiti-sdl/test/Spec.hs +2 -0
@@ 0,0 1,2 @@
main :: IO ()
main = putStrLn "Test suite not yet implemented"


A typograffiti-sdl/typograffiti-sdl.cabal => typograffiti-sdl/typograffiti-sdl.cabal +100 -0
@@ 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 <https://github.com/githubuser/typograffiti-sdl#readme>
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