mischief-render-0.1.0.0: src/Mischief/Render/Material.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}

-- {-# LANGUAGE GADTSyntax #-}
-- {-# LANGUAGE RequiredTypeArguments #-}

module Mischief.Render.Material
  ( WithMaterial (..),
    renderMaterial,
    renderSortedMaterial,
  )
where

import Control.Monad (unless, when)
import Data.Data
import Data.List (sort, sortBy)
import Data.Set qualified as Set
import Data.Traversable
import GHC.TypeLits
import Mischief.ECS
import Mischief.Render.Camera (Camera, CameraTexture (CameraTexture))
import Mischief.Render.Core
import Mischief.Render.Layers (RenderLayers)
import Mischief.Render.Layers qualified as Layers
import Mischief.Render.Material.Definition (Clear, DrawCommand (Draw), Extension (collectExtBindings), FetchBindings (..), Material (IsPhantom, fetch), MaterialType (..), RenderOptions (..), render)
import Mischief.Render.Material.Pipeline (qgetPipeline)
import Mischief.Render.Texture
import Mischief.Shader.Internal.Bindings (ErasedBinding (..), ErasedBindingValue (..))
import Unsafe.Coerce (unsafeCoerce)

-- schedule @RenderLast (systems renderEntities)

data WithMaterial m = WithMaterial deriving (Component)

-- spawn' :: forall m. (Material m) => System Entity
-- spawn' = case eqT @(IsPhantom m) @True of
--   Nothing -> Mischief.ECS.spawn (MaterialType $ Proxy @m)
--   Just _ -> Mischief.ECS.spawn (MaterialType $ Proxy @m, PhantomMaterial)

-- retrieve :: forall m. (Material m) => System Entity
-- retrieve = do
--   e <- queryOne [q|Entity / With (MaterialMarker m)|]
--   case e of
--     Just e -> pure e
--     Nothing -> spawn' @m

-- renderEntities :: System ()
-- renderEntities = query_ $ do
--   camera <- [q|Entity / With Camera|]
--   (MaterialType (_ :: Proxy m), e) <- [q|MaterialType, Entity / Without PhantomMaterial|]
--   qrenderMaterial @m camera

renderMaterial :: forall m. (Material m) => RenderOptions -> System ()
renderMaterial opts = query_ $ do
  (camera, layers) <- [q|Entity, RenderLayers / With Camera|]
  qrenderMaterial @m camera layers opts

qrenderMaterial :: forall m. (Material m) => CameraEntity -> RenderLayers -> RenderOptions -> Query System ()
qrenderMaterial camera layers opts = do
  device <- qres
  queue <- qres
  let ext = Set.toList $ collectExtBindings @'[m]
  let fs = eraseFetches ext
  cams <- qfetchCam camera fs

  commands <- qcollect $ do
    (sprite, layers') <- [q|(Entity, RenderLayers) / With (WithMaterial m)|]
    unless (Layers.intersects layers layers') qstop
    b <- qfetchBindings cams sprite
    pure $ Draw b opts.nvertices

  CameraTexture texture <- qget camera [qd|CameraTexture|]
  pipeline <- qgetPipeline @m texture.desc.format
  qlift $ render @m device queue pipeline opts (Texture texture.currentTexture texture.desc) (map (.comp) commands)

renderSortedMaterial :: forall m a. (Material m, Ord a) => RenderOptions -> (MeshEntity -> Query System a) -> System ()
renderSortedMaterial opts f = query_ $ do
  (camera, layers) <- [q|(Entity, RenderLayers) / With Camera|]
  qrenderSortedMaterial @m f camera layers opts

qrenderSortedMaterial :: forall m a. (Material m, Ord a) => (MeshEntity -> Query System a) -> CameraEntity -> RenderLayers -> RenderOptions -> Query System ()
qrenderSortedMaterial f camera layers opts = do
  device <- qres
  queue <- qres
  let ext = Set.toList $ collectExtBindings @'[m]
  let fs = eraseFetches ext
  cams <- qfetchCam camera fs

  commands <- qcollect $ do
    sprites <- qcollect $ do
      (entity, layers') <- [q|(Entity, RenderLayers) / With (WithMaterial m)|]
      unless (Layers.intersects layers layers') qstop
      qpure entity & qmap (const entity)

    sprite <- fst <$> (qentity . qiter . sortBy (\(From _ a) (From _ b) -> compare a b) =<< mapM (\(From _ e) -> From e <$> f e) sprites)

    b <- qfetchBindings cams sprite
    pure $ Draw b opts.nvertices

  CameraTexture texture <- qget camera [qd|CameraTexture|]
  pipeline <- qgetPipeline @m texture.desc.format
  qlift $ render @m device queue pipeline opts (Texture texture.currentTexture texture.desc) (map (.comp) commands)

data ErasedFetch where
  ErasedFetch :: FetchBindings m -> ErasedFetch

data ErasedCam where
  ErasedCam :: a -> ErasedCam

eraseFetches :: [ErasedBinding] -> [ErasedFetch]
eraseFetches =
  map
    ( \(ErasedBinding (m :: m) _ _) ->
        case eqT @m @MaterialType of
          Nothing -> undefined
          Just Refl -> eraseFetch m
    )

eraseFetch :: MaterialType -> ErasedFetch
eraseFetch (MaterialType (_ :: Proxy m)) = ErasedFetch $ fetch @m

-- qgetFetches :: [ErasedBinding] -> Query System [ErasedFetch]
-- qgetFetches [] = pure []
-- qgetFetches (ErasedBinding (_ :: Proxy m) _ : xs) = do
--   !fetch <- qlift $ single [q|(FetchBindings m)|]
--   ((ErasedFetch $ unwrap fetch) :) <$> qgetFetches xs

qfetchCam :: CameraEntity -> [ErasedFetch] -> Query System [(ErasedFetch, ErasedCam)]
qfetchCam c x = for x $ \(ErasedFetch f) -> do
  FetchBindings {camera} <- pure f
  v <- camera c
  pure (ErasedFetch f, ErasedCam v)

qfetchBindings :: [(ErasedFetch, ErasedCam)] -> MeshEntity -> Query System [ErasedBindingValue]
qfetchBindings [] _ = pure []
qfetchBindings ((ErasedFetch !f, ErasedCam (!a :: a)) : xs) e = do
  FetchBindings {mesh, result} <- pure f
  b <- mesh e
  let res = result (unsafeCoerce a) b
  (ErasedBindingValue res :) <$> qfetchBindings xs e

-- fetchExtensionsCam :: forall m. (Material m) => CameraEntity -> Query System [ErasedBindingValue]
-- fetchExtensionsCam c = do
--   let ext = Set.toList $ collectExtBindings

-- fetchExtensions :: forall m. (Material m) => MeshEntity -> CameraEntity -> Query System [ErasedBindingValue]
-- fetchExtensions e c = do
--   let ext = Set.toList $ collectExtBindings @(Extends m)
--   for ext $ \(ErasedBinding _ (_ :: Proxy b)) -> ErasedBindingValue <$> qfetchBinding @b e c