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

import RIO

import RIO.Map qualified as Map
import RIO.Set qualified as Set
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
  { forall models textures. SceneModel models textures -> Text
smLabel            :: Text
  , forall models textures.
SceneModel models textures -> models -> LoadedModel
smGetModel         :: models -> LoadedModel
  , forall models textures.
SceneModel models textures -> textures -> Int32
smGetTextureOffset :: textures -> Int32
  }

sceneMaterials
  :: Foldable t
  => models
  -> textures
  -> t (SceneModel models textures)
  -> Storable.Vector Material
sceneMaterials :: forall (t :: * -> *) models textures.
Foldable t =>
models
-> textures -> t (SceneModel models textures) -> Vector Material
sceneMaterials models
loadedModels textures
combinedTextures =
  [Material] -> Vector Material
forall a. Storable a => [a] -> Vector a
Storable.fromList ([Material] -> Vector Material)
-> (t (SceneModel models textures) -> [Material])
-> t (SceneModel models textures)
-> Vector Material
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, Material) -> Material) -> [(Text, Material)] -> [Material]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Material) -> Material
forall a b. (a, b) -> b
snd ([(Text, Material)] -> [Material])
-> (t (SceneModel models textures) -> [(Text, Material)])
-> t (SceneModel models textures)
-> [Material]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Int (Text, Material) -> [(Text, Material)]
forall k a. Map k a -> [a]
Map.elems (Map Int (Text, Material) -> [(Text, Material)])
-> (t (SceneModel models textures) -> Map Int (Text, Material))
-> t (SceneModel models textures)
-> [(Text, Material)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map Text (Set Int), Map Int (Text, Material))
-> Map Int (Text, Material)
forall a b. (a, b) -> b
snd ((Map Text (Set Int), Map Int (Text, Material))
 -> Map Int (Text, Material))
-> (t (SceneModel models textures)
    -> (Map Text (Set Int), Map Int (Text, Material)))
-> t (SceneModel models textures)
-> Map Int (Text, Material)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Map Text (Set Int), Map Int (Text, Material))
 -> SceneModel models textures
 -> (Map Text (Set Int), Map Int (Text, Material)))
-> (Map Text (Set Int), Map Int (Text, Material))
-> t (SceneModel models textures)
-> (Map Text (Set Int), Map Int (Text, Material))
forall b a. (b -> a -> b) -> b -> t a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Map Text (Set Int), Map Int (Text, Material))
-> SceneModel models textures
-> (Map Text (Set Int), Map Int (Text, Material))
beep (Map Text (Set Int)
forall a. Monoid a => a
mempty, Map Int (Text, Material)
forall a. Monoid a => a
mempty)
  where
    beep :: (Map Text (Set Int), Map Int (Text, Material))
-> SceneModel models textures
-> (Map Text (Set Int), Map Int (Text, Material))
beep (Map Text (Set Int), Map Int (Text, Material))
acc SceneModel{Text
models -> LoadedModel
textures -> Int32
$sel:smLabel:SceneModel :: forall models textures. SceneModel models textures -> Text
$sel:smGetModel:SceneModel :: forall models textures.
SceneModel models textures -> models -> LoadedModel
$sel:smGetTextureOffset:SceneModel :: forall models textures.
SceneModel models textures -> textures -> Int32
smLabel :: Text
smGetModel :: models -> LoadedModel
smGetTextureOffset :: textures -> Int32
..} =
      let
        (Meta
_meta, Vector MaterialNode
materialNodes, Model 'Staged
_model) = models -> LoadedModel
smGetModel models
loadedModels
        textureOffset :: Int32
textureOffset = textures -> Int32
smGetTextureOffset textures
combinedTextures
      in
        Text
-> Int32
-> (Map Text (Set Int), Map Int (Text, Material))
-> [MaterialNode]
-> (Map Text (Set Int), Map Int (Text, Material))
forall (t :: * -> *).
Foldable t =>
Text
-> Int32
-> (Map Text (Set Int), Map Int (Text, Material))
-> t MaterialNode
-> (Map Text (Set Int), Map Int (Text, Material))
modelMaterials Text
smLabel Int32
textureOffset (Map Text (Set Int), Map Int (Text, Material))
acc (Vector MaterialNode -> [MaterialNode]
forall a. Storable a => Vector a -> [a]
Storable.toList Vector MaterialNode
materialNodes)

modelMaterials
  :: Foldable t
  => Text
  -> Int32
  -> (Map Text (Set Int), Map Int (Text, Material))
  -> t Lit.MaterialNode
  -> (Map Text (Set Int), Map Int (Text, Material))
modelMaterials :: forall (t :: * -> *).
Foldable t =>
Text
-> Int32
-> (Map Text (Set Int), Map Int (Text, Material))
-> t MaterialNode
-> (Map Text (Set Int), Map Int (Text, Material))
modelMaterials Text
label Int32
textureOffset =
  (MaterialNode
 -> (Map Text (Set Int), Map Int (Text, Material))
 -> (Map Text (Set Int), Map Int (Text, Material)))
-> (Map Text (Set Int), Map Int (Text, Material))
-> t MaterialNode
-> (Map Text (Set Int), Map Int (Text, Material))
forall a b. (a -> b -> b) -> b -> t a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Text
-> Int32
-> MaterialNode
-> (Map Text (Set Int), Map Int (Text, Material))
-> (Map Text (Set Int), Map Int (Text, Material))
nodeMaterials Text
label Int32
textureOffset)

nodeMaterials
  :: Text
  -> Int32
  -> Lit.MaterialNode
  -> (Map Text (Set Int), Map Int (Text, Material))
  -> (Map Text (Set Int), Map Int (Text, Material))
nodeMaterials :: Text
-> Int32
-> MaterialNode
-> (Map Text (Set Int), Map Int (Text, Material))
-> (Map Text (Set Int), Map Int (Text, Material))
nodeMaterials Text
label Int32
textureStart Lit.MaterialNode{Int
mnMaterialIx :: Int
$sel:mnMaterialIx:MaterialNode :: MaterialNode -> Int
mnMaterialIx, Material
mnMaterial :: Material
$sel:mnMaterial:MaterialNode :: MaterialNode -> Material
mnMaterial} (Map Text (Set Int)
ids, Map Int (Text, Material)
collection) =
  case Int -> Map Int (Text, Material) -> Maybe (Text, Material)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
mnMaterialIx Map Int (Text, Material)
collection of
    Maybe (Text, Material)
Nothing ->
      ( (Set Int -> Set Int -> Set Int)
-> Text -> Set Int -> Map Text (Set Int) -> Map Text (Set Int)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith Set Int -> Set Int -> Set Int
forall a. Monoid a => a -> a -> a
mappend Text
label (Int -> Set Int
forall a. a -> Set a
Set.singleton Int
mnMaterialIx) Map Text (Set Int)
ids
      , Int
-> (Text, Material)
-> Map Int (Text, Material)
-> Map Int (Text, Material)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Int
mnMaterialIx (Text
label, Material
newMaterial) Map Int (Text, Material)
collection
      )
    Just (Text
oldLabel, Material
oldMaterial) ->
      if Material
newMaterial Material -> Material -> Bool
forall a. Eq a => a -> a -> Bool
/= Material
oldMaterial then
        String -> (Map Text (Set Int), Map Int (Text, Material))
forall a. HasCallStack => String -> a
error (String -> (Map Text (Set Int), Map Int (Text, Material)))
-> String -> (Map Text (Set Int), Map Int (Text, Material))
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
          [ String
"Ouf... The material indices are clashing for " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show Text
label
          , String
"ID: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
mnMaterialIx String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" from " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show Text
oldLabel
          , String
""
          , String
"Old: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Material -> String
forall a. Show a => a -> String
show Material
oldMaterial
          , String
"Now: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Material -> String
forall a. Show a => a -> String
show Material
mnMaterial
          , String
""
          , String
"Bad material offset? Known material IDs:"
          , [String] -> String
unlines do
              (Text
knownLabel, Set Int
knownIds) <- Map Text (Set Int) -> [(Text, Set Int)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Text (Set Int)
ids
              String -> [String]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ Text -> String
forall a. Show a => a -> String
show Text
knownLabel String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [Int] -> String
forall a. Show a => a -> String
show (Set Int -> [Int]
forall a. Set a -> [a]
Set.toList Set Int
knownIds)
          , String
"Try setting " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show Text
label String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" material offset to " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
suggestOffset
          ]
      else
        (Map Text (Set Int)
ids, Map Int (Text, Material)
collection)
  where
    newMaterial :: Material
newMaterial =
      Int32 -> Material -> Material
shiftTextures Int32
textureStart Material
mnMaterial

    suggestOffset :: Int
    suggestOffset :: Int
suggestOffset =
      (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int -> Int) -> ([Int] -> Int) -> [Int] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int) -> Int -> [Int] -> Int
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$
        [Maybe Int] -> [Int]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Int] -> [Int])
-> ([Set Int] -> [Maybe Int]) -> [Set Int] -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set Int -> Maybe Int) -> [Set Int] -> [Maybe Int]
forall a b. (a -> b) -> [a] -> [b]
map Set Int -> Maybe Int
forall a. Set a -> Maybe a
Set.lookupMax ([Set Int] -> [Int]) -> [Set Int] -> [Int]
forall a b. (a -> b) -> a -> b
$
          Map Text (Set Int) -> [Set Int]
forall k a. Map k a -> [a]
Map.elems (Text -> Map Text (Set Int) -> Map Text (Set Int)
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Text
label Map Text (Set Int)
ids)