Model.hs

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

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

module Render.Unlit.Textured.Model
  ( Model
  , Vertex
  , VertexAttrs

  , AttrsF(..)
  , Attrs
  , attrs

  , Stores
  , attrStores
  , stores1
  , Buffers

  , TextureParams(..)

  , ObserverCoherent
  ) where

import RIO

import Geomancy (Transform, Vec2, Vec4)
import Geomancy.Vec3 qualified as Vec3
import Graphics.Gl.Block (Block)
import Graphics.Gl.Block qualified as Block
import RIO.Vector.Storable qualified as Storable
import Vulkan.Core10 qualified as Vk
import Vulkan.NamedType ((:::))
import Vulkan.Zero (Zero(..))

import Engine.Types (HKD)
import Engine.Vulkan.Format (HasVkFormat(..))
import Engine.Vulkan.Pipeline.Graphics (HasVertexInputBindings(..), instanceFormat)
import Engine.Worker qualified as Worker
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 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
  }

attrStores :: Foldable t => t Attrs -> Stores
attrStores source = Attrs
  { params = Storable.fromList $ map (.params) $ toList source
  , transforms = Storable.fromList $ map (.transforms) $ toList source
  }

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

data TextureParams = TextureParams
  { tpScale     :: Vec2
  , tpOffset    :: Vec2
  , tpGamma     :: Vec4
  , tpSamplerId :: Int32
  , tpTextureId :: Int32
  }
  deriving (Generic, Show, Block)
  deriving Storable via (Block.Packed TextureParams)

instance Zero TextureParams where
  zero = TextureParams
    { tpScale     = 1.0
    , tpOffset    = 0.0
    , tpGamma     = 1.0
    , tpSamplerId = minBound
    , tpTextureId = minBound
    }

instance HasVkFormat TextureParams where
  getVkFormat =
    [ Vk.FORMAT_R32G32B32A32_SFLOAT -- iTextureScaleOffset :: vec4
    , Vk.FORMAT_R32G32B32A32_SFLOAT -- iTextureGamma       :: vec4
    , Vk.FORMAT_R32G32_SINT         -- iTextureIds         :: ivec2
    ]