A => .gitignore +20 -0
@@ 1,20 @@
+dist*
+*.hi
+*.o
+*.sqlite3
+.cabal-sandbox
+cabal.sandbox.config
+cabal.config
+*/.stack-work/
+.stack-work/
+*.sw[a-z]
+*.hp
+*.prof
+*.tags
+*.out
+*.tmp
+.DS_Store
+.projectile
+TAGS
+*.#*
+*.cabal
A => ChangeLog.md +3 -0
@@ 1,3 @@
+# Changelog for typograffiti
+
+## Unreleased changes
A => LICENSE +30 -0
@@ 1,30 @@
+Copyright Author name here (c) 2018
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Author name here nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
A => README.md +6 -0
@@ 1,6 @@
+# typograffiti
+Typograffiti aims to make working with text in multimedia applications easy.
+
+## requirements
+* opengl 3.x
+* freetype 2.x
A => Setup.hs +2 -0
@@ 1,2 @@
+import Distribution.Simple
+main = defaultMain
A => app/Main.hs +130 -0
@@ 1,130 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+module Main where
+
+import Control.Monad (forever)
+import Control.Monad.Except (runExceptT, withExceptT)
+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 Graphics.GL
+import SDL
+import System.FilePath ((</>))
+import Typograffiti
+import Typograffiti.GL
+
+
+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, 0.0, 0.1);"
+ , "}"
+ ]
+
+
+fragmentShader :: ByteString
+fragmentShader = B8.pack $ unlines
+ [ "#version 330 core"
+ , "in vec2 fuv;"
+ , "out vec4 fcolor;"
+ , "uniform sampler2D tex;"
+ , "void main () {"
+ , " fcolor = texture(tex, fuv);"
+ , "}"
+ ]
+
+
+main :: IO ()
+main = do
+ SDL.initializeAll
+
+ let openGL = defaultOpenGL
+ { glProfile = Core Debug 3 3 }
+ wcfg = defaultWindow
+ { windowInitialSize = V2 640 480
+ , windowOpenGL = Just openGL
+ }
+
+ w <- createWindow "Typograffiti" wcfg
+ _ <- glCreateContext w
+ let ttfName = "assets" </> "Neuton-Regular.ttf"
+
+ (either fail return =<<) . runExceptT $ do
+ -- Get the atlas
+ atlas <- withExceptT show
+ $ allocAtlas ttfName (PixelSize 16 16) asciiChars
+ -- Compile our shader program
+ let position = 0
+ uv = 1
+ vert <- compileOGLShader vertexShader GL_VERTEX_SHADER
+ frag <- compileOGLShader fragmentShader GL_FRAGMENT_SHADER
+ prog <- compileOGLProgram
+ [ ("position", fromIntegral position)
+ , ("uv", fromIntegral uv)
+ ]
+ [vert, frag]
+ glUseProgram prog
+ -- Get our uniform locations
+ projection <- getUniformLocation prog "projection"
+ modelview <- getUniformLocation prog "modelview"
+ tex <- getUniformLocation prog "tex"
+ -- Generate our string geometry
+ geom <- withExceptT show
+ $ stringTris atlas True "Hi there"
+ let (ps, uvs) = UV.unzip geom
+ -- Buffer the geometry into our attributes
+ textVao <- withVAO $ \vao -> do
+ withBuffers 2 $ \[pbuf, uvbuf] -> do
+ bufferGeometry position pbuf ps
+ bufferGeometry uv uvbuf uvs
+ return vao
+ atlasVao <- withVAO $ \vao -> do
+ withBuffers 2 $ \[pbuf, uvbuf] -> do
+ let V2 w h = fromIntegral
+ <$> atlasTextureSize atlas
+ bufferGeometry position pbuf $ UV.fromList
+ [ V2 0 0, V2 w 0, V2 w h
+ , V2 0 0, V2 w h, V2 0 h
+ ]
+ bufferGeometry uv uvbuf $ UV.fromList
+ [ V2 0 0, V2 1 0, V2 1 1
+ , V2 0 0, V2 1 1, V2 0 1
+ ]
+ return vao
+
+ -- Set our model view transform
+ let mv :: M44 Float
+ mv = mat4Translate (V3 10 100 0)
+ mv2 :: M44 Float
+ mv2 = mv !*! mat4Scale (V3 0.125 0.125 1)
+ -- Forever loop, drawing stuff
+ forever $ do
+ _ <- pollEvents
+ pj :: M44 Float <-
+ orthoProjection <$> get (windowSize w)
+ withBoundTextures [atlasTexture atlas] $ do
+ updateUniform prog projection pj
+ updateUniform prog modelview mv
+ updateUniform prog tex (0 :: Int)
+ drawVAO
+ prog
+ textVao
+ GL_TRIANGLES
+ (fromIntegral $ UV.length ps)
+
+ updateUniform prog modelview mv2
+ drawVAO
+ prog
+ atlasVao
+ GL_TRIANGLES
+ 6
+ glSwapWindow w
A => assets/Neuton-Regular.ttf +0 -0
A => assets/OFL.txt +94 -0
@@ 1,94 @@
+Copyright (c) 2010, 2011, Brian Zick (artistenator@gmail.com www.21326.info),
+with Reserved Font Name "Neuton" "Neuton Italic" "Neuton Cursive"
+
+This Font Software is licensed under the SIL Open Font License, Version 1.1.
+This license is copied below, and is also available with a FAQ at:
+http://scripts.sil.org/OFL
+
+
+-----------------------------------------------------------
+SIL OPEN FONT LICENSE Version 1.1 - 26 February 2007
+-----------------------------------------------------------
+
+PREAMBLE
+The goals of the Open Font License (OFL) are to stimulate worldwide
+development of collaborative font projects, to support the font creation
+efforts of academic and linguistic communities, and to provide a free and
+open framework in which fonts may be shared and improved in partnership
+with others.
+
+The OFL allows the licensed fonts to be used, studied, modified and
+redistributed freely as long as they are not sold by themselves. The
+fonts, including any derivative works, can be bundled, embedded,
+redistributed and/or sold with any software provided that any reserved
+names are not used by derivative works. The fonts and derivatives,
+however, cannot be released under any other type of license. The
+requirement for fonts to remain under this license does not apply
+to any document created using the fonts or their derivatives.
+
+DEFINITIONS
+"Font Software" refers to the set of files released by the Copyright
+Holder(s) under this license and clearly marked as such. This may
+include source files, build scripts and documentation.
+
+"Reserved Font Name" refers to any names specified as such after the
+copyright statement(s).
+
+"Original Version" refers to the collection of Font Software components as
+distributed by the Copyright Holder(s).
+
+"Modified Version" refers to any derivative made by adding to, deleting,
+or substituting -- in part or in whole -- any of the components of the
+Original Version, by changing formats or by porting the Font Software to a
+new environment.
+
+"Author" refers to any designer, engineer, programmer, technical
+writer or other person who contributed to the Font Software.
+
+PERMISSION & CONDITIONS
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of the Font Software, to use, study, copy, merge, embed, modify,
+redistribute, and sell modified and unmodified copies of the Font
+Software, subject to the following conditions:
+
+1) Neither the Font Software nor any of its individual components,
+in Original or Modified Versions, may be sold by itself.
+
+2) Original or Modified Versions of the Font Software may be bundled,
+redistributed and/or sold with any software, provided that each copy
+contains the above copyright notice and this license. These can be
+included either as stand-alone text files, human-readable headers or
+in the appropriate machine-readable metadata fields within text or
+binary files as long as those fields can be easily viewed by the user.
+
+3) No Modified Version of the Font Software may use the Reserved Font
+Name(s) unless explicit written permission is granted by the corresponding
+Copyright Holder. This restriction only applies to the primary font name as
+presented to the users.
+
+4) The name(s) of the Copyright Holder(s) or the Author(s) of the Font
+Software shall not be used to promote, endorse or advertise any
+Modified Version, except to acknowledge the contribution(s) of the
+Copyright Holder(s) and the Author(s) or with their explicit written
+permission.
+
+5) The Font Software, modified or unmodified, in part or in whole,
+must be distributed entirely under this license, and must not be
+distributed under any other license. The requirement for fonts to
+remain under this license does not apply to any document created
+using the Font Software.
+
+TERMINATION
+This license becomes null and void if any of the above conditions are
+not met.
+
+DISCLAIMER
+THE FONT SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT
+OF COPYRIGHT, PATENT, TRADEMARK, OR OTHER RIGHT. IN NO EVENT SHALL THE
+COPYRIGHT HOLDER BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+INCLUDING ANY GENERAL, SPECIAL, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL
+DAMAGES, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+FROM, OUT OF THE USE OR INABILITY TO USE THE FONT SOFTWARE OR FROM
+OTHER DEALINGS IN THE FONT SOFTWARE.
A => package.yaml +61 -0
@@ 1,61 @@
+name: typograffiti
+version: 0.1.0.0
+github: "githubuser/typograffiti"
+license: BSD3
+author: "Author name here"
+maintainer: "example@example.com"
+copyright: "2018 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#readme>
+
+dependencies:
+- base >= 4.7 && < 5
+- bytestring
+- containers
+- freetype2
+- gl
+- linear
+- mtl
+- template-haskell
+- vector
+
+library:
+ source-dirs: src
+
+executables:
+ typograffiti-exe:
+ main: Main.hs
+ source-dirs: app
+ other-modules: Paths_typograffiti
+ ghc-options:
+ - -threaded
+ - -rtsopts
+ - -with-rtsopts=-N
+ dependencies:
+ - filepath
+ - JuicyPixels
+ - sdl2
+ - typograffiti
+
+
+tests:
+ typograffiti-test:
+ main: Spec.hs
+ source-dirs: test
+ ghc-options:
+ - -threaded
+ - -rtsopts
+ - -with-rtsopts=-N
+ dependencies:
+ - typograffiti
A => src/Typograffiti.hs +124 -0
@@ 1,124 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RecordWildCards #-}
+-- |
+-- Module: Gelatin.FreeType2
+-- Copyright: (c) 2017 Schell Scivally
+-- License: MIT
+-- Maintainer: Schell Scivally <schell@takt.com>
+--
+-- This module provides easy freetype2 font rendering using gelatin's
+-- graphics primitives.
+--
+module Typograffiti
+ ( allocAtlas
+ , GlyphSize (..)
+ , TypograffitiError (..)
+ , Atlas (..)
+ , asciiChars
+ , stringTris
+ ) where
+
+import Typograffiti.Atlas
+import Typograffiti.Glyph
+
+
+--------------------------------------------------------------------------------
+-- WordMap
+--------------------------------------------------------------------------------
+
+
+--------------------------------------------------------------------------------
+-- Picture
+--------------------------------------------------------------------------------
+-- | Constructs a 'TexturePictureT' of one word in all red.
+-- V4ization can then be done using 'setReplacementV4' in the picture
+-- computation, or by using 'redChannelReplacement' and passing that to the
+-- renderer after compilation, at render time. Keep in mind that any new word
+-- geometry will be discarded, since this computation does not return a new 'Atlas'.
+-- For that reason it is advised that you load the needed words before using this
+-- function. For loading words, see 'loadWords'.
+--
+-- This is used in 'freetypeFontRendering' to construct the geometry of each word.
+-- 'freetypeFontRendering' goes further and stores these geometries, looking them up
+-- and constructing a string of word renderers for each input 'String'.
+--freetypePicture
+-- :: MonadIO m
+-- => Atlas
+-- -- ^ The 'Atlas' from which to read font textures word geometry.
+-- -> String
+-- -- ^ The word to render.
+-- -> m FontRendering
+-- -- ^ Returns a textured picture computation representing the texture and
+-- -- geometry of the input word.
+--freetypePicture atlas@Atlas{..} str = do
+-- eKerning <- withFreeType (Just atlasLibrary) $ hasKerning atlasFontFace
+-- setTextures [atlasTexture]
+-- let useKerning = either (const False) id eKerning
+-- setGeometry $ triangles $ stringTris atlas useKerning str
+--------------------------------------------------------------------------------
+-- Performance FontRendering
+--------------------------------------------------------------------------------
+-- | Constructs a 'FontRendering' from the given color and string. The 'WordMap'
+-- record of the given 'Atlas' is used to construct the string geometry, greatly
+-- improving performance and allowing longer strings to be compiled and renderered
+-- in real time. To create a new 'Atlas' see 'allocAtlas'.
+--
+-- Note that since word geometries are stored in the 'Atlas' 'WordMap' and multiple
+-- renderers can reference the same 'Atlas', the returned 'FontRendering' contains a
+-- clean up operation that does nothing. It is expected that the programmer
+-- will call 'freeAtlas' manually when the 'Atlas' is no longer needed.
+--freetypeFontRendering
+-- :: MonadIO m
+-- => SomeProgram
+-- -- ^ The V2(backend, to) use for compilation.
+-- -> Atlas
+-- -- ^ The 'Atlas' to read character textures from and load word geometry
+-- -- into.
+-- -> V4 Float
+-- -- ^ The solid color to render the string with.
+-- -> String
+-- -- ^ The string to render.
+-- -- This string can contain newlines, which will be respected.
+-- -> m (FontRendering, V2 Float, Atlas)
+-- -- ^ Returns the 'FontRendering', the size of the text and the new
+-- -- 'Atlas' with the loaded geometry of the string.
+--freetypeFontRendering b atlas0 color str = do
+-- atlas <- loadWords b atlas0 str
+-- let glyphw = glyphWidth $ atlasGlyphSize atlas
+-- spacew = fromMaybe glyphw $ do
+-- metrcs <- IM.lookup (fromEnum ' ') $ atlasMetrics atlas
+-- let (x, _) = glyphAdvance metrcs
+-- return $ fromIntegral x
+-- glyphh = glyphHeight $ atlasGlyphSize atlas
+-- spaceh = glyphh
+-- isWhiteSpace c = c == ' ' || c == '\n' || c == '\t'
+-- renderWord :: [FontTransform] -> V2 Float -> String -> IO ()
+-- renderWord _ _ "" = return ()
+-- renderWord rs (V2 _ y) ('\n':cs) = renderWord rs (V2 0 (y + spaceh)) cs
+-- renderWord rs (V2 x y) (' ':cs) = renderWord rs (V2 (x + spacew) y) cs
+-- renderWord rs (V2 x y) cs = do
+-- let word = takeWhile (not . isWhiteSpace) cs
+-- rest = drop (length word) cs
+-- case M.lookup word (atlasWordMap atlas) of
+-- Nothing -> renderWord rs (V2 x y) rest
+-- Just (V2 w _, r) -> do
+-- let ts = [move x y, redChannelReplacementV4 color]
+-- snd r $ ts ++ rs
+-- renderWord rs (V2 (x + w) y) rest
+-- rr t = renderWord t 0 str
+-- measureString :: (V2 Float, V2 Float) -> String -> (V2 Float, V2 Float)
+-- measureString (V2 x y, V2 w h) "" = (V2 x y, V2 w h)
+-- measureString (V2 x y, V2 w _) (' ':cs) =
+-- let nx = x + spacew in measureString (V2 nx y, V2 (max w nx) y) cs
+-- measureString (V2 x y, V2 w h) ('\n':cs) =
+-- let ny = y + spaceh in measureString (V2 x ny, V2 w (max h ny)) cs
+-- measureString (V2 x y, V2 w h) cs =
+-- let word = takeWhile (not . isWhiteSpace) cs
+-- rest = drop (length word) cs
+-- n = case M.lookup word (atlasWordMap atlas) of
+-- Nothing -> (V2 x y, V2 w h)
+-- Just (V2 ww _, _) -> let nx = x + ww
+-- in (V2 nx y, V2 (max w nx) y)
+-- in measureString n rest
+-- (szw, szh) = snd $ measureString (0,0) str
+-- return ((return (), rr), V2 szw (max spaceh szh), atlas)
A => src/Typograffiti/Atlas.hs +347 -0
@@ 1,347 @@
+{-# 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 easy freetype2 font rendering without having to mess 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.Map (Map)
+import qualified Data.Map as M
+import Data.Vector.Unboxed (Vector)
+import qualified Data.Vector.Unboxed as UV
+import Foreign.Marshal.Utils (with)
+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.
+ deriving (Show, Eq)
+
+
+data SpatialTransform = SpatialTransformTranslate (V2 Float)
+ | SpatialTransformScale (V2 Float)
+ | SpatialTransformRotate Float
+
+
+data FontTransform = FontTransformAlpha Float
+ | FontTransformMultiply (V4 Float)
+ | FontTransformReplaceRed (V4 Float)
+ | FontTransformSpatial SpatialTransform
+
+
+data FontRendering = FontRendering
+ { fontRenderingDraw :: [FontTransform] -> IO ()
+ , fontRenderingRelease :: IO ()
+ , fontRenderingSize :: V2 Int
+ }
+
+
+type WordMap = Map String (V2 Float, FontRendering)
+
+
+--------------------------------------------------------------------------------
+-- Atlas
+--------------------------------------------------------------------------------
+
+
+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 (PixelSize 0 0) ""
+
+
+data AtlasMeasure = AM { amWH :: V2 Int
+ , amXY :: V2 Int
+ , rowHeight :: Int
+ , amMap :: IntMap (V2 Int)
+ } deriving (Show, Eq)
+
+
+emptyAM :: AtlasMeasure
+emptyAM = AM 0 (V2 1 1) 0 mempty
+
+
+spacing :: Int
+spacing = 1
+
+
+measure :: FT_Face -> Int -> AtlasMeasure -> Char -> FreeTypeIO AtlasMeasure
+measure fce maxw am@AM{..} char
+ | Just _ <- IM.lookup (fromEnum char) amMap = return 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
+ , amMap = IM.insert (fromEnum char) amXY amMap
+ }
+ return 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.5) . (* 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 here.
+allocAtlas
+ :: ( MonadIO m
+ , MonadError TypograffitiError m
+ )
+ => FilePath
+ -- ^ 'FilePath' of the 'Font' 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
+ PixelSize w h -> setPixelSizes fce (2*w) (2*h)
+ CharSize w h dpix dpiy -> setCharSize fce (floor $ 26.6 * 2 * w)
+ (floor $ 26.6 * 2 * h)
+ dpix dpiy
+
+ AM{..} <- foldM (measure fce 512) emptyAM str
+
+ let V2 w h = amWH
+ xymap = 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
+
+
+-- | Load a string of words into the 'Atlas'.
+--loadWords
+-- :: MonadIO m
+-- => _program
+-- -- ^ The V2(backend, needed) to render font glyphs.
+-- -> Atlas
+-- -- ^ The atlas to load the words into.
+-- -> String
+-- -- ^ The string of words to load, with each word separated by spaces.
+-- -> m Atlas
+--loadWords b atlas str = do
+-- wm <- liftIO $ foldM loadWord (atlasWordMap atlas) $ words str
+-- return atlas{atlasWordMap=wm}
+-- where loadWord wm word
+-- | M.member word wm = return wm
+-- | otherwise = do
+-- let pic = do freetypePicture atlas word
+-- _pictureSize2 fst
+-- (sz,r) <- _compilePictureT b pic
+-- return $ M.insert word (sz,r) wm
+
+
+-- | Unload any words not contained in the source string.
+--unloadMissingWords
+-- :: MonadIO m
+-- => Atlas
+-- -- ^ The 'Atlas' to unload words from.
+-- -> String
+-- -- ^ The source string.
+-- -> m Atlas
+--unloadMissingWords atlas str = do
+-- let wm = atlasWordMap atlas
+-- ws = M.fromList $ zip (words str) [(0::Int)..]
+-- missing = M.difference wm ws
+-- retain = M.difference wm missing
+-- dealoc = liftIO . fontRenderingRelease . snd
+-- <$> missing
+-- sequence_ dealoc
+-- return atlas{atlasWordMap=retain}
+
+
+-- | Construct the geometry needed to render the given character.
+makeCharQuad
+ :: ( MonadIO m
+ , 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 . (/(64::Double)) . fromIntegral . fst) e
+ _ -> return $ fromIntegral penx
+ case IM.lookup ichar atlasMetrics of
+ Nothing -> throwError $ TypograffitiErrorNoGlyphMetricsForChar char -- return (penx, mndx)
+ 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)
A => src/Typograffiti/GL.hs +337 -0
@@ 1,337 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE LambdaCase #-}
+module Typograffiti.GL where
+
+import Control.Exception (assert)
+import Control.Monad (forM_, when)
+import Control.Monad.Except (MonadError (..))
+import Control.Monad.IO.Class (MonadIO (..))
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Char8 as B8
+import qualified Data.Foldable as F
+import qualified Data.Vector.Storable as SV
+import Data.Vector.Unboxed (Unbox)
+import qualified Data.Vector.Unboxed as UV
+import Foreign.C.String (peekCAStringLen, withCString)
+import Foreign.Marshal.Array
+import Foreign.Marshal.Utils
+import Foreign.Ptr
+import Foreign.Storable
+import GHC.TypeLits (KnownNat)
+import Graphics.GL.Core32
+import Graphics.GL.Types
+import Linear
+import Linear.V (Finite, Size, dim, toV)
+
+
+
+allocAndActivateTex :: GLenum -> IO GLuint
+allocAndActivateTex u = do
+ [t] <- allocaArray 1 $ \ptr -> do
+ glGenTextures 1 ptr
+ peekArray 1 ptr
+ glActiveTexture u
+ glBindTexture GL_TEXTURE_2D t
+ return t
+
+
+clearErrors :: String -> IO ()
+clearErrors str = do
+ err' <- glGetError
+ when (err' /= 0) $ do
+ putStrLn $ unwords [str, show err']
+ assert False $ return ()
+
+
+withVAO :: MonadIO m => (GLuint -> IO b) -> m b
+withVAO f = liftIO $ do
+ [vao] <- allocaArray 1 $ \ptr -> do
+ glGenVertexArrays 1 ptr
+ peekArray 1 ptr
+ glBindVertexArray vao
+ r <- f vao
+ clearErrors "withVAO"
+ glBindVertexArray 0
+ return r
+
+
+withBuffers :: Int -> ([GLuint] -> IO b) -> IO b
+withBuffers n f = do
+ bufs <- allocaArray n $ \ptr -> do
+ glGenBuffers (fromIntegral n) ptr
+ peekArray (fromIntegral n) ptr
+ f bufs
+
+
+-- | Buffer some geometry into an attribute.
+-- The type variable 'f' should be V0, V1, V2, V3 or V4.
+bufferGeometry
+ :: ( Foldable f
+ , Unbox (f Float)
+ , Storable (f Float)
+ , Finite f
+ , KnownNat (Size f)
+ )
+ => GLuint
+ -- ^ The attribute location.
+ -> GLuint
+ -- ^ The buffer identifier.
+ -> UV.Vector (f Float)
+ -- ^ The geometry to buffer.
+ -> IO ()
+bufferGeometry loc buf as
+ | UV.null as = return ()
+ | otherwise = do
+ let v = UV.head as
+ asize = UV.length as * sizeOf v
+ n = fromIntegral $ dim $ toV v
+ glBindBuffer GL_ARRAY_BUFFER buf
+ SV.unsafeWith (convertVec as) $ \ptr ->
+ glBufferData GL_ARRAY_BUFFER (fromIntegral asize) (castPtr ptr) GL_STATIC_DRAW
+ glEnableVertexAttribArray loc
+ glVertexAttribPointer loc n GL_FLOAT GL_FALSE 0 nullPtr
+ clearErrors "bufferGeometry"
+
+
+convertVec
+ :: (Unbox (f Float), Foldable f) => UV.Vector (f Float) -> SV.Vector GLfloat
+convertVec =
+ SV.convert . UV.map realToFrac . UV.concatMap (UV.fromList . F.toList)
+
+
+-- | Binds the given textures to GL_TEXTURE0, GL_TEXTURE1, ... in ascending
+-- order of the texture unit, runs the IO action and then unbinds the textures.
+withBoundTextures :: MonadIO m => [GLuint] -> m a -> m a
+withBoundTextures ts f = do
+ liftIO $ mapM_ (uncurry bindTex) (zip ts [GL_TEXTURE0 ..])
+ a <- f
+ liftIO $ glBindTexture GL_TEXTURE_2D 0
+ return a
+ where bindTex tex u = glActiveTexture u >> glBindTexture GL_TEXTURE_2D tex
+
+
+drawVAO
+ :: MonadIO m
+ => GLuint
+ -- ^ The program
+ -> GLuint
+ -- ^ The vao
+ -> GLenum
+ -- ^ The draw mode
+ -> GLsizei
+ -- ^ The number of vertices to draw
+ -> m ()
+drawVAO program vao mode num = liftIO $ do
+ glUseProgram program
+ glBindVertexArray vao
+ clearErrors "drawBuffer:glBindVertex"
+ glDrawArrays mode 0 num
+ clearErrors "drawBuffer:glDrawArrays"
+
+
+compileOGLShader
+ :: (MonadIO m, MonadError String m)
+ => ByteString
+ -- ^ The shader source
+ -> GLenum
+ -- ^ The shader type (vertex, frag, etc)
+ -> m GLuint
+ -- ^ Either an error message or the generated shader handle.
+compileOGLShader src shType = do
+ shader <- liftIO $ glCreateShader shType
+ if shader == 0
+ then throwError "Could not create shader"
+ else do
+ success <- liftIO $ do
+ withCString (B8.unpack src) $ \ptr ->
+ with ptr $ \ptrptr -> glShaderSource shader 1 ptrptr nullPtr
+
+ glCompileShader shader
+ with (0 :: GLint) $ \ptr -> do
+ glGetShaderiv shader GL_COMPILE_STATUS ptr
+ peek ptr
+
+ if success == GL_FALSE
+ then do
+ err <- liftIO $ do
+ infoLog <- with (0 :: GLint) $ \ptr -> do
+ glGetShaderiv shader GL_INFO_LOG_LENGTH ptr
+ logsize <- peek ptr
+ allocaArray (fromIntegral logsize) $ \logptr -> do
+ glGetShaderInfoLog shader logsize nullPtr logptr
+ peekArray (fromIntegral logsize) logptr
+
+ return $ unlines [ "Could not compile shader:"
+ , B8.unpack src
+ , map (toEnum . fromEnum) infoLog
+ ]
+ throwError err
+ else return shader
+
+
+compileOGLProgram
+ :: ( MonadIO m
+ , MonadError String m
+ )
+ => [(String, Integer)]
+ -> [GLuint]
+ -> m GLuint
+compileOGLProgram attribs shaders = do
+ (program, success) <- liftIO $ do
+ program <- glCreateProgram
+ forM_ shaders (glAttachShader program)
+ forM_ attribs
+ $ \(name, loc) ->
+ withCString name
+ $ glBindAttribLocation program
+ $ fromIntegral loc
+ glLinkProgram program
+
+ success <- with (0 :: GLint) $ \ptr -> do
+ glGetProgramiv program GL_LINK_STATUS ptr
+ peek ptr
+ return (program, success)
+
+ if success == GL_FALSE
+ then do
+ err <- liftIO $ with (0 :: GLint) $ \ptr -> do
+ glGetProgramiv program GL_INFO_LOG_LENGTH ptr
+ logsize <- peek ptr
+ infoLog <- allocaArray (fromIntegral logsize) $ \logptr -> do
+ glGetProgramInfoLog program logsize nullPtr logptr
+ peekArray (fromIntegral logsize) logptr
+ return $ unlines [ "Could not link program"
+ , map (toEnum . fromEnum) infoLog
+ ]
+ throwError err
+ else do
+ liftIO $ forM_ shaders glDeleteShader
+ return program
+
+
+orthoProjection
+ :: Integral a
+ => V2 a
+ -- ^ The window width and height
+ -> M44 Float
+orthoProjection (V2 ww wh) =
+ let (hw,hh) = (fromIntegral ww, fromIntegral wh)
+ in ortho 0 hw hh 0 0 1
+
+
+--------------------------------------------------------------------------------
+-- Uniform marshaling functions
+--------------------------------------------------------------------------------
+
+
+getUniformLocation :: MonadIO m => GLuint -> String -> m GLint
+getUniformLocation program ident = liftIO
+ $ withCString ident
+ $ glGetUniformLocation program
+
+
+class UniformValue a where
+ updateUniform
+ :: MonadIO m
+ => GLuint
+ -- ^ The program
+ -> GLint
+ -- ^ The uniform location
+ -> a
+ -- ^ The value.
+ -> m ()
+
+
+clearUniformUpdateError :: Show a => GLuint -> GLint -> a -> IO ()
+clearUniformUpdateError prog loc val = glGetError >>= \case
+ 0 -> return ()
+ e -> do
+ let buf = replicate 256 ' '
+ ident <- withCString buf
+ $ \strptr -> with 0
+ $ \szptr -> do
+ glGetActiveUniformName prog (fromIntegral loc) 256 szptr strptr
+ sz <- peek szptr
+ peekCAStringLen (strptr, fromIntegral sz)
+ putStrLn $ unwords [ "Could not update uniform"
+ , ident
+ , "with value"
+ , show val
+ , ", encountered error (" ++ show e ++ ")"
+ , show (GL_INVALID_OPERATION :: Integer, "invalid operation" :: String)
+ , show (GL_INVALID_VALUE :: Integer, "invalid value" :: String)
+ ]
+ assert False $ return ()
+
+
+instance UniformValue Bool where
+ updateUniform p loc bool = liftIO $ do
+ glUniform1i loc $ if bool then 1 else 0
+ clearUniformUpdateError p loc bool
+
+instance UniformValue Int where
+ updateUniform p loc enum = liftIO $ do
+ glUniform1i loc $ fromIntegral $ fromEnum enum
+ clearUniformUpdateError p loc enum
+
+instance UniformValue Float where
+ updateUniform p loc float = liftIO $ do
+ glUniform1f loc $ realToFrac float
+ clearUniformUpdateError p loc float
+
+instance UniformValue Double where
+ updateUniform p loc d = liftIO $ do
+ glUniform1f loc $ realToFrac d
+ clearUniformUpdateError p loc d
+
+instance UniformValue (V2 Float) where
+ updateUniform p loc v = liftIO $ do
+ let V2 x y = fmap realToFrac v
+ glUniform2f loc x y
+ clearUniformUpdateError p loc v
+
+instance UniformValue (V3 Float) where
+ updateUniform p loc v = liftIO $ do
+ let V3 x y z = fmap realToFrac v
+ glUniform3f loc x y z
+ clearUniformUpdateError p loc v
+
+instance UniformValue (V4 Float) where
+ updateUniform p loc v = liftIO $ do
+ let (V4 r g b a) = realToFrac <$> v
+ glUniform4f loc r g b a
+ clearUniformUpdateError p loc v
+
+instance UniformValue (M44 Float) where
+ updateUniform p loc val = liftIO $ do
+ with val $ glUniformMatrix4fv loc 1 GL_TRUE . castPtr
+ clearUniformUpdateError p loc val
+
+instance UniformValue (V2 Int) where
+ updateUniform p loc v = liftIO $ do
+ let V2 x y = fmap fromIntegral v
+ glUniform2i loc x y
+ clearUniformUpdateError p loc v
+
+instance UniformValue (Int,Int) where
+ updateUniform p loc = updateUniform p loc . uncurry V2
+
+
+--------------------------------------------------------------------------------
+-- Matrix helpers
+--------------------------------------------------------------------------------
+
+
+mat4Translate :: Num a => V3 a -> M44 a
+mat4Translate = mkTransformationMat identity
+
+mat4Rotate :: (Num a, Epsilon a, Floating a) => a -> V3 a -> M44 a
+mat4Rotate phi v = mkTransformation (axisAngle v phi) (V3 0 0 0)
+
+mat4Scale :: Num a => V3 a -> M44 a
+mat4Scale (V3 x y z) =
+ V4 (V4 x 0 0 0)
+ (V4 0 y 0 0)
+ (V4 0 0 z 0)
+ (V4 0 0 0 1)
A => src/Typograffiti/Glyph.hs +30 -0
@@ 1,30 @@
+module Typograffiti.Glyph where
+
+
+import Linear
+
+
+data GlyphSize = CharSize Float Float Int Int
+ | PixelSize Int Int
+ deriving (Show, Eq, Ord)
+
+
+glyphWidth :: GlyphSize -> Float
+glyphWidth (CharSize x y _ _) = if x == 0 then y else x
+glyphWidth (PixelSize x y) = fromIntegral $ if x == 0 then y else x
+
+
+glyphHeight :: GlyphSize -> Float
+glyphHeight (CharSize x y _ _) = if y == 0 then x else y
+glyphHeight (PixelSize x y) = fromIntegral $ if y == 0 then x else y
+
+
+-- | https://www.freetype.org/freetype2/docs/tutorial/step2.html
+data GlyphMetrics = GlyphMetrics
+ { glyphTexBB :: (V2 Int, V2 Int)
+ , glyphTexSize :: V2 Int
+ , glyphSize :: V2 Int
+ , glyphHoriBearing :: V2 Int
+ , glyphVertBearing :: V2 Int
+ , glyphAdvance :: V2 Int
+ } deriving (Show, Eq)
A => src/Typograffiti/Utils.hs +129 -0
@@ 1,129 @@
+{-# 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_Sizess" $ 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
+ liftIO $ print ("v", vx, vy)
+ return (fromIntegral vx, fromIntegral vy)
A => stack.yaml +65 -0
@@ 1,65 @@
+# 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
+# resolver: ghcjs-0.1.0_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: lts-12.10
+
+# 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
+# - location:
+# git: https://github.com/commercialhaskell/stack.git
+# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+# subdirs:
+# - auto-update
+# - wai
+packages:
+- .
+# 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)
+# 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.7"
+#
+# 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<
\ No newline at end of file
A => test/Spec.hs +2 -0
@@ 1,2 @@
+main :: IO ()
+main = putStrLn "Test suite not yet implemented"