Camera.hs

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 = 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 $ \(HookContext entity) -> do
        Just (CameraTexture (SwappableTexture {currentTexture, otherTexture})) <- single [q|entity. CameraTexture|]
        liftIO $ wgpuTextureRelease currentTexture
        liftIO $ wgpuTextureRelease otherTexture
    ]

newtype CameraMatrices = CameraMatrices (Buffer Matrices) deriving anyclass (Component)

data CameraPlugin

instance Plugin CameraPlugin where
  init = do
    void $ spawn $ Observer onAddCameraOutputTo
    void $ spawn $ Observer onUpdateWindowSize

    systems updateCameraMatrices
      & schedule @Update

updateCameraMatrices :: System ()
updateCameraMatrices = do
  device <- res @RenderDevice
  queue <- res @RenderQueue
  for_ ((,) <$> device <*> queue) go
  where
    go :: (RenderDevice, RenderQueue) -> System ()
    go (device, queue) = do
      cameras <- query [q|Entity, Maybe CameraMatrices, Transform, OutputTo -> (WindowSize) / With Camera|]
      for_ cameras $ \(entity, buffer, transform, From _ (WindowSize w h)) -> do
        buffer <- case buffer of
          Just (CameraMatrices b) -> pure b
          Nothing -> do
            buffer <- createBuffer @Matrices device
            insert (CameraMatrices buffer) entity
            pure buffer

        uploadBuffer queue buffer (getCameraProjection w h transform)

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

onUpdateWindowSize :: OnSet WindowSize -> System ()
onUpdateWindowSize (OnSet window) = do
  cameras <- query [q|Entity / With OutputTo -> window|]
  for_ cameras $ \camera -> updateCameraTexture camera window

-- | Creates a new CameraTexture component that fits the targeted window.
updateCameraTexture :: Entity -> Entity -> System ()
updateCameraTexture camera window = do
  Just device <- res @RenderDevice
  window <- single [q|window. WindowSize|]
  case window of
    Nothing -> warn "Camera output window not found."
    Just (WindowSize width height) -> do
      texture <- liftIO $ createSwappableTexture device (textureDescriptor {Texture.width, height})
      insert (CameraTexture texture) camera

newTextureDescriptor :: Int -> Int -> WGPUStringView -> WGPUTextureDescriptor
newTextureDescriptor w h label =
  WGPUTextureDescriptor
    { size = WGPUExtent3D (fromIntegral w) (fromIntegral h) 1,
      label,
      mipLevelCount = 1,
      sampleCount = 1,
      dimension = wGPUTextureDimension_2D,
      format = wGPUTextureFormat_RGBA8UnormSrgb,
      usage = wGPUTextureUsage_TextureBinding .|. wGPUTextureUsage_CopyDst,
      nextInChain = nullPtr,
      viewFormatCount = 0,
      viewFormats = ConstPtr nullPtr
    }

data Matrices f = Matrices
  { projection :: Field f (ST.Mat 4 4),
    view :: Field f (ST.Mat 4 4)
  }
  deriving stock (Generic)
  deriving anyclass (Bufferable)

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

  let forward = V3 0 0 1
  let right = V3 1 0 0
  let up = V3 0 1 0

  let rotation =
        V4
          (V4 right.x right.y right.z 0)
          (V4 up.x up.y up.z 0)
          (V4 forward.x forward.y forward.z 0)
          (V4 0 0 0 1)

  let translation' =
        V4
          (V4 1 0 0 0)
          (V4 0 1 0 0)
          (V4 0 0 1 0)
          (V4 (-pos.x) (-pos.y) (-pos.z) 1)

  let translation :: V4 (V4 Float) = rotation !*! translation'
  -- let V4 v1 v2 v3 v4 = translation

  Matrices
    -- projection matrix
    ( V4
        (V4 (2 / (r - l)) 0 0 (-((r + l) / (r - l))))
        (V4 0 (2 / (t - b)) 0 (-((t + b) / (t - b))))
        (V4 0 0 (-(2 / (f - n))) (-((f + n) / (f - n))))
        (V4 0 0 0 1)
    )
    -- view matrix
    translation

cameraView :: Entity -> Query System TextureView
cameraView camera = do
  CameraTexture (SwappableTexture {currentTexture = texture, desc}) <- qget camera [qd|CameraTexture|]
  qlift $ createView $ Texture texture desc

cameraSwapView :: Entity -> Query System TextureView
cameraSwapView camera = do
  CameraTexture (SwappableTexture {currentTexture = texture, desc, otherTexture}) <- qget camera [qd|CameraTexture|]
  qlift $ do
    insert (CameraTexture $ SwappableTexture {currentTexture = otherTexture, otherTexture = texture, desc}) camera
    createView $ Texture texture desc