Samplers.hs

{-# LANGUAGE DeriveAnyClass #-}

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

  , Params
  , create
  , destroy
  ) where

import RIO

import Control.Monad.Trans.Resource qualified as Resource
import Data.Distributive (Distributive(..))
import Data.Distributive.Generic (genericCollect)
import Data.Functor.Rep (Co(..), Representable)
import GHC.Generics (Generic1)
import Vulkan.Core10 qualified as Vk
import Vulkan.NamedType ((:::))
import Vulkan.Zero (zero)

import Engine.Vulkan.Types (HasSwapchain(..), HasVulkan(..), MonadVulkan)
import Resource.Collection qualified as Collection

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, Generic, Generic1)
  deriving Applicative via (Co Collection)
  deriving anyclass (Representable)

instance Distributive Collection where
  collect = genericCollect

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 m
     , Resource.MonadResource m
     , HasSwapchain a
     )
  => a
  -> m (Resource.ReleaseKey, Collection Vk.Sampler)
allocate swapchain = do
  context <- ask
  Resource.allocate
    (for params $ create context $ getAnisotropy swapchain)
    (traverse_ $ destroy context)

create
  :: (MonadIO io, HasVulkan context)
  => context
  -> "max anisotropy" ::: Float
  -> Params
  -> io Vk.Sampler
create context maxAnisotropy (filt, mips, reps) =
  Vk.createSampler (getDevice context) samplerCI Nothing
  where
    samplerCI = 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
      }

destroy :: (MonadIO io, HasVulkan context) => context -> Vk.Sampler -> io ()
destroy context sampler =
  Vk.destroySampler (getDevice context) sampler Nothing