{-# OPTIONS_GHC -fplugin Foreign.Storable.Generic.Plugin #-}

{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE OverloadedRecordDot #-}

{- XXX: Copy-pasta from Unlit.Textured.Model.

Attept with newtypes ended up too disruptive.
Perhaps a better solution would be adding unique tag parameter to Pipeline type.
-}

module Render.Debug.Model
  ( Model
  , Vertex
  , VertexAttrs

  , AttrsF(..)
  , Attrs
  , attrs

  , Stores
  , stores1
  , Buffers

  , TextureParams(..)

  , ObserverCoherent
  ) where

import RIO

import Foreign.Storable.Generic (GStorable)
import Geomancy (Transform, Vec2)
import Geomancy.Vec3 qualified as Vec3
import RIO.Vector.Storable qualified as Storable
import Vulkan.NamedType ((:::))
import Vulkan.Zero (Zero(..))

import Engine.Types (HKD)
import Engine.Vulkan.Pipeline.Graphics (HasVertexInputBindings(..), instanceFormat)
import Engine.Worker qualified as Worker
import Render.Unlit.Textured.Model (TextureParams(..))
import Resource.Buffer qualified as Buffer
import Resource.Model qualified as Model
import Resource.Model.Observer qualified as Observer

type Model buf = Model.Indexed buf Vec3.Packed VertexAttrs
type Vertex = Model.Vertex3d VertexAttrs

type VertexAttrs = "uv" ::: Vec2

data AttrsF f = Attrs
  { forall (f :: * -> *). AttrsF f -> HKD f TextureParams
params     :: HKD f TextureParams
  , forall (f :: * -> *). AttrsF f -> HKD f Transform
transforms :: HKD f Transform
  }
  deriving ((forall x. AttrsF f -> Rep (AttrsF f) x)
-> (forall x. Rep (AttrsF f) x -> AttrsF f) -> Generic (AttrsF f)
forall x. Rep (AttrsF f) x -> AttrsF f
forall x. AttrsF f -> Rep (AttrsF f) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (f :: * -> *) x. Rep (AttrsF f) x -> AttrsF f
forall (f :: * -> *) x. AttrsF f -> Rep (AttrsF f) x
$cfrom :: forall (f :: * -> *) x. AttrsF f -> Rep (AttrsF f) x
from :: forall x. AttrsF f -> Rep (AttrsF f) x
$cto :: forall (f :: * -> *) x. Rep (AttrsF f) x -> AttrsF f
to :: forall x. Rep (AttrsF f) x -> AttrsF f
Generic)

type Attrs = AttrsF Identity
deriving instance Show Attrs
instance GStorable Attrs

instance HasVertexInputBindings Attrs where
  vertexInputBindings :: [VertexInputBinding]
vertexInputBindings =
    [ forall a. HasVkFormat a => VertexInputBinding
instanceFormat @TextureParams
    , forall a. HasVkFormat a => VertexInputBinding
instanceFormat @Transform
    ]

type Stores = AttrsF Storable.Vector
deriving instance Show Stores

type Buffers = AttrsF (Buffer.Allocated 'Buffer.Coherent)
deriving instance Show Buffers
instance Observer.VertexBuffers Buffers
type ObserverCoherent = Worker.ObserverIO Buffers

instance Observer.UpdateCoherent Buffers Stores

instance Model.HasVertexBuffers Buffers where
  type VertexBuffersOf Buffers = Attrs

instance Zero Attrs where
  zero :: Attrs
zero = Attrs
    { $sel:params:Attrs :: HKD Identity TextureParams
params = HKD Identity TextureParams
TextureParams
forall a. Zero a => a
zero
    , $sel:transforms:Attrs :: HKD Identity Transform
transforms = Transform
HKD Identity Transform
forall a. Monoid a => a
mempty
    }

attrs :: Int32 -> Int32 -> [Transform] -> Attrs
attrs :: Int32 -> Int32 -> [Transform] -> Attrs
attrs Int32
samplerId Int32
textureId [Transform]
transforms = Attrs
  { $sel:params:Attrs :: HKD Identity TextureParams
params = TextureParams
forall a. Zero a => a
zero
      { $sel:tpSamplerId:TextureParams :: Int32
tpSamplerId = Int32
samplerId
      , $sel:tpTextureId:TextureParams :: Int32
tpTextureId = Int32
textureId
      }
  , $sel:transforms:Attrs :: HKD Identity Transform
transforms = [Transform] -> Transform
forall a. Monoid a => [a] -> a
mconcat [Transform]
transforms
  }

stores1 :: Int32 -> Int32 -> [Transform] -> Stores
stores1 :: Int32 -> Int32 -> [Transform] -> Stores
stores1 Int32
samplerId Int32
textureId [Transform]
transforms =
  Attrs
    { $sel:params:Attrs :: HKD Vector TextureParams
params = TextureParams -> Vector TextureParams
forall a. Storable a => a -> Vector a
Storable.singleton Attrs
attrs1.params
    , $sel:transforms:Attrs :: HKD Vector Transform
transforms = Transform -> Vector Transform
forall a. Storable a => a -> Vector a
Storable.singleton Attrs
attrs1.transforms
    }
  where
    attrs1 :: Attrs
attrs1 = Int32 -> Int32 -> [Transform] -> Attrs
attrs
      Int32
samplerId
      Int32
textureId
      [Transform]
transforms