aztecs-gl-text-0.1.0: src/Aztecs/GL/Text/Label.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Aztecs.GL.Text.Label
  ( -- * Labels
    Label (..),
    LabelStyle (..),
    defaultLabelStyle,
  )
where

import Aztecs
import Aztecs.GL.Internal
import Aztecs.GL.Material
import Aztecs.GL.Mesh
import Aztecs.GL.Text.Label.Internal
import Control.Exception (catch)
import Control.Monad
import Control.Monad.IO.Class
import qualified Data.Vector.Storable as SV
import Foreign
import FreeType.Core.Base
import FreeType.Core.Types
import FreeType.Exception (FtError)
import FreeType.Format.Multiple
import Graphics.Rendering.OpenGL (($=))
import qualified Graphics.Rendering.OpenGL as GL
import Linear
import Prelude hiding (lookup)

-- | Label styling options
data LabelStyle = LabelStyle
  { -- | Font size in pixels
    labelFontSize :: !Int,
    -- | Text color (RGBA)
    labelColor :: !(V4 Float),
    -- | Font weight (100-900, where 400 is normal, 700 is bold)
    labelFontWeight :: !Int,
    -- | Whether to render in italic style
    labelItalic :: !Bool
  }
  deriving (Eq)

-- | Default label style with given font entity
defaultLabelStyle :: LabelStyle
defaultLabelStyle =
  LabelStyle
    { labelFontSize = 16,
      labelColor = V4 1 1 1 1,
      labelFontWeight = 400,
      labelItalic = False
    }

-- | Label component
data Label = Label
  { -- | Text content
    labelText :: !String,
    -- | Entity ID of the @Font@ component to use
    labelFont :: !EntityID,
    -- | Text styling
    labelStyle :: !LabelStyle
  }
  deriving (Eq)

instance (MonadIO m) => Component m Label where
  componentOnInsert e lbl = inAnyWindowContext $ do
    let style = labelStyle lbl
        text = labelText lbl
        fontE = labelFont lbl
        fontSize = labelFontSize style
        V4 r g b a = labelColor style

    -- Look up the font state from the font entity
    mFontState <- lookup fontE
    case mFontState of
      Just fontState -> do
        -- Set the font size for this label
        liftIO $ ft_Set_Pixel_Sizes (fontStateFace fontState) 0 (fromIntegral fontSize)

        -- Set variable font weight
        let weight = labelFontWeight style
            italic = labelItalic style
        liftIO $ setVariableFontWeight (fontStateFace fontState) weight

        -- Get glyphs for the text and create a texture atlas
        (glyphs, atlasInfo) <- liftIO $ getGlyphsAndAtlasIOFromFace (fontStateFace fontState) text weight italic

        -- Calculate total dimensions
        let totalWidth = sum $ map (fromIntegral . glyphAdvance) glyphs
            totalHeight = maximum' $ map (fromIntegral . glyphHeight) glyphs

        -- Store label state (including atlas texture for cleanup)
        insert e $
          bundle
            LabelState
              { labelGlyphs = glyphs,
                labelTotalWidth = totalWidth,
                labelTotalHeight = totalHeight,
                labelAtlasTexture = atlasTexture atlasInfo
              }

        -- Build mesh
        let mesh = compileLabelMesh glyphs atlasInfo

        -- Build material
        let mat = labelMaterial (atlasTexture atlasInfo) r g b a

        -- Insert references to mesh and material
        insert e $ bundle mesh <> bundle mat
      Nothing -> return ()

  componentOnChange e old newLabel = when (old /= newLabel) $ inAnyWindowContext $ do
    -- Now recreate resources with new label
    let style = labelStyle newLabel
        text = labelText newLabel
        fontE = labelFont newLabel
        fontSize = labelFontSize style
        V4 r g b a = labelColor style

    mFontState <- lookup fontE
    case mFontState of
      Just fontState -> do
        liftIO $ ft_Set_Pixel_Sizes (fontStateFace fontState) 0 (fromIntegral fontSize)

        let weight = labelFontWeight style
            italic = labelItalic style
        liftIO $ setVariableFontWeight (fontStateFace fontState) weight

        (glyphs, atlasInfo) <- liftIO $ getGlyphsAndAtlasIOFromFace (fontStateFace fontState) text weight italic

        let totalWidth = sum $ map (fromIntegral . glyphAdvance) glyphs
            totalHeight = maximum' $ map (fromIntegral . glyphHeight) glyphs

        -- Update label state in place
        insert e $
          bundle
            LabelState
              { labelGlyphs = glyphs,
                labelTotalWidth = totalWidth,
                labelTotalHeight = totalHeight,
                labelAtlasTexture = atlasTexture atlasInfo
              }

        -- Create new mesh and material data, and UPDATE in place (don't remove/re-insert)
        let mesh = compileLabelMesh glyphs atlasInfo
        meshData <- liftIO $ unMesh mesh
        insert e $ bundle meshData -- Update MeshState in place
        let mat = labelMaterial (atlasTexture atlasInfo) r g b a
        matData <- liftIO $ unMaterial mat
        insert e $ bundle matData -- Update MaterialState in place
      Nothing -> return ()

  componentOnRemove e _ = inAnyWindowContext $ do
    -- Delete atlas texture from label state
    mLabelState <- lookup e
    case mLabelState of
      Just ls -> liftIO $ GL.deleteObjectName (labelAtlasTexture ls)
      Nothing -> return ()

    -- Delete VBO from mesh state
    mMeshState <- lookup @_ @MeshState e
    case mMeshState of
      Just ms -> liftIO $ GL.deleteObjectName (meshVbo ms)
      Nothing -> return ()

    -- Remove all components
    _ <- remove @_ @Mesh e
    _ <- remove @_ @MeshState e
    _ <- remove @_ @Material e
    _ <- remove @_ @MaterialState e
    _ <- remove @_ @LabelState e
    return ()

-- | Maximum helper that handles empty lists
maximum' :: (Ord a, Num a) => [a] -> a
maximum' [] = 0
maximum' xs = maximum xs

-- | Set the weight axis for a variable font
-- The 'wght' axis tag is 0x77676874 in FreeType
setVariableFontWeight :: FT_Face -> Int -> IO ()
setVariableFontWeight face weight = do
  -- Try to set the weight - this will silently fail for non-variable fonts
  let weightFixed = fromIntegral weight * 65536 -- Convert to 16.16 fixed point
  -- The weight axis is typically the first axis in variable fonts
  -- We use ft_Set_Var_Design_Coordinates with just the weight value
  -- FreeType will throw an error for non-variable fonts, which we catch
  ft_Set_Var_Design_Coordinates face [weightFixed] `catch` handleError
  where
    handleError :: FtError -> IO ()
    handleError _ = return () -- Silently ignore errors (non-variable fonts)

-- | Atlas info for a label's text
data AtlasInfo = AtlasInfo
  { atlasTexture :: !GL.TextureObject,
    atlasGlyphUVs :: ![(Float, Float, Float, Float)] -- (u0, v0, u1, v1) for each glyph
  }

-- | Get glyphs and create a texture atlas for the text using a pre-loaded font face
getGlyphsAndAtlasIOFromFace :: FT_Face -> String -> Int -> Bool -> IO ([GlyphInfo], AtlasInfo)
getGlyphsAndAtlasIOFromFace face text weight italic = do
  -- Render all glyphs and collect their bitmap data
  glyphData <- forM text $ \char -> do
    glyph <- renderGlyphMetrics face char weight italic
    bitmapData <- getGlyphBitmapData face char weight italic
    return (glyph, bitmapData)

  let glyphs = map fst glyphData
      bitmaps = map snd glyphData

  -- Calculate atlas dimensions (simple horizontal layout)
  let atlasWidth' = sum $ map (\(w, _, _) -> max 1 w) bitmaps
      atlasHeight' = maximum' $ map (\(_, h, _) -> max 1 h) bitmaps
      atlasW = max 1 atlasWidth'
      atlasH = max 1 atlasHeight'

  -- Create the atlas texture
  [tex] <- GL.genObjectNames 1
  GL.textureBinding GL.Texture2D $= Just tex
  GL.textureFilter GL.Texture2D $= ((GL.Linear', Nothing), GL.Linear')
  GL.textureWrapMode GL.Texture2D GL.S $= (GL.Repeated, GL.ClampToEdge)
  GL.textureWrapMode GL.Texture2D GL.T $= (GL.Repeated, GL.ClampToEdge)

  -- Allocate atlas buffer (RGBA for proper blending)
  atlasBuffer <- mallocBytes (atlasW * atlasH * 4)
  -- Clear to transparent black
  forM_ [0 .. atlasW * atlasH * 4 - 1] $ \i ->
    pokeByteOff atlasBuffer i (0 :: Word8)

  -- Copy each glyph into the atlas and calculate UVs
  let copyGlyphs :: [(Int, Int, Ptr Word8)] -> Int -> [(Float, Float, Float, Float)] -> IO [(Float, Float, Float, Float)]
      copyGlyphs [] _ uvs = return (reverse uvs)
      copyGlyphs ((w, h, buf) : rest) xOffset uvs = do
        -- Copy glyph bitmap to atlas (convert grayscale to RGBA)
        when (w > 0 && h > 0) $
          forM_ [0 .. h - 1] $ \row ->
            forM_ [0 .. w - 1] $ \col -> do
              let srcIdx = row * w + col
                  dstIdx = (row * atlasW + (xOffset + col)) * 4
              alpha <- peekByteOff buf srcIdx :: IO Word8
              -- Set RGBA (white with alpha from glyph)
              pokeByteOff atlasBuffer dstIdx (255 :: Word8) -- R
              pokeByteOff atlasBuffer (dstIdx + 1) (255 :: Word8) -- G
              pokeByteOff atlasBuffer (dstIdx + 2) (255 :: Word8) -- B
              pokeByteOff atlasBuffer (dstIdx + 3) alpha -- A

        -- Free the copied bitmap buffer
        free buf

        -- Calculate UV coordinates for this glyph
        let u0 = fromIntegral xOffset / fromIntegral atlasW
            v0 = 0
            u1 = fromIntegral (xOffset + w) / fromIntegral atlasW
            v1 = fromIntegral h / fromIntegral atlasH

        copyGlyphs rest (xOffset + max 1 w) ((u0, v0, u1, v1) : uvs)

  uvs <- copyGlyphs bitmaps 0 []

  -- Upload atlas to GPU
  GL.rowAlignment GL.Unpack $= 1
  GL.texImage2D
    GL.Texture2D
    GL.NoProxy
    0
    GL.RGBA8
    (GL.TextureSize2D (fromIntegral atlasW) (fromIntegral atlasH))
    0
    (GL.PixelData GL.RGBA GL.UnsignedByte atlasBuffer)

  free atlasBuffer
  GL.textureBinding GL.Texture2D $= Nothing

  return (glyphs, AtlasInfo tex uvs)

-- | Get raw bitmap data for a glyph (width, height, buffer pointer)
-- Note: weight parameter is reserved for future synthetic bold implementation
getGlyphBitmapData :: FT_Face -> Char -> Int -> Bool -> IO (Int, Int, Ptr Word8)
getGlyphBitmapData face char _weight italic = do
  let charCode = fromIntegral $ fromEnum char
  glyphIndex <- ft_Get_Char_Index face charCode

  -- Apply italic transformation via FT_Set_Transform if needed
  when italic $ do
    let shear = 0.2 :: Double -- ~12 degree slant
        matrix =
          FT_Matrix
            { mXx = 0x10000,
              mXy = round (shear * 0x10000),
              mYx = 0,
              mYy = 0x10000
            }
    ft_Set_Transform face (Just matrix) Nothing

  ft_Load_Glyph face glyphIndex FT_LOAD_RENDER

  -- Reset transform after loading
  when italic $ ft_Set_Transform face Nothing Nothing

  faceRec <- peek face
  let glyphSlot = frGlyph faceRec
  slotRec <- peek glyphSlot

  let bitmap = gsrBitmap slotRec
      width = fromIntegral $ bWidth bitmap
      height = fromIntegral $ bRows bitmap
      buffer = bBuffer bitmap
      pitch = fromIntegral $ bPitch bitmap

  -- Copy the bitmap data since FreeType may overwrite it
  if width > 0 && height > 0
    then do
      bufCopy <- mallocBytes (width * height)
      forM_ [0 .. height - 1] $ \row -> do
        let srcOffset = row * pitch
            dstOffset = row * width
        copyBytes (plusPtr bufCopy dstOffset) (plusPtr buffer srcOffset) width
      return (width, height, bufCopy)
    else do
      emptyBuf <- mallocBytes 1
      pokeByteOff emptyBuf 0 (0 :: Word8)
      return (0, 0, emptyBuf)

-- | Render a glyph and get its metrics
-- Note: weight parameter is reserved for future synthetic bold implementation
renderGlyphMetrics :: FT_Face -> Char -> Int -> Bool -> IO GlyphInfo
renderGlyphMetrics face char _weight italic = do
  let charCode = fromIntegral $ fromEnum char
  glyphIndex <- ft_Get_Char_Index face charCode

  -- Apply italic transformation via FT_Set_Transform if needed
  when italic $ do
    let shear = 0.2 :: Double -- ~12 degree slant
        matrix =
          FT_Matrix
            { mXx = 0x10000,
              mXy = round (shear * 0x10000),
              mYx = 0,
              mYy = 0x10000
            }
    ft_Set_Transform face (Just matrix) Nothing

  ft_Load_Glyph face glyphIndex FT_LOAD_RENDER

  -- Reset transform after loading
  when italic $ ft_Set_Transform face Nothing Nothing

  -- Get glyph slot from face
  faceRec <- peek face
  let glyphSlot = frGlyph faceRec
  slotRec <- peek glyphSlot

  let bitmap = gsrBitmap slotRec
      width = fromIntegral $ bWidth bitmap
      height = fromIntegral $ bRows bitmap

  let metrics = gsrMetrics slotRec
      bitmapLeft = fromIntegral (gmHoriBearingX metrics) `div` 64
      bitmapTop = fromIntegral (gmHoriBearingY metrics) `div` 64
      advanceX = fromIntegral (gmHoriAdvance metrics) `div` 64

  -- We don't need individual textures anymore, just return glyph metrics
  -- Use a dummy texture object since we use atlas textures instead
  return $
    GlyphInfo
      { glyphTexture = GL.TextureObject 0,
        glyphWidth = width,
        glyphHeight = height,
        glyphBearingX = bitmapLeft,
        glyphBearingY = bitmapTop,
        glyphAdvance = advanceX
      }

-- | Compile mesh for rendering label glyphs
compileLabelMesh :: [GlyphInfo] -> AtlasInfo -> Mesh
compileLabelMesh glyphs atlasInfo = Mesh $ do
  [vbo] <- GL.genObjectNames 1
  GL.bindBuffer GL.ArrayBuffer $= Just vbo

  -- Generate vertices for all glyphs with atlas UVs
  let vertices = generateLabelVertices glyphs (atlasGlyphUVs atlasInfo) 0
  SV.unsafeWith (SV.fromList vertices) $ \ptr -> do
    let size = fromIntegral $ length vertices * sizeOf (undefined :: GL.GLfloat)
    GL.bufferData GL.ArrayBuffer $= (size, ptr, GL.StaticDraw)

  GL.bindBuffer GL.ArrayBuffer $= Nothing

  let numQuads = length glyphs
      vertexCount = fromIntegral $ numQuads * 6
  return $
    MeshState
      { meshVbo = vbo,
        meshPush = do
          GL.bindBuffer GL.ArrayBuffer $= Just vbo
          -- Position: 2 floats, stride 16 bytes (4 floats), offset 0
          GL.clientState GL.VertexArray $= GL.Enabled
          GL.arrayPointer GL.VertexArray $= GL.VertexArrayDescriptor 2 GL.Float 16 nullPtr
          -- UV: 2 floats, stride 16 bytes, offset 8 bytes
          GL.clientState GL.TextureCoordArray $= GL.Enabled
          GL.arrayPointer GL.TextureCoordArray $= GL.VertexArrayDescriptor 2 GL.Float 16 (plusPtr nullPtr 8)
          GL.drawArrays GL.Triangles 0 vertexCount,
        meshPop = do
          GL.clientState GL.TextureCoordArray $= GL.Disabled
          GL.clientState GL.VertexArray $= GL.Disabled
          GL.bindBuffer GL.ArrayBuffer $= Nothing
      }

-- | Generate vertices for label glyphs (position + UV)
generateLabelVertices :: [GlyphInfo] -> [(Float, Float, Float, Float)] -> Float -> [GL.GLfloat]
generateLabelVertices [] _ _ = []
generateLabelVertices _ [] _ = []
generateLabelVertices (g : gs) ((u0, v0, u1, v1) : uvs) xOffset =
  let w = fromIntegral $ glyphWidth g
      h = fromIntegral $ glyphHeight g
      bx = fromIntegral $ glyphBearingX g
      by = fromIntegral $ glyphBearingY g
      x = xOffset + bx
      y = by - h

      -- Two triangles for the quad, using atlas UVs
      quadVerts =
        [ -- First triangle (bottom-left, bottom-right, top-right)
          x,
          y,
          u0,
          v1, -- bottom-left
          x + w,
          y,
          u1,
          v1, -- bottom-right
          x + w,
          y + h,
          u1,
          v0, -- top-right
          -- Second triangle (bottom-left, top-right, top-left)
          x,
          y,
          u0,
          v1, -- bottom-left
          x + w,
          y + h,
          u1,
          v0, -- top-right
          x,
          y + h,
          u0,
          v0 -- top-left
        ]
      nextOffset = xOffset + fromIntegral (glyphAdvance g)
   in map realToFrac quadVerts ++ generateLabelVertices gs uvs nextOffset

-- | Create material for rendering label with color tint
labelMaterial :: GL.TextureObject -> Float -> Float -> Float -> Float -> Material
labelMaterial tex r g b a =
  Material . pure $
    MaterialState
      { materialPush = do
          GL.blend $= GL.Enabled
          GL.blendFunc $= (GL.SrcAlpha, GL.OneMinusSrcAlpha)
          GL.texture GL.Texture2D $= GL.Enabled
          GL.textureBinding GL.Texture2D $= Just tex
          GL.color $ GL.Color4 (realToFrac r) (realToFrac g) (realToFrac b) (realToFrac a :: GL.GLfloat),
        materialPop = do
          GL.textureBinding GL.Texture2D $= Nothing
          GL.texture GL.Texture2D $= GL.Disabled
          GL.blend $= GL.Disabled
      }