Collect.hs

module Render.Lit.Material.Collect
  ( LoadedModel
  , SceneModel(..)
  , sceneMaterials
  , modelMaterials
  , nodeMaterials
  ) where

import RIO

import RIO.Map qualified as Map
import RIO.Vector.Storable qualified as Storable

import Render.Lit.Material (shiftTextures)
import Render.Lit.Material.Model qualified as LitMaterial
import Resource.Buffer qualified as Buffer
import Resource.Mesh.Types qualified as Mesh
import Resource.Mesh.Lit qualified as Lit
import Render.Lit.Material (Material)

type LoadedModel =
  ( Mesh.Meta
  , Storable.Vector Lit.MaterialNode
  , LitMaterial.Model 'Buffer.Staged
  )

data SceneModel models textures = SceneModel
  { smLabel            :: Text
  , smGetModel         :: models -> LoadedModel
  , smGetTextureOffset :: textures -> Int32
  }

sceneMaterials
  :: Foldable t
  => models
  -> textures
  -> t (SceneModel models textures)
  -> Storable.Vector Material
sceneMaterials loadedModels combinedTextures =
  Storable.fromList . Map.elems . foldl' beep mempty
  where
    beep acc SceneModel{..} =
      let
        (_meta, materialNodes, _model) = smGetModel loadedModels
        textureOffset = smGetTextureOffset combinedTextures
      in
        modelMaterials smLabel textureOffset acc (Storable.toList materialNodes)

modelMaterials
  :: Foldable t
  => Text
  -> Int32
  -> Map Int Material
  -> t Lit.MaterialNode
  -> Map Int Material
modelMaterials label textureOffset =
  foldr (nodeMaterials label textureOffset)

nodeMaterials
  :: Text
  -> Int32
  -> Lit.MaterialNode
  -> Map Int Material
  -> Map Int Material
nodeMaterials label textureStart Lit.MaterialNode{mnMaterialIx, mnMaterial} collection =
  case Map.lookup mnMaterialIx collection of
    Nothing ->
      Map.insert mnMaterialIx newMaterial collection
    Just oldMaterial ->
      if newMaterial /= oldMaterial then
        error $ unlines
          [ "Ouf... The material indices are clashing for " <> show label
          , "At: " <> show mnMaterialIx
          , "Old: " <> show oldMaterial
          , "Now: " <> show mnMaterial
          ]
      else
        collection
  where
    newMaterial =
      shiftTextures textureStart mnMaterial