Shape.hs

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

module Aztecs.GL.D2.Shape
  ( -- * Shapes
    Rectangle (..),
    Circle (..),
    Triangle (..),
  )
where

import Aztecs
import Aztecs.GL.Internal
import Aztecs.GL.Mesh
import Control.Monad
import Control.Monad.IO.Class
import qualified Data.Vector.Storable as SV
import Foreign.Ptr
import Foreign.Storable
import Graphics.Rendering.OpenGL (($=))
import qualified Graphics.Rendering.OpenGL as GL
import Prelude hiding (lookup)

-- | Rectangle component
data Rectangle = Rectangle
  { rectangleWidth :: !Float,
    rectangleHeight :: !Float
  }
  deriving (Show, Eq)

instance (MonadIO m) => Component m Rectangle where
  componentOnInsert e rect = inParentWindowContext e $ do
    let mesh = compileRectangle rect
    meshE <- spawn $ bundle mesh
    insert e $ bundle (OfMesh meshE)
  componentOnChange e oldRect newRect = when (oldRect /= newRect) . inParentWindowContext e $ do
    mMesh <- lookup e
    case mMesh of
      Just (OfMesh meshE) -> do
        mData <- lookup meshE
        case mData of
          Just md -> liftIO $ GL.deleteObjectName (meshVbo md)
          Nothing -> return ()
        let newMesh = compileRectangle newRect
        meshData <- liftIO $ unMesh newMesh
        insert meshE $ bundle meshData
      Nothing -> do
        let mesh = compileRectangle newRect
        meshE <- spawn $ bundle mesh
        insert e $ bundle (OfMesh meshE)
  componentOnRemove e _ = inParentWindowContext e $ do
    mMesh <- lookup e
    case mMesh of
      Just (OfMesh meshE) -> do
        mData <- lookup meshE
        case mData of
          Just md -> do
            liftIO $ GL.deleteObjectName (meshVbo md)
            despawn meshE
          Nothing -> return ()
        _ <- remove @_ @OfMesh e
        return ()
      Nothing -> return ()

-- | Circle component
data Circle = Circle
  { circleRadius :: !Float,
    circleSegments :: !Int
  }
  deriving (Show, Eq)

instance (MonadIO m) => Component m Circle where
  componentOnInsert e circ = inParentWindowContext e $ do
    let mesh = compileCircle circ
    meshE <- spawn $ bundle mesh
    insert e $ bundle (OfMesh meshE)
  componentOnChange e oldCirc newCirc = when (oldCirc /= newCirc) . inParentWindowContext e $ do
    mMesh <- lookup e
    case mMesh of
      Just (OfMesh meshE) -> do
        mData <- lookup meshE
        case mData of
          Just md -> liftIO $ GL.deleteObjectName (meshVbo md)
          Nothing -> return ()
        let newMesh = compileCircle newCirc
        meshData <- liftIO $ unMesh newMesh
        insert meshE $ bundle meshData
      Nothing -> do
        let mesh = compileCircle newCirc
        meshE <- spawn $ bundle mesh
        insert e $ bundle (OfMesh meshE)
  componentOnRemove e _ = inParentWindowContext e $ do
    mMesh <- lookup e
    case mMesh of
      Just (OfMesh meshE) -> do
        mData <- lookup meshE
        case mData of
          Just md -> do
            liftIO $ GL.deleteObjectName (meshVbo md)
            despawn meshE
          Nothing -> return ()
        _ <- remove @_ @OfMesh e
        return ()
      Nothing -> return ()

-- | Triangle component
data Triangle = Triangle
  { triangleX1 :: !Float,
    triangleY1 :: !Float,
    triangleX2 :: !Float,
    triangleY2 :: !Float,
    triangleX3 :: !Float,
    triangleY3 :: !Float
  }
  deriving (Show, Eq)

instance (MonadIO m) => Component m Triangle where
  componentOnInsert e tri = inParentWindowContext e $ do
    let mesh = compileTriangle tri
    meshE <- spawn $ bundle mesh
    insert e $ bundle (OfMesh meshE)
  componentOnChange e oldTri newTri = when (oldTri /= newTri) . inParentWindowContext e $ do
    mMesh <- lookup e
    case mMesh of
      Just (OfMesh meshE) -> do
        mData <- lookup meshE
        case mData of
          Just md -> liftIO $ GL.deleteObjectName (meshVbo md)
          Nothing -> return ()
        let newMesh = compileTriangle newTri
        meshData <- liftIO $ unMesh newMesh
        insert meshE $ bundle meshData
      Nothing -> do
        let mesh = compileTriangle newTri
        meshE <- spawn $ bundle mesh
        insert e $ bundle (OfMesh meshE)
  componentOnRemove e _ = inParentWindowContext e $ do
    mMesh <- lookup e
    case mMesh of
      Just (OfMesh meshE) -> do
        mData <- lookup meshE
        case mData of
          Just md -> do
            liftIO $ GL.deleteObjectName (meshVbo md)
            despawn meshE
          Nothing -> return ()
        _ <- remove @_ @OfMesh e
        return ()
      Nothing -> return ()

-- | Compile a rectangle into a VBO mesh with texture coordinates
compileRectangle :: Rectangle -> Mesh
compileRectangle (Rectangle w h) =
  let hw = w / 2
      hh = h / 2
      -- Interleaved: x, y, u, v for each vertex (V flipped for OpenGL)
      vertices =
        SV.fromList
          [ -hw,
            -hh,
            0,
            1, -- bottom-left
            hw,
            -hh,
            1,
            1, -- bottom-right
            hw,
            hh,
            1,
            0, -- top-right
            -hw,
            hh,
            0,
            0 -- top-left
          ] ::
          SV.Vector GL.GLfloat
   in compileMeshWithUV vertices GL.Quads

-- | Compile a circle into a VBO mesh
compileCircle :: Circle -> Mesh
compileCircle (Circle radius segments) =
  let angles = [2 * pi * fromIntegral i / fromIntegral segments | i <- [0 .. segments]]
      vertices = SV.fromList $ [0, 0] ++ concatMap (\a -> [radius * cos a, radius * sin a]) angles :: SV.Vector GL.GLfloat
   in compileMesh vertices GL.TriangleFan

-- | Compile a triangle into a VBO mesh
compileTriangle :: Triangle -> Mesh
compileTriangle (Triangle x1 y1 x2 y2 x3 y3) =
  let vertices = SV.fromList [x1, y1, x2, y2, x3, y3] :: SV.Vector GL.GLfloat
   in compileMesh vertices GL.Triangles

-- | Compile vertices into a VBO mesh (position only)
compileMesh :: SV.Vector GL.GLfloat -> GL.PrimitiveMode -> Mesh
compileMesh vertices mode = Mesh $ do
  let vertexCount = fromIntegral $ SV.length vertices `div` 2
  vbo <- uploadVbo vertices
  return $ simpleMeshState vbo vertexCount mode

-- | Compile vertices with UV into a VBO mesh (interleaved: x, y, u, v)
compileMeshWithUV :: SV.Vector GL.GLfloat -> GL.PrimitiveMode -> Mesh
compileMeshWithUV vertices mode = Mesh $ do
  let vertexCount = fromIntegral $ SV.length vertices `div` 4
  vbo <- uploadVbo vertices
  return $ texturedMeshState vbo vertexCount mode

-- | Upload vertex data to a new VBO
uploadVbo :: SV.Vector GL.GLfloat -> IO GL.BufferObject
uploadVbo vertices = do
  [vbo] <- GL.genObjectNames 1
  GL.bindBuffer GL.ArrayBuffer $= Just vbo
  SV.unsafeWith vertices $ \ptr -> do
    let dataSize = fromIntegral $ SV.length vertices * sizeOf (undefined :: GL.GLfloat)
    GL.bufferData GL.ArrayBuffer $= (dataSize, ptr, GL.StaticDraw)
  GL.bindBuffer GL.ArrayBuffer $= Nothing
  return vbo

-- | Create MeshState for non-textured mesh (position only, stride 0)
simpleMeshState :: GL.BufferObject -> GL.GLint -> GL.PrimitiveMode -> MeshState
simpleMeshState vbo vertexCount mode =
  MeshState
    { meshVbo = vbo,
      meshPush = do
        GL.bindBuffer GL.ArrayBuffer $= Just vbo
        GL.clientState GL.VertexArray $= GL.Enabled
        GL.arrayPointer GL.VertexArray $= GL.VertexArrayDescriptor 2 GL.Float 0 nullPtr
        GL.drawArrays mode 0 vertexCount,
      meshPop = do
        GL.clientState GL.VertexArray $= GL.Disabled
        GL.bindBuffer GL.ArrayBuffer $= Nothing
    }

-- | Create MeshState for textured mesh (interleaved x,y,u,v, stride 16)
texturedMeshState :: GL.BufferObject -> GL.GLint -> GL.PrimitiveMode -> MeshState
texturedMeshState vbo vertexCount mode =
  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 mode 0 vertexCount,
      meshPop = do
        GL.clientState GL.TextureCoordArray $= GL.Disabled
        GL.clientState GL.VertexArray $= GL.Disabled
        GL.bindBuffer GL.ArrayBuffer $= Nothing
    }