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)