{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
module Typograffiti.Atlas where
import Control.Exception (try)
import Control.Monad
import Control.Monad.Except (MonadError (..))
import Control.Monad.Fail (MonadFail (..))
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 (GLuint)
import FreeType.Core.Base
import FreeType.Core.Types as BM
import FreeType.Exception (FtError (..))
import Linear (V2 (..))
import Data.Int (Int32)
import Data.Word (Word32)
import Data.Text.Glyphize (GlyphInfo (..), GlyphPos (..))
import Foreign.Storable (peek)
import Foreign.Ptr (castPtr)
import Foreign.C.String (withCString)
import Typograffiti.GL
data TypograffitiError =
TypograffitiErrorNoMetricsForGlyph Int
| TypograffitiErrorFreetype String Int32
| TypograffitiErrorGL String
deriving (Int -> TypograffitiError -> ShowS
[TypograffitiError] -> ShowS
TypograffitiError -> String
(Int -> TypograffitiError -> ShowS)
-> (TypograffitiError -> String)
-> ([TypograffitiError] -> ShowS)
-> Show TypograffitiError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TypograffitiError] -> ShowS
$cshowList :: [TypograffitiError] -> ShowS
show :: TypograffitiError -> String
$cshow :: TypograffitiError -> String
showsPrec :: Int -> TypograffitiError -> ShowS
$cshowsPrec :: Int -> TypograffitiError -> ShowS
Show, TypograffitiError -> TypograffitiError -> Bool
(TypograffitiError -> TypograffitiError -> Bool)
-> (TypograffitiError -> TypograffitiError -> Bool)
-> Eq TypograffitiError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TypograffitiError -> TypograffitiError -> Bool
$c/= :: TypograffitiError -> TypograffitiError -> Bool
== :: TypograffitiError -> TypograffitiError -> Bool
$c== :: TypograffitiError -> TypograffitiError -> Bool
Eq)
data GlyphMetrics = GlyphMetrics {
GlyphMetrics -> (V2 Int, V2 Int)
glyphTexBB :: (V2 Int, V2 Int),
GlyphMetrics -> V2 Int
glyphSize :: V2 Int,
GlyphMetrics -> V2 Int
glyphOffset :: V2 Int
} deriving (Int -> GlyphMetrics -> ShowS
[GlyphMetrics] -> ShowS
GlyphMetrics -> String
(Int -> GlyphMetrics -> ShowS)
-> (GlyphMetrics -> String)
-> ([GlyphMetrics] -> ShowS)
-> Show GlyphMetrics
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GlyphMetrics] -> ShowS
$cshowList :: [GlyphMetrics] -> ShowS
show :: GlyphMetrics -> String
$cshow :: GlyphMetrics -> String
showsPrec :: Int -> GlyphMetrics -> ShowS
$cshowsPrec :: Int -> GlyphMetrics -> ShowS
Show, GlyphMetrics -> GlyphMetrics -> Bool
(GlyphMetrics -> GlyphMetrics -> Bool)
-> (GlyphMetrics -> GlyphMetrics -> Bool) -> Eq GlyphMetrics
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GlyphMetrics -> GlyphMetrics -> Bool
$c/= :: GlyphMetrics -> GlyphMetrics -> Bool
== :: GlyphMetrics -> GlyphMetrics -> Bool
$c== :: GlyphMetrics -> GlyphMetrics -> Bool
Eq)
data Atlas = Atlas {
Atlas -> GLuint
atlasTexture :: GLuint,
Atlas -> V2 Int
atlasTextureSize :: V2 Int,
Atlas -> IntMap GlyphMetrics
atlasMetrics :: IntMap GlyphMetrics,
Atlas -> (Float, Float)
atlasScale :: (Float, Float)
} deriving (Int -> Atlas -> ShowS
[Atlas] -> ShowS
Atlas -> String
(Int -> Atlas -> ShowS)
-> (Atlas -> String) -> ([Atlas] -> ShowS) -> Show Atlas
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Atlas] -> ShowS
$cshowList :: [Atlas] -> ShowS
show :: Atlas -> String
$cshow :: Atlas -> String
showsPrec :: Int -> Atlas -> ShowS
$cshowsPrec :: Int -> Atlas -> ShowS
Show)
emptyAtlas :: GLuint -> Atlas
emptyAtlas :: GLuint -> Atlas
emptyAtlas GLuint
t = GLuint -> V2 Int -> IntMap GlyphMetrics -> (Float, Float) -> Atlas
Atlas GLuint
t V2 Int
0 IntMap GlyphMetrics
forall a. Monoid a => a
mempty (Float
0, Float
0)
data AtlasMeasure = AM {
AtlasMeasure -> V2 Int
amWH :: V2 Int,
AtlasMeasure -> V2 Int
amXY :: V2 Int,
AtlasMeasure -> Int
rowHeight :: Int,
AtlasMeasure -> IntMap (V2 Int)
amMap :: IntMap (V2 Int)
} deriving (Int -> AtlasMeasure -> ShowS
[AtlasMeasure] -> ShowS
AtlasMeasure -> String
(Int -> AtlasMeasure -> ShowS)
-> (AtlasMeasure -> String)
-> ([AtlasMeasure] -> ShowS)
-> Show AtlasMeasure
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AtlasMeasure] -> ShowS
$cshowList :: [AtlasMeasure] -> ShowS
show :: AtlasMeasure -> String
$cshow :: AtlasMeasure -> String
showsPrec :: Int -> AtlasMeasure -> ShowS
$cshowsPrec :: Int -> AtlasMeasure -> ShowS
Show, AtlasMeasure -> AtlasMeasure -> Bool
(AtlasMeasure -> AtlasMeasure -> Bool)
-> (AtlasMeasure -> AtlasMeasure -> Bool) -> Eq AtlasMeasure
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AtlasMeasure -> AtlasMeasure -> Bool
$c/= :: AtlasMeasure -> AtlasMeasure -> Bool
== :: AtlasMeasure -> AtlasMeasure -> Bool
$c== :: AtlasMeasure -> AtlasMeasure -> Bool
Eq)
emptyAM :: AtlasMeasure
emptyAM :: AtlasMeasure
emptyAM = V2 Int -> V2 Int -> Int -> IntMap (V2 Int) -> AtlasMeasure
AM V2 Int
0 (Int -> Int -> V2 Int
forall a. a -> a -> V2 a
V2 Int
1 Int
1) Int
0 IntMap (V2 Int)
forall a. Monoid a => a
mempty
spacing :: Int
spacing :: Int
spacing = Int
1
type GlyphRetriever m = Word32 -> m (FT_Bitmap, FT_Glyph_Metrics)
glyphRetriever :: (MonadIO m, MonadError TypograffitiError m) => FT_Face -> GlyphRetriever m
glyphRetriever :: forall (m :: * -> *).
(MonadIO m, MonadError TypograffitiError m) =>
FT_Face -> GlyphRetriever m
glyphRetriever FT_Face
font GLuint
glyph = do
IO () -> m ()
forall (m :: * -> *) a.
(MonadIO m, MonadError TypograffitiError m) =>
IO a -> m a
liftFreetype (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FT_Face -> GLuint -> Int32 -> IO ()
ft_Load_Glyph FT_Face
font (Int -> GLuint
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> GLuint) -> Int -> GLuint
forall a b. (a -> b) -> a -> b
$ GLuint -> Int
forall a. Enum a => a -> Int
fromEnum GLuint
glyph) Int32
forall a. (Eq a, Num a) => a
FT_LOAD_RENDER
FT_FaceRec
font' <- IO FT_FaceRec -> m FT_FaceRec
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FT_FaceRec -> m FT_FaceRec) -> IO FT_FaceRec -> m FT_FaceRec
forall a b. (a -> b) -> a -> b
$ FT_Face -> IO FT_FaceRec
forall a. Storable a => Ptr a -> IO a
peek FT_Face
font
FT_GlyphSlotRec
slot <- IO FT_GlyphSlotRec -> m FT_GlyphSlotRec
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FT_GlyphSlotRec -> m FT_GlyphSlotRec)
-> IO FT_GlyphSlotRec -> m FT_GlyphSlotRec
forall a b. (a -> b) -> a -> b
$ Ptr FT_GlyphSlotRec -> IO FT_GlyphSlotRec
forall a. Storable a => Ptr a -> IO a
peek (Ptr FT_GlyphSlotRec -> IO FT_GlyphSlotRec)
-> Ptr FT_GlyphSlotRec -> IO FT_GlyphSlotRec
forall a b. (a -> b) -> a -> b
$ FT_FaceRec -> Ptr FT_GlyphSlotRec
frGlyph FT_FaceRec
font'
(FT_Bitmap, FT_Glyph_Metrics) -> m (FT_Bitmap, FT_Glyph_Metrics)
forall (m :: * -> *) a. Monad m => a -> m a
return (FT_GlyphSlotRec -> FT_Bitmap
gsrBitmap FT_GlyphSlotRec
slot, FT_GlyphSlotRec -> FT_Glyph_Metrics
gsrMetrics FT_GlyphSlotRec
slot)
measure :: (MonadIO m, MonadError TypograffitiError m) =>
GlyphRetriever m -> Int -> AtlasMeasure -> Word32 -> m AtlasMeasure
measure :: forall (m :: * -> *).
(MonadIO m, MonadError TypograffitiError m) =>
GlyphRetriever m -> Int -> AtlasMeasure -> GLuint -> m AtlasMeasure
measure GlyphRetriever m
cb Int
maxw am :: AtlasMeasure
am@AM{Int
V2 Int
IntMap (V2 Int)
amMap :: IntMap (V2 Int)
rowHeight :: Int
amXY :: V2 Int
amWH :: V2 Int
amMap :: AtlasMeasure -> IntMap (V2 Int)
rowHeight :: AtlasMeasure -> Int
amXY :: AtlasMeasure -> V2 Int
amWH :: AtlasMeasure -> V2 Int
..} GLuint
glyph
| Just V2 Int
_ <- Int -> IntMap (V2 Int) -> Maybe (V2 Int)
forall a. Int -> IntMap a -> Maybe a
IM.lookup (GLuint -> Int
forall a. Enum a => a -> Int
fromEnum GLuint
glyph) IntMap (V2 Int)
amMap = AtlasMeasure -> m AtlasMeasure
forall (m :: * -> *) a. Monad m => a -> m a
return AtlasMeasure
am
| Bool
otherwise = do
let V2 Int
x Int
y = V2 Int
amXY
V2 Int
w Int
h = V2 Int
amWH
(FT_Bitmap
bmp, FT_Glyph_Metrics
_) <- GlyphRetriever m
cb GLuint
glyph
let bw :: Int
bw = GLuint -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (GLuint -> Int) -> GLuint -> Int
forall a b. (a -> b) -> a -> b
$ FT_Bitmap -> GLuint
bWidth FT_Bitmap
bmp
bh :: Int
bh = GLuint -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (GLuint -> Int) -> GLuint -> Int
forall a b. (a -> b) -> a -> b
$ FT_Bitmap -> GLuint
bRows FT_Bitmap
bmp
gotoNextRow :: Bool
gotoNextRow = (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
bw Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
spacing Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
maxw)
rh :: Int
rh = if Bool
gotoNextRow then Int
0 else Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
bh Int
rowHeight
nx :: Int
nx = if Bool
gotoNextRow then Int
0 else Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
bw Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
spacing
nw :: Int
nw = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
w (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
bw Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
spacing)
nh :: Int
nh = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
h (Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
rh Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
spacing)
ny :: Int
ny = if Bool
gotoNextRow then Int
nh else Int
y
am :: AtlasMeasure
am = AM :: V2 Int -> V2 Int -> Int -> IntMap (V2 Int) -> AtlasMeasure
AM {
amWH :: V2 Int
amWH = Int -> Int -> V2 Int
forall a. a -> a -> V2 a
V2 Int
nw Int
nh,
amXY :: V2 Int
amXY = Int -> Int -> V2 Int
forall a. a -> a -> V2 a
V2 Int
nx Int
ny,
rowHeight :: Int
rowHeight = Int
rh,
amMap :: IntMap (V2 Int)
amMap = Int -> V2 Int -> IntMap (V2 Int) -> IntMap (V2 Int)
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert (GLuint -> Int
forall a. Enum a => a -> Int
fromEnum GLuint
glyph) V2 Int
amXY IntMap (V2 Int)
amMap
}
AtlasMeasure -> m AtlasMeasure
forall (m :: * -> *) a. Monad m => a -> m a
return AtlasMeasure
am
texturize :: (MonadIO m, MonadError TypograffitiError m) =>
GlyphRetriever m -> IntMap (V2 Int) -> Atlas -> Word32 -> m Atlas
texturize :: forall (m :: * -> *).
(MonadIO m, MonadError TypograffitiError m) =>
GlyphRetriever m -> IntMap (V2 Int) -> Atlas -> GLuint -> m Atlas
texturize GlyphRetriever m
cb IntMap (V2 Int)
xymap atlas :: Atlas
atlas@Atlas{GLuint
(Float, Float)
V2 Int
IntMap GlyphMetrics
atlasScale :: (Float, Float)
atlasMetrics :: IntMap GlyphMetrics
atlasTextureSize :: V2 Int
atlasTexture :: GLuint
atlasScale :: Atlas -> (Float, Float)
atlasMetrics :: Atlas -> IntMap GlyphMetrics
atlasTextureSize :: Atlas -> V2 Int
atlasTexture :: Atlas -> GLuint
..} GLuint
glyph
| Just pos :: V2 Int
pos@(V2 Int
x Int
y) <- Int -> IntMap (V2 Int) -> Maybe (V2 Int)
forall a. Int -> IntMap a -> Maybe a
IM.lookup (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ GLuint -> Int
forall a. Enum a => a -> Int
fromEnum GLuint
glyph) IntMap (V2 Int)
xymap = do
(FT_Bitmap
bmp, FT_Glyph_Metrics
metrics) <- GlyphRetriever m
cb GLuint
glyph
GLuint
-> Int32
-> Int32
-> Int32
-> Int32
-> Int32
-> GLuint
-> GLuint
-> Ptr ()
-> m ()
forall (m :: * -> *).
MonadIO m =>
GLuint
-> Int32
-> Int32
-> Int32
-> Int32
-> Int32
-> GLuint
-> GLuint
-> Ptr ()
-> m ()
glTexSubImage2D GLuint
forall a. (Eq a, Num a) => a
GL_TEXTURE_2D Int32
0
(Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x) (Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
y)
(GLuint -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (GLuint -> Int32) -> GLuint -> Int32
forall a b. (a -> b) -> a -> b
$ FT_Bitmap -> GLuint
bWidth FT_Bitmap
bmp) (GLuint -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (GLuint -> Int32) -> GLuint -> Int32
forall a b. (a -> b) -> a -> b
$ FT_Bitmap -> GLuint
bRows FT_Bitmap
bmp)
GLuint
forall a. (Eq a, Num a) => a
GL_RED GLuint
forall a. (Eq a, Num a) => a
GL_UNSIGNED_BYTE
(Ptr Word8 -> Ptr ()
forall a b. Ptr a -> Ptr b
castPtr (Ptr Word8 -> Ptr ()) -> Ptr Word8 -> Ptr ()
forall a b. (a -> b) -> a -> b
$ FT_Bitmap -> Ptr Word8
bBuffer FT_Bitmap
bmp)
let vecwh :: V2 Int
vecwh = GLuint -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (GLuint -> Int) -> V2 GLuint -> V2 Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GLuint -> GLuint -> V2 GLuint
forall a. a -> a -> V2 a
V2 (FT_Bitmap -> GLuint
bWidth FT_Bitmap
bmp) (FT_Bitmap -> GLuint
bRows FT_Bitmap
bmp)
canon :: FT_Pos -> Int
canon = Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double -> Int) -> (FT_Pos -> Double) -> FT_Pos -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
0.5) (Double -> Double) -> (FT_Pos -> Double) -> FT_Pos -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
0.015625) (Double -> Double) -> (FT_Pos -> Double) -> FT_Pos -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Integer -> Double) -> (FT_Pos -> Integer) -> FT_Pos -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FT_Pos -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral
vecsz :: V2 Int
vecsz = FT_Pos -> Int
canon (FT_Pos -> Int) -> V2 FT_Pos -> V2 Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FT_Pos -> FT_Pos -> V2 FT_Pos
forall a. a -> a -> V2 a
V2 (FT_Glyph_Metrics -> FT_Pos
gmWidth FT_Glyph_Metrics
metrics) (FT_Glyph_Metrics -> FT_Pos
gmHeight FT_Glyph_Metrics
metrics)
vecxb :: V2 Int
vecxb = FT_Pos -> Int
canon (FT_Pos -> Int) -> V2 FT_Pos -> V2 Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FT_Pos -> FT_Pos -> V2 FT_Pos
forall a. a -> a -> V2 a
V2 (FT_Glyph_Metrics -> FT_Pos
gmHoriBearingX FT_Glyph_Metrics
metrics) (FT_Glyph_Metrics -> FT_Pos
gmHoriBearingY FT_Glyph_Metrics
metrics)
mtrcs :: GlyphMetrics
mtrcs = GlyphMetrics :: (V2 Int, V2 Int) -> V2 Int -> V2 Int -> GlyphMetrics
GlyphMetrics {
glyphTexBB :: (V2 Int, V2 Int)
glyphTexBB = (V2 Int
pos, V2 Int
pos V2 Int -> V2 Int -> V2 Int
forall a. Num a => a -> a -> a
+ V2 Int
vecwh),
glyphSize :: V2 Int
glyphSize = V2 Int
vecsz,
glyphOffset :: V2 Int
glyphOffset = V2 Int
vecxb
}
Atlas -> m Atlas
forall (m :: * -> *) a. Monad m => a -> m a
return Atlas
atlas { atlasMetrics :: IntMap GlyphMetrics
atlasMetrics = Int -> GlyphMetrics -> IntMap GlyphMetrics -> IntMap GlyphMetrics
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert (GLuint -> Int
forall a. Enum a => a -> Int
fromEnum GLuint
glyph) GlyphMetrics
mtrcs IntMap GlyphMetrics
atlasMetrics }
| Bool
otherwise = do
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String
"Cound not find glyph " String -> ShowS
forall a. [a] -> [a] -> [a]
++ GLuint -> String
forall a. Show a => a -> String
show GLuint
glyph)
Atlas -> m Atlas
forall (m :: * -> *) a. Monad m => a -> m a
return Atlas
atlas
allocAtlas :: (MonadIO m, MonadFail m, MonadError TypograffitiError m) =>
GlyphRetriever m -> [Word32] -> (Float, Float) -> m Atlas
allocAtlas :: forall (m :: * -> *).
(MonadIO m, MonadFail m, MonadError TypograffitiError m) =>
GlyphRetriever m -> [GLuint] -> (Float, Float) -> m Atlas
allocAtlas GlyphRetriever m
cb [GLuint]
glyphs (Float, Float)
scale = do
AM {Int
V2 Int
IntMap (V2 Int)
amMap :: IntMap (V2 Int)
rowHeight :: Int
amXY :: V2 Int
amWH :: V2 Int
amMap :: AtlasMeasure -> IntMap (V2 Int)
rowHeight :: AtlasMeasure -> Int
amXY :: AtlasMeasure -> V2 Int
amWH :: AtlasMeasure -> V2 Int
..} <- (AtlasMeasure -> GLuint -> m AtlasMeasure)
-> AtlasMeasure -> [GLuint] -> m AtlasMeasure
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (GlyphRetriever m -> Int -> AtlasMeasure -> GLuint -> m AtlasMeasure
forall (m :: * -> *).
(MonadIO m, MonadError TypograffitiError m) =>
GlyphRetriever m -> Int -> AtlasMeasure -> GLuint -> m AtlasMeasure
measure GlyphRetriever m
cb Int
512) AtlasMeasure
emptyAM [GLuint]
glyphs
let V2 Int
w Int
h = V2 Int
amWH
xymap :: IntMap (V2 Int)
xymap = IntMap (V2 Int)
amMap
GLuint
t <- GLuint -> m GLuint
forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
GLuint -> m GLuint
allocAndActivateTex GLuint
0
GLuint -> Int32 -> m ()
forall (m :: * -> *). MonadIO m => GLuint -> Int32 -> m ()
glPixelStorei GLuint
forall a. (Eq a, Num a) => a
GL_UNPACK_ALIGNMENT Int32
1
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> (CString -> IO ()) -> IO ()
forall a. String -> (CString -> IO a) -> IO a
withCString (Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
h) (Char -> String) -> Char -> String
forall a b. (a -> b) -> a -> b
$ Int -> Char
forall a. Enum a => Int -> a
toEnum Int
0) ((CString -> IO ()) -> IO ()) -> (CString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
GLuint
-> Int32
-> Int32
-> Int32
-> Int32
-> Int32
-> GLuint
-> GLuint
-> Ptr ()
-> IO ()
forall (m :: * -> *).
MonadIO m =>
GLuint
-> Int32
-> Int32
-> Int32
-> Int32
-> Int32
-> GLuint
-> GLuint
-> Ptr ()
-> m ()
glTexImage2D GLuint
forall a. (Eq a, Num a) => a
GL_TEXTURE_2D Int32
0 Int32
forall a. (Eq a, Num a) => a
GL_RED (Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w) (Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h)
Int32
0 GLuint
forall a. (Eq a, Num a) => a
GL_RED GLuint
forall a. (Eq a, Num a) => a
GL_UNSIGNED_BYTE (Ptr () -> IO ()) -> (CString -> Ptr ()) -> CString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CString -> Ptr ()
forall a b. Ptr a -> Ptr b
castPtr
Atlas
atlas <- (Atlas -> GLuint -> m Atlas) -> Atlas -> [GLuint] -> m Atlas
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (GlyphRetriever m -> IntMap (V2 Int) -> Atlas -> GLuint -> m Atlas
forall (m :: * -> *).
(MonadIO m, MonadError TypograffitiError m) =>
GlyphRetriever m -> IntMap (V2 Int) -> Atlas -> GLuint -> m Atlas
texturize GlyphRetriever m
cb IntMap (V2 Int)
xymap) (GLuint -> Atlas
emptyAtlas GLuint
t) [GLuint]
glyphs
GLuint -> m ()
forall (m :: * -> *). MonadIO m => GLuint -> m ()
glGenerateMipmap GLuint
forall a. (Eq a, Num a) => a
GL_TEXTURE_2D
GLuint -> GLuint -> Int32 -> m ()
forall (m :: * -> *).
MonadIO m =>
GLuint -> GLuint -> Int32 -> m ()
glTexParameteri GLuint
forall a. (Eq a, Num a) => a
GL_TEXTURE_2D GLuint
forall a. (Eq a, Num a) => a
GL_TEXTURE_WRAP_S Int32
forall a. (Eq a, Num a) => a
GL_REPEAT
GLuint -> GLuint -> Int32 -> m ()
forall (m :: * -> *).
MonadIO m =>
GLuint -> GLuint -> Int32 -> m ()
glTexParameteri GLuint
forall a. (Eq a, Num a) => a
GL_TEXTURE_2D GLuint
forall a. (Eq a, Num a) => a
GL_TEXTURE_WRAP_T Int32
forall a. (Eq a, Num a) => a
GL_REPEAT
GLuint -> GLuint -> Int32 -> m ()
forall (m :: * -> *).
MonadIO m =>
GLuint -> GLuint -> Int32 -> m ()
glTexParameteri GLuint
forall a. (Eq a, Num a) => a
GL_TEXTURE_2D GLuint
forall a. (Eq a, Num a) => a
GL_TEXTURE_MAG_FILTER Int32
forall a. (Eq a, Num a) => a
GL_LINEAR
GLuint -> GLuint -> Int32 -> m ()
forall (m :: * -> *).
MonadIO m =>
GLuint -> GLuint -> Int32 -> m ()
glTexParameteri GLuint
forall a. (Eq a, Num a) => a
GL_TEXTURE_2D GLuint
forall a. (Eq a, Num a) => a
GL_TEXTURE_MIN_FILTER Int32
forall a. (Eq a, Num a) => a
GL_LINEAR
GLuint -> GLuint -> m ()
forall (m :: * -> *). MonadIO m => GLuint -> GLuint -> m ()
glBindTexture GLuint
forall a. (Eq a, Num a) => a
GL_TEXTURE_2D GLuint
0
GLuint -> Int32 -> m ()
forall (m :: * -> *). MonadIO m => GLuint -> Int32 -> m ()
glPixelStorei GLuint
forall a. (Eq a, Num a) => a
GL_UNPACK_ALIGNMENT Int32
4
Atlas -> m Atlas
forall (m :: * -> *) a. Monad m => a -> m a
return Atlas
atlas { atlasTextureSize :: V2 Int
atlasTextureSize = Int -> Int -> V2 Int
forall a. a -> a -> V2 a
V2 Int
w Int
h, atlasScale :: (Float, Float)
atlasScale = (Float, Float)
scale }
freeAtlas :: MonadIO m => Atlas -> m ()
freeAtlas :: forall (m :: * -> *). MonadIO m => Atlas -> m ()
freeAtlas Atlas
a = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ GLuint -> (Ptr GLuint -> IO ()) -> IO ()
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with (Atlas -> GLuint
atlasTexture Atlas
a) ((Ptr GLuint -> IO ()) -> IO ()) -> (Ptr GLuint -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr GLuint
ptr -> Int32 -> Ptr GLuint -> IO ()
forall (m :: * -> *). MonadIO m => Int32 -> Ptr GLuint -> m ()
glDeleteTextures Int32
1 Ptr GLuint
ptr
type Quads = (Float, Float, [Vector (V2 Float, V2 Float)])
makeCharQuad :: (MonadIO m, MonadError TypograffitiError m) =>
Atlas -> Quads -> (GlyphInfo, GlyphPos) -> m Quads
makeCharQuad :: forall (m :: * -> *).
(MonadIO m, MonadError TypograffitiError m) =>
Atlas -> Quads -> (GlyphInfo, GlyphPos) -> m Quads
makeCharQuad Atlas {GLuint
(Float, Float)
V2 Int
IntMap GlyphMetrics
atlasScale :: (Float, Float)
atlasMetrics :: IntMap GlyphMetrics
atlasTextureSize :: V2 Int
atlasTexture :: GLuint
atlasScale :: Atlas -> (Float, Float)
atlasMetrics :: Atlas -> IntMap GlyphMetrics
atlasTextureSize :: Atlas -> V2 Int
atlasTexture :: Atlas -> GLuint
..} (Float
penx, Float
peny, [Vector (V2 Float, V2 Float)]
mLast) (GlyphInfo {codepoint :: GlyphInfo -> GLuint
codepoint=GLuint
glyph}, GlyphPos {Int32
y_offset :: GlyphPos -> Int32
y_advance :: GlyphPos -> Int32
x_offset :: GlyphPos -> Int32
x_advance :: GlyphPos -> Int32
y_offset :: Int32
x_offset :: Int32
y_advance :: Int32
x_advance :: Int32
..}) = do
let iglyph :: Int
iglyph = GLuint -> Int
forall a. Enum a => a -> Int
fromEnum GLuint
glyph
case Int -> IntMap GlyphMetrics -> Maybe GlyphMetrics
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
iglyph IntMap GlyphMetrics
atlasMetrics of
Maybe GlyphMetrics
Nothing -> TypograffitiError -> m Quads
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TypograffitiError -> m Quads) -> TypograffitiError -> m Quads
forall a b. (a -> b) -> a -> b
$ Int -> TypograffitiError
TypograffitiErrorNoMetricsForGlyph Int
iglyph
Just GlyphMetrics {(V2 Int, V2 Int)
V2 Int
glyphOffset :: V2 Int
glyphSize :: V2 Int
glyphTexBB :: (V2 Int, V2 Int)
glyphOffset :: GlyphMetrics -> V2 Int
glyphSize :: GlyphMetrics -> V2 Int
glyphTexBB :: GlyphMetrics -> (V2 Int, V2 Int)
..} -> do
let x :: Float
x = Float
penx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Int32 -> Float
f Int32
x_offsetFloat -> Float -> Float
forall a. Num a => a -> a -> a
*(Float, Float) -> Float
forall a b. (a, b) -> a
fst (Float, Float)
atlasScale
y :: Float
y = Float
peny Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Int32 -> Float
f Int32
y_offsetFloat -> Float -> Float
forall a. Num a => a -> a -> a
*(Float, Float) -> Float
forall a b. (a, b) -> b
snd (Float, Float)
atlasScale
V2 Float
w Float
h = Int -> Float
f' (Int -> Float) -> V2 Int -> V2 Float
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> V2 Int
glyphSize
V2 Float
dx Float
dy = Int -> Float
f' (Int -> Float) -> V2 Int -> V2 Float
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> V2 Int
glyphOffset
(Float
x', Float
y') = (Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
dx, Float
y Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
dy)
V2 Float
aszW Float
aszH = Int -> Float
f' (Int -> Float) -> V2 Int -> V2 Float
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> V2 Int
atlasTextureSize
V2 Float
texL Float
texT = Int -> Float
f' (Int -> Float) -> V2 Int -> V2 Float
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (V2 Int, V2 Int) -> V2 Int
forall a b. (a, b) -> a
fst (V2 Int, V2 Int)
glyphTexBB
V2 Float
texR Float
texB = Int -> Float
f' (Int -> Float) -> V2 Int -> V2 Float
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (V2 Int, V2 Int) -> V2 Int
forall a b. (a, b) -> b
snd (V2 Int, V2 Int)
glyphTexBB
tl :: (V2 Float, V2 Float)
tl = (Float -> Float -> V2 Float
forall a. a -> a -> V2 a
V2 (Float
x') (Float
y'), Float -> Float -> V2 Float
forall a. a -> a -> V2 a
V2 (Float
texLFloat -> Float -> Float
forall a. Fractional a => a -> a -> a
/Float
aszW) (Float
texTFloat -> Float -> Float
forall a. Fractional a => a -> a -> a
/Float
aszH))
tr :: (V2 Float, V2 Float)
tr = (Float -> Float -> V2 Float
forall a. a -> a -> V2 a
V2 (Float
x'Float -> Float -> Float
forall a. Num a => a -> a -> a
+Float
w) (Float
y'), Float -> Float -> V2 Float
forall a. a -> a -> V2 a
V2 (Float
texRFloat -> Float -> Float
forall a. Fractional a => a -> a -> a
/Float
aszW) (Float
texTFloat -> Float -> Float
forall a. Fractional a => a -> a -> a
/Float
aszH))
br :: (V2 Float, V2 Float)
br = (Float -> Float -> V2 Float
forall a. a -> a -> V2 a
V2 (Float
x'Float -> Float -> Float
forall a. Num a => a -> a -> a
+Float
w) (Float
y'Float -> Float -> Float
forall a. Num a => a -> a -> a
+Float
h), Float -> Float -> V2 Float
forall a. a -> a -> V2 a
V2 (Float
texRFloat -> Float -> Float
forall a. Fractional a => a -> a -> a
/Float
aszW) (Float
texBFloat -> Float -> Float
forall a. Fractional a => a -> a -> a
/Float
aszH))
bl :: (V2 Float, V2 Float)
bl = (Float -> Float -> V2 Float
forall a. a -> a -> V2 a
V2 (Float
x') (Float
y'Float -> Float -> Float
forall a. Num a => a -> a -> a
+Float
h), Float -> Float -> V2 Float
forall a. a -> a -> V2 a
V2 (Float
texLFloat -> Float -> Float
forall a. Fractional a => a -> a -> a
/Float
aszW) (Float
texBFloat -> Float -> Float
forall a. Fractional a => a -> a -> a
/Float
aszH))
Quads -> m Quads
forall (m :: * -> *) a. Monad m => a -> m a
return (Float
penx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Int32 -> Float
f Int32
x_advanceFloat -> Float -> Float
forall a. Num a => a -> a -> a
*(Float, Float) -> Float
forall a b. (a, b) -> a
fst (Float, Float)
atlasScale, Float
peny Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Int32 -> Float
f Int32
y_advanceFloat -> Float -> Float
forall a. Num a => a -> a -> a
*(Float, Float) -> Float
forall a b. (a, b) -> b
snd (Float, Float)
atlasScale,
[(V2 Float, V2 Float)] -> Vector (V2 Float, V2 Float)
forall a. Unbox a => [a] -> Vector a
UV.fromList [(V2 Float, V2 Float)
tl, (V2 Float, V2 Float)
tr, (V2 Float, V2 Float)
br, (V2 Float, V2 Float)
tl, (V2 Float, V2 Float)
br, (V2 Float, V2 Float)
bl] Vector (V2 Float, V2 Float)
-> [Vector (V2 Float, V2 Float)] -> [Vector (V2 Float, V2 Float)]
forall a. a -> [a] -> [a]
: [Vector (V2 Float, V2 Float)]
mLast)
where
f :: Int32 -> Float
f :: Int32 -> Float
f = Int32 -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral
f' :: Int -> Float
f' :: Int -> Float
f' = Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral
stringTris :: (MonadIO m, MonadError TypograffitiError m) =>
Atlas -> [(GlyphInfo, GlyphPos)] -> m Quads
stringTris :: forall (m :: * -> *).
(MonadIO m, MonadError TypograffitiError m) =>
Atlas -> [(GlyphInfo, GlyphPos)] -> m Quads
stringTris Atlas
atlas = (Quads -> (GlyphInfo, GlyphPos) -> m Quads)
-> Quads -> [(GlyphInfo, GlyphPos)] -> m Quads
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Atlas -> Quads -> (GlyphInfo, GlyphPos) -> m Quads
forall (m :: * -> *).
(MonadIO m, MonadError TypograffitiError m) =>
Atlas -> Quads -> (GlyphInfo, GlyphPos) -> m Quads
makeCharQuad Atlas
atlas) (Float
0, Float
0, [])
stringTris' :: (MonadIO m, MonadError TypograffitiError m) =>
Atlas -> [(GlyphInfo, GlyphPos)] -> m (Vector (V2 Float, V2 Float))
stringTris' :: forall (m :: * -> *).
(MonadIO m, MonadError TypograffitiError m) =>
Atlas -> [(GlyphInfo, GlyphPos)] -> m (Vector (V2 Float, V2 Float))
stringTris' Atlas
atlas [(GlyphInfo, GlyphPos)]
glyphs = do
(Float
_, Float
_, [Vector (V2 Float, V2 Float)]
ret) <- Atlas -> [(GlyphInfo, GlyphPos)] -> m Quads
forall (m :: * -> *).
(MonadIO m, MonadError TypograffitiError m) =>
Atlas -> [(GlyphInfo, GlyphPos)] -> m Quads
stringTris Atlas
atlas [(GlyphInfo, GlyphPos)]
glyphs
Vector (V2 Float, V2 Float) -> m (Vector (V2 Float, V2 Float))
forall (m :: * -> *) a. Monad m => a -> m a
return (Vector (V2 Float, V2 Float) -> m (Vector (V2 Float, V2 Float)))
-> Vector (V2 Float, V2 Float) -> m (Vector (V2 Float, V2 Float))
forall a b. (a -> b) -> a -> b
$ [Vector (V2 Float, V2 Float)] -> Vector (V2 Float, V2 Float)
forall a. Unbox a => [Vector a] -> Vector a
UV.concat ([Vector (V2 Float, V2 Float)] -> Vector (V2 Float, V2 Float))
-> [Vector (V2 Float, V2 Float)] -> Vector (V2 Float, V2 Float)
forall a b. (a -> b) -> a -> b
$ [Vector (V2 Float, V2 Float)] -> [Vector (V2 Float, V2 Float)]
forall a. [a] -> [a]
reverse [Vector (V2 Float, V2 Float)]
ret
liftFreetype :: (MonadIO m, MonadError TypograffitiError m) => IO a -> m a
liftFreetype :: forall (m :: * -> *) a.
(MonadIO m, MonadError TypograffitiError m) =>
IO a -> m a
liftFreetype IO a
cb = do
Either FtError a
err <- IO (Either FtError a) -> m (Either FtError a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either FtError a) -> m (Either FtError a))
-> IO (Either FtError a) -> m (Either FtError a)
forall a b. (a -> b) -> a -> b
$ IO a -> IO (Either FtError a)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO a -> IO (Either FtError a)) -> IO a -> IO (Either FtError a)
forall a b. (a -> b) -> a -> b
$ IO a
cb
case Either FtError a
err of
Left (FtError String
func Int32
code) -> TypograffitiError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TypograffitiError -> m a) -> TypograffitiError -> m a
forall a b. (a -> b) -> a -> b
$ String -> Int32 -> TypograffitiError
TypograffitiErrorFreetype String
func Int32
code
Right a
ret -> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
ret