{-# 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 (Typeable (WithMaterial m)
[HookRel (WithMaterial m)]
[Hook (WithMaterial m)]
Set DefaultComponentType
IsExclusive (IsExclusiveRel (WithMaterial m))
(Typeable (WithMaterial m),
 IsExclusive (IsExclusiveRel (WithMaterial m))) =>
Set DefaultComponentType
-> [Hook (WithMaterial m)]
-> [Hook (WithMaterial m)]
-> [Hook (WithMaterial m)]
-> [HookRel (WithMaterial m)]
-> [HookRel (WithMaterial m)]
-> [HookRel (WithMaterial m)]
-> Component (WithMaterial m)
forall c.
(Typeable c, IsExclusive (IsExclusiveRel c)) =>
Set DefaultComponentType
-> [Hook c]
-> [Hook c]
-> [Hook c]
-> [HookRel c]
-> [HookRel c]
-> [HookRel c]
-> Component c
forall k (m :: k).
(Typeable m, Typeable k) =>
Typeable (WithMaterial m)
forall k (m :: k).
(Typeable m, Typeable k) =>
[HookRel (WithMaterial m)]
forall k (m :: k).
(Typeable m, Typeable k) =>
[Hook (WithMaterial m)]
forall k (m :: k).
(Typeable m, Typeable k) =>
Set DefaultComponentType
forall k (m :: k).
(Typeable m, Typeable k) =>
IsExclusive (IsExclusiveRel (WithMaterial m))
$crequired :: forall k (m :: k).
(Typeable m, Typeable k) =>
Set DefaultComponentType
required :: Set DefaultComponentType
$conAdd :: forall k (m :: k).
(Typeable m, Typeable k) =>
[Hook (WithMaterial m)]
onAdd :: [Hook (WithMaterial m)]
$conSet :: forall k (m :: k).
(Typeable m, Typeable k) =>
[Hook (WithMaterial m)]
onSet :: [Hook (WithMaterial m)]
$conRemove :: forall k (m :: k).
(Typeable m, Typeable k) =>
[Hook (WithMaterial m)]
onRemove :: [Hook (WithMaterial m)]
$conAddRel :: forall k (m :: k).
(Typeable m, Typeable k) =>
[HookRel (WithMaterial m)]
onAddRel :: [HookRel (WithMaterial m)]
$conSetRel :: forall k (m :: k).
(Typeable m, Typeable k) =>
[HookRel (WithMaterial m)]
onSetRel :: [HookRel (WithMaterial m)]
$conRemoveRel :: forall k (m :: k).
(Typeable m, Typeable k) =>
[HookRel (WithMaterial m)]
onRemoveRel :: [HookRel (WithMaterial m)]
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 :: forall m. Material m => RenderOptions -> System ()
renderMaterial RenderOptions
opts = Query System () -> System ()
forall w (m :: * -> *) out. MonadSystem w m => Query m out -> m ()
query_ (Query System () -> System ()) -> Query System () -> System ()
forall a b. (a -> b) -> a -> b
$ do
  (camera, layers) <- [q|Entity, RenderLayers / With Camera|]
  qrenderMaterial @m camera layers opts

qrenderMaterial :: forall m. (Material m) => CameraEntity -> RenderLayers -> RenderOptions -> Query System ()
qrenderMaterial :: forall m.
Material m =>
CameraEntity -> RenderLayers -> RenderOptions -> Query System ()
qrenderMaterial CameraEntity
camera RenderLayers
layers RenderOptions
opts = do
  device <- Query System RenderDevice
forall c (m :: * -> *) w.
(MonadSystem w m, Component c) =>
Query m c
qres
  queue <- qres
  let ext = Set ErasedBinding -> [ErasedBinding]
forall a. Set a -> [a]
Set.toList (Set ErasedBinding -> [ErasedBinding])
-> Set ErasedBinding -> [ErasedBinding]
forall a b. (a -> b) -> a -> b
$ forall (a :: [*]). Extension a => Set ErasedBinding
collectExtBindings @'[m]
  let fs = [ErasedBinding] -> [ErasedFetch]
eraseFetches [ErasedBinding]
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 :: forall m a.
(Material m, Ord a) =>
RenderOptions -> (CameraEntity -> Query System a) -> System ()
renderSortedMaterial RenderOptions
opts CameraEntity -> Query System a
f = Query System () -> System ()
forall w (m :: * -> *) out. MonadSystem w m => Query m out -> m ()
query_ (Query System () -> System ()) -> Query System () -> System ()
forall a b. (a -> b) -> a -> b
$ 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 :: forall m a.
(Material m, Ord a) =>
(CameraEntity -> Query System a)
-> CameraEntity -> RenderLayers -> RenderOptions -> Query System ()
qrenderSortedMaterial CameraEntity -> Query System a
f CameraEntity
camera RenderLayers
layers RenderOptions
opts = do
  device <- Query System RenderDevice
forall c (m :: * -> *) w.
(MonadSystem w m, Component c) =>
Query m c
qres
  queue <- qres
  let ext = Set ErasedBinding -> [ErasedBinding]
forall a. Set a -> [a]
Set.toList (Set ErasedBinding -> [ErasedBinding])
-> Set ErasedBinding -> [ErasedBinding]
forall a b. (a -> b) -> a -> b
$ forall (a :: [*]). Extension a => Set ErasedBinding
collectExtBindings @'[m]
  let fs = [ErasedBinding] -> [ErasedFetch]
eraseFetches [ErasedBinding]
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 CameraEntity
_ a
a) (From CameraEntity
_ a
b) -> a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
a a
b) =<< mapM (\(From CameraEntity
_ CameraEntity
e) -> CameraEntity -> a -> From a
forall c. CameraEntity -> c -> From c
From CameraEntity
e (a -> From a) -> Query System a -> Query System (From a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CameraEntity -> Query System a
f CameraEntity
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 :: [ErasedBinding] -> [ErasedFetch]
eraseFetches =
  (ErasedBinding -> ErasedFetch) -> [ErasedBinding] -> [ErasedFetch]
forall a b. (a -> b) -> [a] -> [b]
map
    ( \(ErasedBinding (m
m :: m) Proxy a
_ Proxy b
_) ->
        case forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
forall a b. (Typeable a, Typeable b) => Maybe (a :~: b)
eqT @m @MaterialType of
          Maybe (m :~: MaterialType)
Nothing -> ErasedFetch
forall a. HasCallStack => a
undefined
          Just m :~: MaterialType
Refl -> MaterialType -> ErasedFetch
eraseFetch m
MaterialType
m
    )

eraseFetch :: MaterialType -> ErasedFetch
eraseFetch :: MaterialType -> ErasedFetch
eraseFetch (MaterialType (Proxy m
_ :: Proxy m)) = FetchBindings (B m) -> ErasedFetch
forall (a :: * -> *). FetchBindings a -> ErasedFetch
ErasedFetch (FetchBindings (B m) -> ErasedFetch)
-> FetchBindings (B m) -> ErasedFetch
forall a b. (a -> b) -> a -> b
$ forall a. Material a => FetchBindings (B a)
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 :: CameraEntity
-> [ErasedFetch] -> Query System [(ErasedFetch, ErasedCam)]
qfetchCam CameraEntity
c [ErasedFetch]
x = [ErasedFetch]
-> (ErasedFetch -> Query System (ErasedFetch, ErasedCam))
-> Query System [(ErasedFetch, ErasedCam)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [ErasedFetch]
x ((ErasedFetch -> Query System (ErasedFetch, ErasedCam))
 -> Query System [(ErasedFetch, ErasedCam)])
-> (ErasedFetch -> Query System (ErasedFetch, ErasedCam))
-> Query System [(ErasedFetch, ErasedCam)]
forall a b. (a -> b) -> a -> b
$ \(ErasedFetch FetchBindings m
f) -> do
  FetchBindings {camera} <- FetchBindings m -> Query System (FetchBindings m)
forall a. a -> Query System a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FetchBindings m
f
  v <- camera c
  pure (ErasedFetch f, ErasedCam v)

qfetchBindings :: [(ErasedFetch, ErasedCam)] -> MeshEntity -> Query System [ErasedBindingValue]
qfetchBindings :: [(ErasedFetch, ErasedCam)]
-> CameraEntity -> Query System [ErasedBindingValue]
qfetchBindings [] CameraEntity
_ = [ErasedBindingValue] -> Query System [ErasedBindingValue]
forall a. a -> Query System a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
qfetchBindings ((ErasedFetch !FetchBindings m
f, ErasedCam (!a
a :: a)) : [(ErasedFetch, ErasedCam)]
xs) CameraEntity
e = do
  FetchBindings {mesh, result} <- FetchBindings m -> Query System (FetchBindings m)
forall a. a -> Query System a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FetchBindings m
f
  b <- mesh e
  let res = x -> y -> m CPU
result (a -> x
forall a b. a -> b
unsafeCoerce a
a) y
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