D2.hs

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

module Aztecs.GL.D2
  ( -- * OpenGL
    module Aztecs.GL.D2.Image,
    module Aztecs.GL.Material,
    module Aztecs.GL.Mesh,
    module Aztecs.GL.D2.Shape,
    module Aztecs.GL.D2.Sprite,
    render,

    -- * Transform
    module Aztecs.Transform,
  )
where

import Aztecs
import Aztecs.GL.D2.Image
import Aztecs.GL.D2.Shape
import Aztecs.GL.D2.Sprite
import Aztecs.GL.Internal
import Aztecs.GL.Material
import Aztecs.GL.Mesh
import Aztecs.GLFW
import Aztecs.Transform
import Control.Monad
import Control.Monad.IO.Class
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Graphics.Rendering.OpenGL (($=))
import qualified Graphics.Rendering.OpenGL as GL
import qualified Graphics.UI.GLFW as GLFW
import Prelude hiding (lookup)

-- | Render all entities with @Mesh@ or @OfMesh@, @Material@ or @OfMaterial@, and @Transform2D@ components
render :: (MonadIO m) => Access m ()
render = do
  windows <- system . readQuery $ (,) <$> query @_ @Window <*> query @_ @RawWindow
  forM_ windows $ \(window, RawWindow raw _) -> do
    liftIO $ do
      GLFW.makeContextCurrent (Just raw)

      -- Set viewport and clear
      GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral $ windowWidth window) (fromIntegral $ windowHeight window))
      GL.clearColor $= GL.Color4 0 0 0 1
      GL.clear [GL.ColorBuffer]

      -- Set up orthographic projection
      GL.matrixMode $= GL.Projection
      GL.loadIdentity
      GL.ortho 0 (fromIntegral $ windowWidth window) 0 (fromIntegral $ windowHeight window) (-1) 1
      GL.matrixMode $= GL.Modelview 0
      GL.loadIdentity

    -- Get render groups and render each group
    (_, RenderGroups groups) <- renderGroups
    forM_ (Map.toList groups) $ \(RenderGroupKey meshE matE, entityEs) -> renderGroup meshE matE entityEs

-- | Render all entities with @Mesh@ or @OfMesh@, @Material@ or @OfMaterial@, and @Transform2D@ components
renderGroup :: (MonadIO m) => EntityID -> EntityID -> Set.Set EntityID -> Access m ()
renderGroup meshE matE entitySet = do
  let entities = Set.toList entitySet
  mMeshState <- do
    mMeshState <- lookup meshE
    case mMeshState of
      Just ms -> return $ Just ms
      Nothing -> do
        mMesh <- lookup meshE
        case mMesh of
          Just mesh -> do
            ms <- liftIO $ unMesh mesh
            insert meshE $ bundle ms
            return $ Just ms
          Nothing -> return Nothing
  mMatState <- do
    mMatState <- lookup matE
    case mMatState of
      Just ms -> return $ Just ms
      Nothing -> do
        mMat <- lookup matE
        case mMat of
          Just mat -> do
            ms <- liftIO $ unMaterial mat
            insert matE $ bundle ms
            return $ Just ms
          Nothing -> return Nothing
  case (mMeshState, mMatState) of
    (Just meshState, Just matState) -> do
      transforms <- forM entities $ \e -> do
        mTrans <- lookup e
        return (e, mTrans)

      liftIO $ do
        materialPush matState
        forM_ transforms $ \(_, mTrans) ->
          case mTrans of
            Just (GlobalTransform trans) -> renderMeshWithTransform meshState trans
            Nothing -> return ()
        materialPop matState
    _ -> return ()

renderMeshWithTransform :: MeshState -> Transform2D -> IO ()
renderMeshWithTransform md t = do
  let V2 tx ty = transformTranslation t
      V2 sx sy = transformScale t
      rot = transformRotation t
  GL.preservingMatrix $ do
    GL.translate $ GL.Vector3 (realToFrac tx) (realToFrac ty) (0 :: GL.GLfloat)
    GL.rotate (realToFrac rot) $ GL.Vector3 0 0 (1 :: GL.GLfloat)
    GL.scale (realToFrac sx) (realToFrac sy) (1 :: GL.GLfloat)
    meshPush md
    meshPop md