{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleContexts  #-}
module Graphics.Text.Font.Render where

import           Data.Map (Map)
import           Data.Int (Int32)
import           Data.IntMap (IntMap)
import qualified Data.IntMap as IM
import           Linear.V2 (V2(..))
import           Linear.V (toV, dim, Finite, Size)
import           FreeType.Core.Base (FT_Library, FT_Face,
                                    FT_GlyphSlotRec(..), FT_Glyph_Metrics(..))
import           FreeType.Core.Types (FT_Bitmap(..))
import           Data.Text.Glyphize (GlyphInfo(..), GlyphPos(..))

import           Graphics.GL as GL
import qualified Graphics.GL.Core32 as GL
import           Control.Monad (foldM, when)
import           Control.Exception (assert)
import qualified Data.Foldable          as F
import           GHC.TypeNats (KnownNat)

import           Foreign.Ptr (castPtr, nullPtr)
import           Foreign.C.String (withCString)
import           Foreign.Marshal.Array (peekArray, allocaArray)
import           Foreign.Marshal.Utils (with)
import           Foreign.Storable (Storable(..))
import qualified Data.Vector.Storable   as SV
import           Data.Vector.Unboxed    (Unbox)
import qualified Data.Vector.Unboxed    as UV

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

data GlyphMetrics = GlyphMetrics {
    glyphTexBB :: (V2 Int, V2 Int),
    glyphTexSize :: V2 Int,
    glyphSize :: V2 Int
} deriving (Show, Eq)

data Atlas = Atlas {
    atlasTexture :: GLuint,
    atlasTextureSize :: V2 Int,
    atlasMetrics :: IntMap GlyphMetrics,
    atlasFilePath :: FilePath
}

emptyAtlas t = Atlas t 0 mempty ""

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 cb maxw am@AM{..} (GlyphInfo {codepoint = 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

texturize cb xymap atlas@Atlas{..} (GlyphInfo {codepoint = glyph}, _)
    | Just pos@(V2 x y) <- IM.lookup (fromIntegral $ fromEnum glyph) xymap = do
        (bmp, metrics) <- cb glyph
        glTexSubImage2D GL.GL_TEXTURE_2D 0
            (fromIntegral x) (fromIntegral y)
            (fromIntegral $ bWidth bmp) (fromIntegral $ bRows bmp)
            GL.GL_RED GL.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),
                glyphTexSize = vecwh,
                glyphSize = vecsz
              }
        return atlas { atlasMetrics = IM.insert (fromEnum glyph) mtrcs atlasMetrics }
    | otherwise = do
        putStrLn ("Cound not find glyph " ++ show glyph)
        return atlas

allocAtlas cb glyphs = do
    AM {..} <- foldM (measure cb 512) emptyAM glyphs
    let V2 w h = amWH
        xymap = amMap

    [t] <- allocaArray 1 $ \ptr -> do
        glGenTextures 1 ptr
        peekArray 1 ptr
    glActiveTexture 0
    glBindTexture GL.GL_TEXTURE_2D t

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

    glGenerateMipmap GL.GL_TEXTURE_2D
    glTexParameteri GL.GL_TEXTURE_2D GL.GL_TEXTURE_WRAP_S GL.GL_REPEAT
    glTexParameteri GL.GL_TEXTURE_2D GL.GL_TEXTURE_WRAP_T GL.GL_REPEAT
    glTexParameteri GL.GL_TEXTURE_2D GL.GL_TEXTURE_MAG_FILTER GL.GL_LINEAR
    glTexParameteri GL.GL_TEXTURE_2D GL.GL_TEXTURE_MIN_FILTER GL.GL_LINEAR
    glBindTexture GL.GL_TEXTURE_2D 0
    glPixelStorei GL.GL_UNPACK_ALIGNMENT 4
    return atlas { atlasTextureSize = V2 w h }

freeAtlas a = with (atlasTexture a) $ \ptr -> glDeleteTextures 1 ptr

type Quads = (Float, Float, [(V2 Float, V2 Float)])
makeCharQuad :: Atlas -> Quads -> (GlyphInfo, GlyphPos) -> IO Quads
makeCharQuad Atlas {..} (penx, peny, mLast) (GlyphInfo {codepoint=glyph}, GlyphPos {..}) = do
    let iglyph = fromEnum glyph
    case IM.lookup iglyph atlasMetrics of
        Nothing -> return (penx, peny, mLast)
        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, 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))

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

stringTris :: Atlas -> [(GlyphInfo, GlyphPos)] -> IO Quads
stringTris atlas = foldM (makeCharQuad atlas) (0, 0, [])
stringTris' :: Atlas -> [(GlyphInfo, GlyphPos)] -> IO [(V2 Float, V2 Float)]
stringTris' atlas glyphs = do
    (_, _, ret) <- stringTris atlas glyphs
    return ret

drawGlyphs :: Atlas -> [(GlyphInfo, GlyphPos)] -> IO ()
drawGlyphs atlas@Atlas {..} glyphs = do
    glBindTexture GL.GL_TEXTURE_2D atlasTexture

    (geom', texcoords') <- unzip <$> stringTris' atlas glyphs
    geom <- newBuffer
    texcoords <- newBuffer
    bufferGeometry 0 geom $ UV.fromList geom'
    bufferGeometry 1 texcoords $ UV.fromList texcoords'
    glDrawArrays GL.GL_TRIANGLES 0 $ toEnum $ SV.length $ convertVec $ UV.fromList geom'

------
--- OpenGL Utilities
------

newBuffer :: IO GLuint
newBuffer = do
  [b] <- allocaArray 1 $ \ptr -> do
    glGenBuffers 1 ptr
    peekArray 1 ptr
  return b

-- | 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.GL_ARRAY_BUFFER buf
    SV.unsafeWith (convertVec as) $ \ptr ->
      glBufferData GL.GL_ARRAY_BUFFER (fromIntegral asize) (castPtr ptr) GL.GL_STATIC_DRAW
    glEnableVertexAttribArray loc
    glVertexAttribPointer loc n GL.GL_FLOAT GL.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)

clearErrors str = do
  err' <- glGetError
  when (err' /= 0) $ do
    putStrLn $ unwords [str, show err']
    assert False $ return ()