module Mischief.Render.Image where

import Codec.Picture qualified as P
import Control.Monad
import Data.Foldable
import Data.Primitive.Ptr
import Foreign.C.ConstPtr
import Mischief.Assets
import Mischief.Assets.Image
import Mischief.ECS
import Mischief.ECS.Observer
import Mischief.ECS.Systems qualified as S
import Mischief.Render.Core
import Mischief.Render.Texture
import Mischief.WGPU
import Mischief.WGPU.Types.Enums
import Mischief.WGPU.Types.General

newtype ImageTexture = ImageTexture Texture deriving anyclass (Typeable ImageTexture
[HookRel ImageTexture]
[Hook ImageTexture]
Set DefaultComponentType
IsExclusive (IsExclusiveRel ImageTexture)
(Typeable ImageTexture,
 IsExclusive (IsExclusiveRel ImageTexture)) =>
Set DefaultComponentType
-> [Hook ImageTexture]
-> [Hook ImageTexture]
-> [Hook ImageTexture]
-> [HookRel ImageTexture]
-> [HookRel ImageTexture]
-> [HookRel ImageTexture]
-> Component ImageTexture
forall c.
(Typeable c, IsExclusive (IsExclusiveRel c)) =>
Set DefaultComponentType
-> [Hook c]
-> [Hook c]
-> [Hook c]
-> [HookRel c]
-> [HookRel c]
-> [HookRel c]
-> Component c
$crequired :: Set DefaultComponentType
required :: Set DefaultComponentType
$conAdd :: [Hook ImageTexture]
onAdd :: [Hook ImageTexture]
$conSet :: [Hook ImageTexture]
onSet :: [Hook ImageTexture]
$conRemove :: [Hook ImageTexture]
onRemove :: [Hook ImageTexture]
$conAddRel :: [HookRel ImageTexture]
onAddRel :: [HookRel ImageTexture]
$conSetRel :: [HookRel ImageTexture]
onSetRel :: [HookRel ImageTexture]
$conRemoveRel :: [HookRel ImageTexture]
onRemoveRel :: [HookRel ImageTexture]
Component)

newtype ImageTextureView = ImageTextureView TextureView deriving anyclass (Typeable ImageTextureView
[HookRel ImageTextureView]
[Hook ImageTextureView]
Set DefaultComponentType
IsExclusive (IsExclusiveRel ImageTextureView)
(Typeable ImageTextureView,
 IsExclusive (IsExclusiveRel ImageTextureView)) =>
Set DefaultComponentType
-> [Hook ImageTextureView]
-> [Hook ImageTextureView]
-> [Hook ImageTextureView]
-> [HookRel ImageTextureView]
-> [HookRel ImageTextureView]
-> [HookRel ImageTextureView]
-> Component ImageTextureView
forall c.
(Typeable c, IsExclusive (IsExclusiveRel c)) =>
Set DefaultComponentType
-> [Hook c]
-> [Hook c]
-> [Hook c]
-> [HookRel c]
-> [HookRel c]
-> [HookRel c]
-> Component c
$crequired :: Set DefaultComponentType
required :: Set DefaultComponentType
$conAdd :: [Hook ImageTextureView]
onAdd :: [Hook ImageTextureView]
$conSet :: [Hook ImageTextureView]
onSet :: [Hook ImageTextureView]
$conRemove :: [Hook ImageTextureView]
onRemove :: [Hook ImageTextureView]
$conAddRel :: [HookRel ImageTextureView]
onAddRel :: [HookRel ImageTextureView]
$conSetRel :: [HookRel ImageTextureView]
onSetRel :: [HookRel ImageTextureView]
$conRemoveRel :: [HookRel ImageTextureView]
onRemoveRel :: [HookRel ImageTextureView]
Component)

data ImageUploadingPlugin

data QueueUpload = QueueUpload deriving (Typeable QueueUpload
[HookRel QueueUpload]
[Hook QueueUpload]
Set DefaultComponentType
IsExclusive (IsExclusiveRel QueueUpload)
(Typeable QueueUpload, IsExclusive (IsExclusiveRel QueueUpload)) =>
Set DefaultComponentType
-> [Hook QueueUpload]
-> [Hook QueueUpload]
-> [Hook QueueUpload]
-> [HookRel QueueUpload]
-> [HookRel QueueUpload]
-> [HookRel QueueUpload]
-> Component QueueUpload
forall c.
(Typeable c, IsExclusive (IsExclusiveRel c)) =>
Set DefaultComponentType
-> [Hook c]
-> [Hook c]
-> [Hook c]
-> [HookRel c]
-> [HookRel c]
-> [HookRel c]
-> Component c
$crequired :: Set DefaultComponentType
required :: Set DefaultComponentType
$conAdd :: [Hook QueueUpload]
onAdd :: [Hook QueueUpload]
$conSet :: [Hook QueueUpload]
onSet :: [Hook QueueUpload]
$conRemove :: [Hook QueueUpload]
onRemove :: [Hook QueueUpload]
$conAddRel :: [HookRel QueueUpload]
onAddRel :: [HookRel QueueUpload]
$conSetRel :: [HookRel QueueUpload]
onSetRel :: [HookRel QueueUpload]
$conRemoveRel :: [HookRel QueueUpload]
onRemoveRel :: [HookRel QueueUpload]
Component)

instance Plugin ImageUploadingPlugin where
  init :: System ()
init = do
    System () -> SystemConfig
forall a. ToSystems a => a -> SystemConfig
systems System ()
uploadImages
      SystemConfig -> (SystemConfig -> System ()) -> System ()
forall a b. a -> (a -> b) -> b
& forall sc. Schedule sc => SystemConfig -> System ()
forall {k} (sc :: k). Schedule sc => SystemConfig -> System ()
schedule @Update
    System ()
enableImageUploadOnLoad

uploadImages :: System ()
uploadImages :: System ()
uploadImages = do
  images <- Query System (Entity, Image) -> System [(Entity, Image)]
forall w (m :: * -> *) out.
MonadSystem w m =>
Query m out -> m [out]
query [q|Entity, Image / With QueueUpload|]
  for_ images $ \(Entity
e, Image
_) -> C QueueUpload -> Entity -> System ()
forall c. Collectable c ToRemove => c -> Entity -> System ()
remove (forall a. C a
forall {k} (a :: k). C a
C @QueueUpload) Entity
e

  device <- res @RenderDevice
  queue <- res @RenderQueue

  for_ ((,) <$> device <*> queue) $ \(RenderDevice
device, RenderQueue
queue) -> do
    [(Entity, Image)] -> ((Entity, Image) -> System ()) -> System ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(Entity, Image)]
images (((Entity, Image) -> System ()) -> System ())
-> ((Entity, Image) -> System ()) -> System ()
forall a b. (a -> b) -> a -> b
$ \(Entity
entity, Image
image) -> do
      IO (Texture, TextureView)
-> ((Texture, TextureView) -> System ()) -> System ()
forall w (m :: * -> *) a.
MonadSystem w m =>
IO a -> (a -> System ()) -> m ()
runAfter
        ( do
            tex <- RenderDevice -> Image -> IO Texture
createTextureForImage RenderDevice
device Image
image
            uploadImage queue image tex
            view <- TextureView <$> wgpuTextureCreateView tex.texture (ConstPtr nullPtr)

            pure (tex, view)
        )
        ( \(Texture
tex, TextureView
view) -> do
            forall b. (HasCallStack, Bundle b) => b -> Entity -> System ()
(ImageTexture, ImageTextureView) -> Entity -> System ()
forall b. Bundle b => b -> Entity -> System ()
insert (Texture -> ImageTexture
ImageTexture Texture
tex, TextureView -> ImageTextureView
ImageTextureView TextureView
view) Entity
entity
        )

queueUploadOnLoad :: OnLoad Image -> System ()
queueUploadOnLoad :: OnLoad Image -> System ()
queueUploadOnLoad (OnLoad Entity
e) = forall b. (HasCallStack, Bundle b) => b -> Entity -> System ()
QueueUpload -> Entity -> System ()
forall b. Bundle b => b -> Entity -> System ()
insert QueueUpload
QueueUpload Entity
e

data ImageObserver = ImageObserver deriving (Typeable ImageObserver
[HookRel ImageObserver]
[Hook ImageObserver]
Set DefaultComponentType
IsExclusive (IsExclusiveRel ImageObserver)
(Typeable ImageObserver,
 IsExclusive (IsExclusiveRel ImageObserver)) =>
Set DefaultComponentType
-> [Hook ImageObserver]
-> [Hook ImageObserver]
-> [Hook ImageObserver]
-> [HookRel ImageObserver]
-> [HookRel ImageObserver]
-> [HookRel ImageObserver]
-> Component ImageObserver
forall c.
(Typeable c, IsExclusive (IsExclusiveRel c)) =>
Set DefaultComponentType
-> [Hook c]
-> [Hook c]
-> [Hook c]
-> [HookRel c]
-> [HookRel c]
-> [HookRel c]
-> Component c
$crequired :: Set DefaultComponentType
required :: Set DefaultComponentType
$conAdd :: [Hook ImageObserver]
onAdd :: [Hook ImageObserver]
$conSet :: [Hook ImageObserver]
onSet :: [Hook ImageObserver]
$conRemove :: [Hook ImageObserver]
onRemove :: [Hook ImageObserver]
$conAddRel :: [HookRel ImageObserver]
onAddRel :: [HookRel ImageObserver]
$conSetRel :: [HookRel ImageObserver]
onSetRel :: [HookRel ImageObserver]
$conRemoveRel :: [HookRel ImageObserver]
onRemoveRel :: [HookRel ImageObserver]
Component)

enableImageUploadOnLoad :: System ()
enableImageUploadOnLoad :: System ()
enableImageUploadOnLoad = System Entity -> System ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (System Entity -> System ()) -> System Entity -> System ()
forall a b. (a -> b) -> a -> b
$ (Observer (OnLoad Image), ImageObserver) -> System Entity
forall b. (HasCallStack, Bundle b) => b -> System Entity
spawn ((OnLoad Image -> System ()) -> Observer (OnLoad Image)
forall e. (e -> System ()) -> Observer e
Observer OnLoad Image -> System ()
queueUploadOnLoad, ImageObserver
ImageObserver)

disableImageUploadOnLoad :: System ()
disableImageUploadOnLoad :: System ()
disableImageUploadOnLoad = Query System Entity -> System (Maybe Entity)
forall w (m :: * -> *) out.
MonadSystem w m =>
Query m out -> m (Maybe out)
single [q|Entity / With ImageObserver|] System (Maybe Entity) -> (Maybe Entity -> System ()) -> System ()
forall a b. System a -> (a -> System b) -> System b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Entity -> System ()
despawn (Entity -> System ())
-> (Maybe Entity -> Entity) -> Maybe Entity -> System ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Entity -> Entity
forall (f :: * -> *) a. (HasCallStack, Unwrappable f) => f a -> a
unwrap