module Mischief.Render.Camera where

import Codec.Picture
import Control.Monad
import Control.Monad.IO.Class
import Data.Bits
import Data.Default
import Data.Foldable
import Data.Maybe (fromMaybe)
import Data.Primitive.Ptr (nullPtr)
import Data.Vector.Storable qualified as VS
import Data.Word
import Foreign (with)
import Foreign.C.ConstPtr
import GHC.Generics (Generic)
import Linear (V3 (V3), V4 (V4), (!*!))
import Mischief.ECS
import Mischief.ECS.Events
import Mischief.ECS.Systems qualified as S
import Mischief.Math.Transform
import Mischief.Render.Buffer
import Mischief.Render.Core
import Mischief.Render.Layers (RenderLayers)
import Mischief.Render.Texture
import Mischief.Render.Texture (createTexture)
import Mischief.Render.Texture qualified as Texture
import Mischief.SDL.Window
import Mischief.Shader (Bufferable, Field)
import Mischief.Shader.Internal.State (CPU)
import Mischief.Shader.Types qualified as ST
import Mischief.WGPU (wgpuDeviceCreateTexture, wgpuTextureRelease, withWGPUString)
import Mischief.WGPU.Types.Enums
import Mischief.WGPU.Types.General

data Camera = Camera

instance Component Camera where
  required :: Set DefaultComponentType
required = forall b. RequiredBundle b => Set DefaultComponentType
forall {k} (b :: k). RequiredBundle b => Set DefaultComponentType
require @(Transform, RenderLayers)

-- | Add this as a relationship between a camera and a window to have the
-- camera's output texture be rendered to that window.
--
-- Exclusive.
data OutputTo = OutputTo

instance Component OutputTo where
  type IsExclusiveRel OutputTo = True

newtype CameraTexture = CameraTexture SwappableTexture

instance Component CameraTexture where
  onRemove :: [Hook CameraTexture]
onRemove =
    [ (HookContext -> System ()) -> Hook CameraTexture
forall {k} (a :: k). (HookContext -> System ()) -> Hook a
hook ((HookContext -> System ()) -> Hook CameraTexture)
-> (HookContext -> System ()) -> Hook CameraTexture
forall a b. (a -> b) -> a -> b
$ \(HookContext Entity
entity) -> do
        Just (CameraTexture (SwappableTexture {currentTexture, otherTexture})) <- Query System CameraTexture -> System (Maybe CameraTexture)
forall w (m :: * -> *) out.
MonadSystem w m =>
Query m out -> m (Maybe out)
single [q|entity. CameraTexture|]
        liftIO $ wgpuTextureRelease currentTexture
        liftIO $ wgpuTextureRelease otherTexture
    ]

newtype CameraMatrices = CameraMatrices (Buffer Matrices) deriving anyclass (Typeable CameraMatrices
[HookRel CameraMatrices]
[Hook CameraMatrices]
Set DefaultComponentType
IsExclusive (IsExclusiveRel CameraMatrices)
(Typeable CameraMatrices,
 IsExclusive (IsExclusiveRel CameraMatrices)) =>
Set DefaultComponentType
-> [Hook CameraMatrices]
-> [Hook CameraMatrices]
-> [Hook CameraMatrices]
-> [HookRel CameraMatrices]
-> [HookRel CameraMatrices]
-> [HookRel CameraMatrices]
-> Component CameraMatrices
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 CameraMatrices]
onAdd :: [Hook CameraMatrices]
$conSet :: [Hook CameraMatrices]
onSet :: [Hook CameraMatrices]
$conRemove :: [Hook CameraMatrices]
onRemove :: [Hook CameraMatrices]
$conAddRel :: [HookRel CameraMatrices]
onAddRel :: [HookRel CameraMatrices]
$conSetRel :: [HookRel CameraMatrices]
onSetRel :: [HookRel CameraMatrices]
$conRemoveRel :: [HookRel CameraMatrices]
onRemoveRel :: [HookRel CameraMatrices]
Component)

data CameraPlugin

instance Plugin CameraPlugin where
  init :: System ()
init = do
    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 (OnAddRel OutputTo) -> System Entity
forall b. (HasCallStack, Bundle b) => b -> System Entity
spawn (Observer (OnAddRel OutputTo) -> System Entity)
-> Observer (OnAddRel OutputTo) -> System Entity
forall a b. (a -> b) -> a -> b
$ (OnAddRel OutputTo -> System ()) -> Observer (OnAddRel OutputTo)
forall e. (e -> System ()) -> Observer e
Observer OnAddRel OutputTo -> System ()
onAddCameraOutputTo
    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 (OnSet WindowSize) -> System Entity
forall b. (HasCallStack, Bundle b) => b -> System Entity
spawn (Observer (OnSet WindowSize) -> System Entity)
-> Observer (OnSet WindowSize) -> System Entity
forall a b. (a -> b) -> a -> b
$ (OnSet WindowSize -> System ()) -> Observer (OnSet WindowSize)
forall e. (e -> System ()) -> Observer e
Observer OnSet WindowSize -> System ()
onUpdateWindowSize

    System () -> SystemConfig
forall a. ToSystems a => a -> SystemConfig
systems System ()
updateCameraMatrices
      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

updateCameraMatrices :: System ()
updateCameraMatrices :: System ()
updateCameraMatrices = do
  device <- forall c (m :: * -> *) w.
(MonadSystem w m, Component c) =>
m (Maybe c)
res @RenderDevice
  queue <- res @RenderQueue
  for_ ((,) <$> device <*> queue) go
  where
    go :: (RenderDevice, RenderQueue) -> System ()
    go :: (RenderDevice, RenderQueue) -> System ()
go (RenderDevice
device, RenderQueue
queue) = do
      cameras <- Query
  System (Entity, Maybe CameraMatrices, Transform, From WindowSize)
-> System
     [(Entity, Maybe CameraMatrices, Transform, From WindowSize)]
forall w (m :: * -> *) out.
MonadSystem w m =>
Query m out -> m [out]
query [q|Entity, Maybe CameraMatrices, Transform, OutputTo -> (WindowSize) / With Camera|]
      for_ cameras $ \(Entity
entity, Maybe CameraMatrices
buffer, Transform
transform, From Entity
_ (WindowSize Int
w Int
h)) -> do
        buffer <- case Maybe CameraMatrices
buffer of
          Just (CameraMatrices Buffer Matrices
b) -> Buffer Matrices -> System (Buffer Matrices)
forall a. a -> System a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Buffer Matrices
b
          Maybe CameraMatrices
Nothing -> do
            buffer <- forall (a :: * -> *).
Bufferable a =>
RenderDevice -> System (Buffer a)
createBuffer @Matrices RenderDevice
device
            insert (CameraMatrices buffer) entity
            pure buffer

        uploadBuffer queue buffer (getCameraProjection w h transform)

onAddCameraOutputTo :: OnAddRel OutputTo -> System ()
onAddCameraOutputTo :: OnAddRel OutputTo -> System ()
onAddCameraOutputTo (OnAddRel Entity
entity Entity
target) = Entity -> Entity -> System ()
updateCameraTexture Entity
entity Entity
target

onUpdateWindowSize :: OnSet WindowSize -> System ()
onUpdateWindowSize :: OnSet WindowSize -> System ()
onUpdateWindowSize (OnSet Entity
window) = do
  cameras <- Query System Entity -> System [Entity]
forall w (m :: * -> *) out.
MonadSystem w m =>
Query m out -> m [out]
query [q|Entity / With OutputTo -> window|]
  for_ cameras $ \Entity
camera -> Entity -> Entity -> System ()
updateCameraTexture Entity
camera Entity
window

-- | Creates a new CameraTexture component that fits the targeted window.
updateCameraTexture :: Entity -> Entity -> System ()
updateCameraTexture :: Entity -> Entity -> System ()
updateCameraTexture Entity
camera Entity
window = do
  Just device <- forall c (m :: * -> *) w.
(MonadSystem w m, Component c) =>
m (Maybe c)
res @RenderDevice
  window <- single [q|window. WindowSize|]
  case window of
    Maybe WindowSize
Nothing -> Text -> System ()
forall w (m :: * -> *).
(HasCallStack, MonadSystem w m) =>
Text -> m ()
warn Text
"Camera output window not found."
    Just (WindowSize Int
width Int
height) -> do
      texture <- IO SwappableTexture -> System SwappableTexture
forall a. IO a -> System a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SwappableTexture -> System SwappableTexture)
-> IO SwappableTexture -> System SwappableTexture
forall a b. (a -> b) -> a -> b
$ RenderDevice -> TextureDescriptor -> IO SwappableTexture
createSwappableTexture RenderDevice
device (TextureDescriptor
textureDescriptor {Texture.width, height})
      insert (CameraTexture texture) camera

newTextureDescriptor :: Int -> Int -> WGPUStringView -> WGPUTextureDescriptor
newTextureDescriptor :: Int -> Int -> WGPUStringView -> WGPUTextureDescriptor
newTextureDescriptor Int
w Int
h WGPUStringView
label =
  WGPUTextureDescriptor
    { size :: WGPUExtent3D
size = Word32 -> Word32 -> Word32 -> WGPUExtent3D
WGPUExtent3D (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w) (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h) Word32
1,
      WGPUStringView
label :: WGPUStringView
label :: WGPUStringView
label,
      mipLevelCount :: Word32
mipLevelCount = Word32
1,
      sampleCount :: Word32
sampleCount = Word32
1,
      dimension :: WGPUTextureDimension
dimension = WGPUTextureDimension
wGPUTextureDimension_2D,
      format :: WGPUTextureFormat
format = WGPUTextureFormat
wGPUTextureFormat_RGBA8UnormSrgb,
      usage :: WGPUTextureUsage
usage = WGPUTextureUsage
wGPUTextureUsage_TextureBinding WGPUTextureUsage -> WGPUTextureUsage -> WGPUTextureUsage
forall a. Bits a => a -> a -> a
.|. WGPUTextureUsage
wGPUTextureUsage_CopyDst,
      nextInChain :: Ptr WGPUChainedStruct
nextInChain = Ptr WGPUChainedStruct
forall a. Ptr a
nullPtr,
      viewFormatCount :: CSize
viewFormatCount = CSize
0,
      viewFormats :: ConstPtr WGPUTextureFormat
viewFormats = Ptr WGPUTextureFormat -> ConstPtr WGPUTextureFormat
forall a. Ptr a -> ConstPtr a
ConstPtr Ptr WGPUTextureFormat
forall a. Ptr a
nullPtr
    }

data Matrices f = Matrices
  { forall f. Matrices f -> Field f (Mat 4 4)
projection :: Field f (ST.Mat 4 4),
    forall f. Matrices f -> Field f (Mat 4 4)
view :: Field f (ST.Mat 4 4)
  }
  deriving stock ((forall x. Matrices f -> Rep (Matrices f) x)
-> (forall x. Rep (Matrices f) x -> Matrices f)
-> Generic (Matrices f)
forall x. Rep (Matrices f) x -> Matrices f
forall x. Matrices f -> Rep (Matrices f) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall f x. Rep (Matrices f) x -> Matrices f
forall f x. Matrices f -> Rep (Matrices f) x
$cfrom :: forall f x. Matrices f -> Rep (Matrices f) x
from :: forall x. Matrices f -> Rep (Matrices f) x
$cto :: forall f x. Rep (Matrices f) x -> Matrices f
to :: forall x. Rep (Matrices f) x -> Matrices f
Generic)
  deriving anyclass (Int
[(Text, Text)]
Integer -> Matrices GPU
Matrices CPU -> Ptr Word8 -> IO Int
(Integer -> Matrices GPU)
-> [(Text, Text)]
-> Int
-> (Matrices CPU -> Ptr Word8 -> IO Int)
-> Bufferable Matrices
forall (a :: * -> *).
(Integer -> a GPU)
-> [(Text, Text)]
-> Int
-> (a CPU -> Ptr Word8 -> IO Int)
-> Bufferable a
$cdummyBuffer :: Integer -> Matrices GPU
dummyBuffer :: Integer -> Matrices GPU
$cgetFields :: [(Text, Text)]
getFields :: [(Text, Text)]
$cgetSize :: Int
getSize :: Int
$cputBytes :: Matrices CPU -> Ptr Word8 -> IO Int
putBytes :: Matrices CPU -> Ptr Word8 -> IO Int
Bufferable)

getCameraProjection :: Int -> Int -> Transform -> Matrices CPU
getCameraProjection :: Int -> Int -> Transform -> Matrices CPU
getCameraProjection Int
w Int
h Transform {translation :: Transform -> V3 Float
translation = V3 Float
pos} = do
  let l :: Float
l = V3 Float
pos.x Float -> Float -> Float
forall a. Num a => a -> a -> a
- (Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2)
  let r :: Float
r = V3 Float
pos.x Float -> Float -> Float
forall a. Num a => a -> a -> a
+ (Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2)
  let t :: Float
t = V3 Float
pos.y Float -> Float -> Float
forall a. Num a => a -> a -> a
+ (Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2)
  let b :: Float
b = V3 Float
pos.y Float -> Float -> Float
forall a. Num a => a -> a -> a
- (Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2)
  let n :: Float
n = Float
0
  let f :: Float
f = Float
100

  let forward :: V3 Float
forward = Float -> Float -> Float -> V3 Float
forall a. a -> a -> a -> V3 a
V3 Float
0 Float
0 Float
1
  let right :: V3 Float
right = Float -> Float -> Float -> V3 Float
forall a. a -> a -> a -> V3 a
V3 Float
1 Float
0 Float
0
  let up :: V3 Float
up = Float -> Float -> Float -> V3 Float
forall a. a -> a -> a -> V3 a
V3 Float
0 Float
1 Float
0

  let rotation :: V4 (V4 Float)
rotation =
        V4 Float -> V4 Float -> V4 Float -> V4 Float -> V4 (V4 Float)
forall a. a -> a -> a -> a -> V4 a
V4
          (Float -> Float -> Float -> Float -> V4 Float
forall a. a -> a -> a -> a -> V4 a
V4 V3 Float
right.x V3 Float
right.y V3 Float
right.z Float
0)
          (Float -> Float -> Float -> Float -> V4 Float
forall a. a -> a -> a -> a -> V4 a
V4 V3 Float
up.x V3 Float
up.y V3 Float
up.z Float
0)
          (Float -> Float -> Float -> Float -> V4 Float
forall a. a -> a -> a -> a -> V4 a
V4 V3 Float
forward.x V3 Float
forward.y V3 Float
forward.z Float
0)
          (Float -> Float -> Float -> Float -> V4 Float
forall a. a -> a -> a -> a -> V4 a
V4 Float
0 Float
0 Float
0 Float
1)

  let translation' :: V4 (V4 Float)
translation' =
        V4 Float -> V4 Float -> V4 Float -> V4 Float -> V4 (V4 Float)
forall a. a -> a -> a -> a -> V4 a
V4
          (Float -> Float -> Float -> Float -> V4 Float
forall a. a -> a -> a -> a -> V4 a
V4 Float
1 Float
0 Float
0 Float
0)
          (Float -> Float -> Float -> Float -> V4 Float
forall a. a -> a -> a -> a -> V4 a
V4 Float
0 Float
1 Float
0 Float
0)
          (Float -> Float -> Float -> Float -> V4 Float
forall a. a -> a -> a -> a -> V4 a
V4 Float
0 Float
0 Float
1 Float
0)
          (Float -> Float -> Float -> Float -> V4 Float
forall a. a -> a -> a -> a -> V4 a
V4 (-V3 Float
pos.x) (-V3 Float
pos.y) (-V3 Float
pos.z) Float
1)

  let V4 (V4 Float)
translation :: V4 (V4 Float) = V4 (V4 Float)
rotation V4 (V4 Float) -> V4 (V4 Float) -> V4 (V4 Float)
forall (m :: * -> *) (t :: * -> *) (n :: * -> *) a.
(Functor m, Foldable t, Additive t, Additive n, Num a) =>
m (t a) -> t (n a) -> m (n a)
!*! V4 (V4 Float)
translation'
  -- let V4 v1 v2 v3 v4 = translation

  Field CPU (Mat 4 4) -> Field CPU (Mat 4 4) -> Matrices CPU
forall f. Field f (Mat 4 4) -> Field f (Mat 4 4) -> Matrices f
Matrices
    -- projection matrix
    ( V4 Float -> V4 Float -> V4 Float -> V4 Float -> V4 (V4 Float)
forall a. a -> a -> a -> a -> V4 a
V4
        (Float -> Float -> Float -> Float -> V4 Float
forall a. a -> a -> a -> a -> V4 a
V4 (Float
2 Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ (Float
r Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
l)) Float
0 Float
0 (-((Float
r Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
l) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ (Float
r Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
l))))
        (Float -> Float -> Float -> Float -> V4 Float
forall a. a -> a -> a -> a -> V4 a
V4 Float
0 (Float
2 Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ (Float
t Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
b)) Float
0 (-((Float
t Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
b) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ (Float
t Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
b))))
        (Float -> Float -> Float -> Float -> V4 Float
forall a. a -> a -> a -> a -> V4 a
V4 Float
0 Float
0 (-(Float
2 Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ (Float
f Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
n))) (-((Float
f Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
n) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ (Float
f Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
n))))
        (Float -> Float -> Float -> Float -> V4 Float
forall a. a -> a -> a -> a -> V4 a
V4 Float
0 Float
0 Float
0 Float
1)
    )
    -- view matrix
    V4 (V4 Float)
Field CPU (Mat 4 4)
translation

cameraView :: Entity -> Query System TextureView
cameraView :: Entity -> Query System TextureView
cameraView Entity
camera = do
  CameraTexture (SwappableTexture {currentTexture = texture, desc}) <- Entity -> C CameraTexture -> Query System CameraTexture
forall w (m :: * -> *) qd out.
(MonadSystem w m, Queryable qd out) =>
Entity -> qd -> Query m out
qget Entity
camera [qd|CameraTexture|]
  qlift $ createView $ Texture texture desc

cameraSwapView :: Entity -> Query System TextureView
cameraSwapView :: Entity -> Query System TextureView
cameraSwapView Entity
camera = do
  CameraTexture (SwappableTexture {currentTexture = texture, desc, otherTexture}) <- Entity -> C CameraTexture -> Query System CameraTexture
forall w (m :: * -> *) qd out.
(MonadSystem w m, Queryable qd out) =>
Entity -> qd -> Query m out
qget Entity
camera [qd|CameraTexture|]
  qlift $ do
    insert (CameraTexture $ SwappableTexture {currentTexture = otherTexture, otherTexture = texture, desc}) camera
    createView $ Texture texture desc