{-# 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 (Show, Eq)

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

-- | Size & position of a Glyph in the `Atlas`.
data GlyphMetrics = GlyphMetrics {
    glyphTexBB :: (V2 Int, V2 Int),
    -- ^ Bounding box of the glyph in the texture.
    glyphSize :: V2 Int
    -- ^ Size of the glyph onscreen.
} deriving (Show, Eq)

-- | Cache of rendered glyphs to be composited into place on the GPU.
data Atlas = Atlas {
    atlasTexture :: GLuint,
    -- ^ The texture holding the pre-rendered glyphs.
    atlasTextureSize :: V2 Int,
    -- ^ The size of the texture.
    atlasMetrics :: IntMap GlyphMetrics
    -- ^ Mapping from glyphs to their position in the texture.
} deriving (Show)

-- | Initializes an empty atlas.
emptyAtlas :: GLuint -> Atlas
emptyAtlas t = Atlas t 0 mempty

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

-- | Initializes a new `AtlasMeasure`.
emptyAM :: AtlasMeasure
emptyAM = AM 0 (V2 1 1) 0 mempty

-- | The amount of spacing between glyphs rendered into the atlas's texture.
spacing :: Int
spacing = 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 font glyph = do
    liftFreetype $ ft_Load_Glyph font (fromIntegral $ fromEnum glyph) FT_LOAD_RENDER
    font' <- liftIO $ peek font
    slot <- liftIO $ peek $ frGlyph font'
    return (gsrBitmap slot, gsrMetrics 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 cb maxw am@AM{..} glyph
    | Just _ <- IM.lookup (fromEnum glyph) amMap = return am
    | otherwise = do
        let V2 x y = amXY
            V2 w h = amWH
        (bmp, _) <- cb glyph
        let bw = fromIntegral $ bWidth bmp
            bh = fromIntegral $ bRows 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
            am = AM {
                amWH = V2 nw nh,
                amXY = V2 nx ny,
                rowHeight = rh,
                amMap = IM.insert (fromEnum glyph) amXY amMap
              }
        return 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 cb xymap atlas@Atlas{..} glyph
    | Just pos@(V2 x y) <- IM.lookup (fromIntegral $ fromEnum glyph) xymap = do
        (bmp, metrics) <- cb glyph
        glTexSubImage2D GL_TEXTURE_2D 0
            (fromIntegral x) (fromIntegral y)
            (fromIntegral $ bWidth bmp) (fromIntegral $ bRows bmp)
            GL_RED GL_UNSIGNED_BYTE
            (castPtr $ bBuffer bmp)
        let vecwh = fromIntegral <$> V2 (bWidth bmp) (bRows bmp)
            canon = floor . (* 0.5) . (* 0.015625) . realToFrac . fromIntegral
            vecsz = canon <$> V2 (gmWidth metrics) (gmHeight metrics)
            vecxb = canon <$> V2 (gmHoriBearingX metrics) (gmHoriBearingY metrics)
            vecyb = canon <$> V2 (gmVertBearingX metrics) (gmVertBearingY metrics)
            vecad = canon <$> V2 (gmHoriAdvance metrics) (gmVertAdvance metrics)
            mtrcs = GlyphMetrics {
                glyphTexBB = (pos, pos + vecwh),
                glyphSize = vecsz
              }
        return atlas { atlasMetrics = IM.insert (fromEnum glyph) mtrcs atlasMetrics }
    | otherwise = do
        -- TODO Throw an exception.
        liftIO $ putStrLn ("Cound not find glyph " ++ show glyph)
        return atlas

-- | Allocate a new 'Atlas'.
-- When creating a new 'Atlas' you must pass all the characters that you
-- might need during the life of the 'Atlas'. Character texturization only
-- happens once.
allocAtlas :: (MonadIO m, MonadFail m, MonadError TypograffitiError m) =>
    GlyphRetriever m -> [Word32] -> m Atlas
allocAtlas cb glyphs = do
    AM {..} <- foldM (measure cb 512) emptyAM glyphs
    let V2 w h = amWH
        xymap = amMap

    t <- allocAndActivateTex 0

    glPixelStorei GL_UNPACK_ALIGNMENT 1
    liftIO $ withCString (replicate (w * h) $ toEnum 0) $
        glTexImage2D GL_TEXTURE_2D 0 GL_RED (fromIntegral w) (fromIntegral h)
                    0 GL_RED GL_UNSIGNED_BYTE . castPtr
    atlas <- foldM (texturize cb xymap) (emptyAtlas t) glyphs

    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 }

-- | Releases all resources associated with the given 'Atlas'.
freeAtlas :: MonadIO m => Atlas -> m ()
freeAtlas a = liftIO $ with (atlasTexture a) $ \ptr -> glDeleteTextures 1 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 Atlas {..} (penx, peny, mLast) (GlyphInfo {codepoint=glyph}, GlyphPos {..}) = do
    let iglyph = fromEnum glyph
    case IM.lookup iglyph atlasMetrics of
        Nothing -> throwError $ TypograffitiErrorNoMetricsForGlyph iglyph
        Just GlyphMetrics {..} -> do
            let x = penx + f x_offset
                y = peny + f y_offset
                V2 w h = f' <$> glyphSize
                V2 aszW aszH = f' <$> atlasTextureSize
                V2 texL texT = f' <$> fst glyphTexBB
                V2 texR texB = f' <$> snd glyphTexBB

                tl = (V2 (x) (y-h), V2 (texL/aszW) (texT/aszH))
                tr = (V2 (x+w) (y-h), V2 (texR/aszW) (texT/aszH))
                br = (V2 (x+w) y, V2 (texR/aszW) (texB/aszH))
                bl = (V2 (x) y, V2 (texL/aszW) (texB/aszH))

            return (penx + f x_advance/150, peny + f y_advance/150,
                    UV.fromList [tl, tr, br, tl, br, bl] : mLast)
  where
    f :: Int32 -> Float
    f = fromIntegral
    f' :: Int -> Float
    f' = fromIntegral

-- | Generate the geometry of the given string, with next-glyph position.
stringTris :: (MonadIO m, MonadError TypograffitiError m) =>
    Atlas -> [(GlyphInfo, GlyphPos)] -> m Quads
stringTris atlas = foldM (makeCharQuad atlas) (0, 0, [])
-- | Generate the geometry of the given string.
stringTris' :: (MonadIO m, MonadError TypograffitiError m) =>
    Atlas -> [(GlyphInfo, GlyphPos)] -> m (Vector (V2 Float, V2 Float))
stringTris' atlas glyphs = do
    (_, _, ret) <- stringTris atlas glyphs
    return $ UV.concat $ reverse ret

-- | Internal utility to propagate FreeType errors into Typograffiti errors.
liftFreetype :: (MonadIO m, MonadError TypograffitiError m) => IO a -> m a
liftFreetype cb = do
    err <- liftIO $ try $ cb
    case err of
        Left (FtError func code) -> throwError $ TypograffitiErrorFreetype func code
        Right ret -> return ret