Samplers.hs

module Render.Samplers
  ( Collection(..)
  , allocate
  , allocateFrom
  , indices

  , Params
  , params

  , createInfo
  ) where

import RIO

import Control.Monad.Trans.Resource (ResourceT)
import Control.Monad.Trans.Resource qualified as Resource
import GHC.Generics (Generic1)
import Vulkan.Core10 qualified as Vk
import Vulkan.NamedType ((:::))
import Vulkan.Zero (zero)

import Engine.Vulkan.Types (HasVulkan(..), MonadVulkan)
import Resource.Collection (Generically1(..))
import Resource.Collection qualified as Collection
import Vulkan.CStruct.Extends (PokeChain, Extendss)

data Collection a = Collection
  { linearMipRepeat  :: a -- 0
  , linearMip        :: a -- 1
  , linearRepeat     :: a -- 2
  , linear           :: a -- 3
  , nearestMipRepeat :: a -- 4
  , nearestMip       :: a -- 5
  , nearestRepeat    :: a -- 6
  , nearest          :: a -- 7
  }
  deriving stock (Show, Functor, Foldable, Traversable, Generic1)
  deriving Applicative via Generically1 Collection

type Params = (Vk.Filter, "LOD clamp" ::: Float, Vk.SamplerAddressMode)

params :: Collection Params
params = Collection
  { linearMipRepeat  = (Vk.FILTER_LINEAR,  Vk.LOD_CLAMP_NONE, Vk.SAMPLER_ADDRESS_MODE_REPEAT)          -- 0
  , linearMip        = (Vk.FILTER_LINEAR,  Vk.LOD_CLAMP_NONE, Vk.SAMPLER_ADDRESS_MODE_CLAMP_TO_BORDER) -- 1
  , linearRepeat     = (Vk.FILTER_LINEAR,  0,                 Vk.SAMPLER_ADDRESS_MODE_REPEAT)          -- 2
  , linear           = (Vk.FILTER_LINEAR,  0,                 Vk.SAMPLER_ADDRESS_MODE_CLAMP_TO_BORDER) -- 3
  , nearestMipRepeat = (Vk.FILTER_NEAREST, Vk.LOD_CLAMP_NONE, Vk.SAMPLER_ADDRESS_MODE_REPEAT)          -- 4
  , nearestMip       = (Vk.FILTER_NEAREST, Vk.LOD_CLAMP_NONE, Vk.SAMPLER_ADDRESS_MODE_CLAMP_TO_BORDER) -- 5
  , nearestRepeat    = (Vk.FILTER_NEAREST, 0,                 Vk.SAMPLER_ADDRESS_MODE_REPEAT)          -- 6
  , nearest          = (Vk.FILTER_NEAREST, 0,                 Vk.SAMPLER_ADDRESS_MODE_CLAMP_TO_BORDER) -- 7
  }

indices :: Collection Int32
indices = fmap fst $ Collection.enumerate params

allocate
  :: MonadVulkan env io
  => "max anisotropy" ::: Float
  -> ResourceT io (Collection Vk.Sampler)
allocate maxAnisotropy =
  for params \p ->
    allocateFrom maxAnisotropy p id

allocateFrom
  :: ( PokeChain e
     , Extendss Vk.SamplerCreateInfo e
     , MonadVulkan env io
     )
  => "max anisotropy" ::: Float
  -> Params
  -> (Vk.SamplerCreateInfo '[] -> Vk.SamplerCreateInfo e)
  -> ResourceT io Vk.Sampler
allocateFrom maxAnisotropy (filt, mips, reps) f = do
  device <- asks getDevice
  sampler <- Vk.createSampler
    device
    (f $ createInfo maxAnisotropy filt mips reps)
    Nothing
  _key <- Resource.register $
    Vk.destroySampler device sampler Nothing
  pure sampler

createInfo
  :: "max anisotropy" ::: Float
  -> Vk.Filter
  -> "max LoD" ::: Float
  -> Vk.SamplerAddressMode
  -> Vk.SamplerCreateInfo '[]
createInfo maxAnisotropy filt mips reps = zero
  { Vk.magFilter               = filt
  , Vk.minFilter               = filt
  , Vk.addressModeU            = reps
  , Vk.addressModeV            = reps
  , Vk.addressModeW            = reps
  , Vk.anisotropyEnable        = maxAnisotropy > 1
  , Vk.maxAnisotropy           = maxAnisotropy
  , Vk.borderColor             = Vk.BORDER_COLOR_INT_OPAQUE_BLACK
  , Vk.unnormalizedCoordinates = False
  , Vk.compareEnable           = False
  , Vk.compareOp               = Vk.COMPARE_OP_ALWAYS
  , Vk.mipmapMode              = Vk.SAMPLER_MIPMAP_MODE_LINEAR
  , Vk.mipLodBias              = 0
  , Vk.minLod                  = 0
  , Vk.maxLod                  = mips
  }