{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards  #-}
-- |
-- Module:     Typograffiti.Atlas
-- Copyright:  (c) 2018 Schell Scivally, 2023 Adrian Cochrane
-- License:    MIT
-- Maintainer: Schell Scivally <schell@takt.com>
--             & Adrian Cochrane <alcinnz@argonaut-constellation.org>
--
-- This module provides a font-character atlas to use in font rendering with
-- opengl.
--
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

-- | Represents a failure to render text.
data TypograffitiError =
    TypograffitiErrorNoMetricsForGlyph Int
  -- ^ The are no glyph metrics for this character. This probably means
  -- the character has not been loaded into the atlas.
  | TypograffitiErrorFreetype String Int32
  -- ^ There was a problem while interacting with the freetype2 library.
  | TypograffitiErrorGL String
  -- ^ There was a problem while interacting with OpenGL.
  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)

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

-- | Size & position of a Glyph in the `Atlas`.
data GlyphMetrics = GlyphMetrics {
    GlyphMetrics -> (V2 Int, V2 Int)
glyphTexBB :: (V2 Int, V2 Int),
    -- ^ Bounding box of the glyph in the texture.
    GlyphMetrics -> V2 Int
glyphSize :: V2 Int,
    -- ^ Size of the glyph onscreen.
    GlyphMetrics -> V2 Int
glyphOffset :: V2 Int
    -- ^ Left & top bearings.
} 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)

-- | Cache of rendered glyphs to be composited into place on the GPU.
data Atlas = Atlas {
    Atlas -> GLuint
atlasTexture :: GLuint,
    -- ^ The texture holding the pre-rendered glyphs.
    Atlas -> V2 Int
atlasTextureSize :: V2 Int,
    -- ^ The size of the texture.
    Atlas -> IntMap GlyphMetrics
atlasMetrics :: IntMap GlyphMetrics,
    -- ^ Mapping from glyphs to their position in the texture.
    Atlas -> (Float, Float)
atlasScale :: (Float, Float)
    -- ^ Scaling factor for font-units given by Harfbuzz.
} 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)

-- | Initializes an empty atlas.
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)

-- | Precomputed positioning of glyphs in an `Atlas` texture.
data AtlasMeasure = AM {
    AtlasMeasure -> V2 Int
amWH :: V2 Int,
    -- ^ Current size of the atlas as it has been laid out so far.
    AtlasMeasure -> V2 Int
amXY :: V2 Int,
    -- ^ Tentative position for the next glyph added to the atlas.
    AtlasMeasure -> Int
rowHeight :: Int,
    -- ^ Height of the current row, for the sake of line wrapping.
    AtlasMeasure -> IntMap (V2 Int)
amMap :: IntMap (V2 Int)
    -- ^ Position of each glyph in the atlas.
} 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)

-- | Initializes a new `AtlasMeasure`.
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

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

-- | Callback for looking up a glyph from an atlas.
-- Useful for applying synthetic styles to fonts which lack them,
-- when calling the low-level APIs.
type GlyphRetriever m = Word32 -> m (FT_Bitmap, FT_Glyph_Metrics)
-- | Default callback for glyph lookups, with no modifications.
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)

-- | Extract the measurements of a character in the FT_Face and append it to
-- the given AtlasMeasure.
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

-- | Uploads glyphs into an `Atlas` texture for the GPU to composite.
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
        -- TODO Throw an exception.
        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

-- | 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, 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 }

-- | Releases all resources associated with the given 'Atlas'.
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

-- | The geometry needed to render some text, with the position for the next glyph.
type Quads = (Float, Float, [Vector (V2 Float, V2 Float)])
-- | Construct the geometry needed to render the given character.
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

-- | Generate the geometry of the given string, with next-glyph position.
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, [])
-- | Generate the geometry of the given string.
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

-- | Internal utility to propagate FreeType errors into Typograffiti errors.
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