Model.hs

{-# 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
  { params     :: HKD f TextureParams
  , transforms :: HKD f Transform
  }
  deriving (Generic)

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

instance HasVertexInputBindings Attrs where
  vertexInputBindings =
    [ instanceFormat @TextureParams
    , 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
    { params = zero
    , transforms = mempty
    }

attrs :: Int32 -> Int32 -> [Transform] -> Attrs
attrs samplerId textureId transforms = Attrs
  { params = zero
      { tpSamplerId = samplerId
      , tpTextureId = textureId
      }
  , transforms = mconcat transforms
  }

stores1 :: Int32 -> Int32 -> [Transform] -> Stores
stores1 samplerId textureId transforms =
  Attrs
    { params = Storable.singleton attrs1.params
    , transforms = Storable.singleton attrs1.transforms
    }
  where
    attrs1 = attrs
      samplerId
      textureId
      transforms