Internal.hs

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

module Aztecs.GL.Internal
  ( inParentWindowContext,
    inAnyWindowContext,
    OfMesh (..),
    OfMaterial (..),
    MeshState (..),
    MaterialState (..),
    RenderGroupKey (..),
    RenderGroups (..),
    renderGroups,
    registerRenderable,
    unregisterRenderable,
  )
where

import Aztecs
import Aztecs.GLFW
import Control.Monad
import Control.Monad.IO.Class
import Data.Map (Map)
import qualified Data.Map.Strict as Map
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Vector as V
import Debug.Trace
import qualified Graphics.Rendering.OpenGL as GL
import qualified Graphics.UI.GLFW as GLFW
import Prelude hiding (lookup)

-- | Mesh data component
data MeshState = MeshState
  { meshVbo :: !GL.BufferObject,
    meshPush :: !(IO ()),
    meshPop :: !(IO ())
  }

instance (Monad m) => Component m MeshState

-- | Material state component
data MaterialState = MaterialState
  { -- | Push the material state before rendering
    materialPush :: !(IO ()),
    -- | Pop the material state after rendering
    materialPop :: !(IO ())
  }

instance (Monad m) => Component m MaterialState

-- | OfMesh component that references an entity with a @Mesh@ component
newtype OfMesh = OfMesh {unOfMesh :: EntityID}
  deriving (Show, Eq)

instance (MonadIO m) => Component m OfMesh where
  componentOnInsert e (OfMesh meshE) = do
    mMat <- lookup e
    case mMat of
      Just (OfMaterial matE) -> registerRenderable e meshE matE
      Nothing -> do
        mMatState <- lookup @_ @MaterialState e
        case mMatState of
          Just _ -> registerRenderable e meshE e
          Nothing -> return ()
  componentOnChange e (OfMesh oldMeshE) (OfMesh newMeshE) = when (oldMeshE /= newMeshE) $ do
    mMat <- lookup e
    case mMat of
      Just (OfMaterial matE) -> do
        unregisterRenderable e oldMeshE matE
        registerRenderable e newMeshE matE
      Nothing -> do
        mMatState <- lookup @_ @MaterialState e
        case mMatState of
          Just _ -> do
            unregisterRenderable e oldMeshE e
            registerRenderable e newMeshE e
          Nothing -> return ()
  componentOnRemove e (OfMesh meshE) = do
    mMat <- lookup e
    case mMat of
      Just (OfMaterial matE) -> unregisterRenderable e meshE matE
      Nothing -> do
        mMatState <- lookup @_ @MaterialState e
        case mMatState of
          Just _ -> unregisterRenderable e meshE e
          Nothing -> return ()

-- | OfMaterial component that references an entity with a @Material@ component
newtype OfMaterial = OfMaterial {unOfMaterial :: EntityID}
  deriving (Show, Eq)

instance (MonadIO m) => Component m OfMaterial where
  componentOnInsert e (OfMaterial matE) = do
    mMesh <- lookup e
    case mMesh of
      Just (OfMesh meshE) -> registerRenderable e meshE matE
      Nothing -> do
        mMeshState <- lookup @_ @MeshState e
        case mMeshState of
          Just _ -> registerRenderable e e matE
          Nothing -> return ()
  componentOnChange e (OfMaterial oldMatE) (OfMaterial newMatE) = when (oldMatE /= newMatE) $ do
    mMesh <- lookup e
    case mMesh of
      Just (OfMesh meshE) -> do
        unregisterRenderable e meshE oldMatE
        registerRenderable e meshE newMatE
      Nothing -> do
        mMeshState <- lookup @_ @MeshState e
        case mMeshState of
          Just _ -> do
            unregisterRenderable e e oldMatE
            registerRenderable e e newMatE
          Nothing -> return ()
  componentOnRemove e (OfMaterial matE) = do
    mMesh <- lookup e
    case mMesh of
      Just (OfMesh meshE) -> unregisterRenderable e meshE matE
      Nothing -> do
        mMeshState <- lookup @_ @MeshState e
        case mMeshState of
          Just _ -> unregisterRenderable e e matE
          Nothing -> return ()

-- | Unique key for a render group
data RenderGroupKey = RenderGroupKey
  { -- | EntityID of the render group's mesh
    renderGroupKeyMesh :: EntityID,
    -- | EntityID of the render group's material
    renderGroupKeyMaterial :: EntityID
  }
  deriving (Show, Eq, Ord)

-- | Render groups component
newtype RenderGroups = RenderGroups {unRenderGroups :: Map RenderGroupKey (Set EntityID)}
  deriving (Show, Eq)

instance (Monad m) => Component m RenderGroups

-- | Get or create the @RenderGroups@ singleton
renderGroups :: (Monad m) => Access m (EntityID, RenderGroups)
renderGroups = do
  res <- system . readQuery $ (,) <$> entity <*> query @_ @RenderGroups
  case V.uncons res of
    Just ((e, rg), _) -> return (e, rg)
    Nothing -> do
      let rg = RenderGroups Map.empty
      e <- spawn $ bundle rg
      return (e, rg)

-- | Register an entity as renderable with the given mesh and material entity IDs
registerRenderable :: (MonadIO m) => EntityID -> EntityID -> EntityID -> Access m ()
registerRenderable e meshE matE = do
  liftIO $ traceIO $ "[RenderGroups] registerRenderable entity=" ++ show e ++ ", meshE=" ++ show meshE ++ ", matE=" ++ show matE
  (rgE, RenderGroups groups) <- renderGroups
  let key = RenderGroupKey meshE matE
      newGroups = Map.insertWith Set.union key (Set.singleton e) groups
  insert rgE $ bundle (RenderGroups newGroups)

-- | Unregister an entity from its render group
unregisterRenderable :: (MonadIO m) => EntityID -> EntityID -> EntityID -> Access m ()
unregisterRenderable e meshE matE = do
  liftIO $ traceIO $ "[RenderGroups] unregisterRenderable entity=" ++ show e ++ ", meshE=" ++ show meshE ++ ", matE=" ++ show matE
  (rgE, RenderGroups groups) <- renderGroups
  let key = RenderGroupKey meshE matE
      newGroups = Map.update removeEntity key groups
      removeEntity es =
        let es' = Set.delete e es
         in if Set.null es' then Nothing else Just es'
  insert rgE $ bundle (RenderGroups newGroups)

-- | Run an action in this entity's parent window's OpenGL context
inParentWindowContext :: (MonadIO m) => EntityID -> Access m () -> Access m ()
inParentWindowContext e action = do
  res <- lookup e
  case res of
    Just (Parent parentE) -> do
      res' <- lookup parentE
      case res' of
        Just (RawWindow raw _) -> do
          liftIO . GLFW.makeContextCurrent $ Just raw
          action
        Nothing -> return ()
    Nothing -> return ()

-- | Run an action in any available window context
inAnyWindowContext :: (MonadIO m) => Access m () -> Access m ()
inAnyWindowContext action = do
  windows <- system . readQuery $ query @_ @RawWindow
  case V.uncons windows of
    Just (RawWindow raw _, _) -> do
      liftIO . GLFW.makeContextCurrent $ Just raw
      action
    Nothing -> return ()