Add material groups to masking pane.

1 files changed, 21 insertions, 8 deletions

diff --git a/MeshSketch.hs b/MeshSketch.hs
index a153f5e..7ab0d7a 100644
--- a/MeshSketch.hs
+++ b/MeshSketch.hs
@@ -136,7 +136,13 @@ realToFracVector :: ( Real a
                     ) => Vector a -> Vector b
 realToFracVector v = Math.fromList $ map realToFrac $ Math.toList v
 
-addOBJToObjectArray :: GLStorage -> String -> [(GPUMesh, Maybe Text)] -> Map Text (ObjMaterial,TextureData) -> IO [LC.Object]
+data MaskableObject = MaskableObject
+    { maskableObject :: LC.Object
+    , groupMasks :: Map Text [(Int32,Int32)]
+    }
+
+addOBJToObjectArray :: GLStorage -> String -> [(GPUMesh, Maybe Text)] -> Map Text (ObjMaterial,TextureData)
+                                 -> IO [MaskableObject]
 addOBJToObjectArray storage slotName objMesh mtlLib = forM objMesh $ \(mesh,mat) -> do
   obj <- LC.addMeshToObjectArray storage slotName ["diffuseTexture","diffuseColor"] mesh
          -- diffuseTexture and diffuseColor values can change on each model
@@ -145,7 +151,10 @@ addOBJToObjectArray storage slotName objMesh mtlLib = forM objMesh $ \(mesh,mat)
     Just (ObjMaterial{..},t) -> LC.updateObjectUniforms obj $ do
       "diffuseTexture" @= return t -- set model's diffuse texture
       "diffuseColor" @= let (r,g,b) = mtl_Kd in return (V4 r g b mtl_Tr)
-  return obj
+  let len = case Map.elems (objAttributes obj) of
+        Stream { streamLength = x }:_ -> x
+        _                             -> 1
+  return $ MaskableObject obj $ maybe Map.empty (`Map.singleton` [(0,1)]) mat
 
 mkFullscreenToggle :: IsWindow a => a -> IO (IO ())
 mkFullscreenToggle w = do
@@ -160,15 +169,20 @@ xzPlaneVector :: Vector Float
 xzPlaneVector = fromList [ 0,1,0 -- unit normal
                          , 0 ]   -- distance from origin
 
-uploadState :: IsWidget glarea => MeshData -> glarea -> GLStorage -> IO State
-uploadState obj glarea storage = do
+uploadState :: MeshData -> MeshSketch -> GLStorage -> IO State
+uploadState obj mm storage = do
+    let glarea = mmWidget mm
     -- load OBJ geometry and material descriptions
     let workarea = BoundingBox (-1.5) (1.5) (-1.5) 1.5 (-1.5) (1.5)
     ((objMesh,mtlLib),objscale) <- uploadOBJToGPU (Just workarea) obj
     -- load materials textures
     gpuMtlLib <- uploadMtlLib mtlLib
     -- add OBJ to pipeline input
-    addOBJToObjectArray storage "objects" objMesh gpuMtlLib
+    bufs <- addOBJToObjectArray storage "objects" objMesh gpuMtlLib
+    let gs = Map.keys $ foldr (\a ms -> Map.union (groupMasks a) ms) Map.empty bufs
+    forM_ gs $ \groupname -> do
+        addToGroupsPane (mmListStore mm) True groupname
+
     -- grid plane
     uploadMeshToGPU xzplane >>= addMeshToObjectArray storage "plane" []
 
@@ -385,7 +399,7 @@ newGroupsListWidget = do
         return groupc
     one <- treeViewAppendColumn treeView togc
     two <- treeViewAppendColumn treeView groupc
-    addToGroupsPane liststore False "sample text"
+    -- addToGroupsPane liststore False "sample text"
     return (treeView,liststore)
 
 
@@ -413,7 +427,7 @@ onRealize mesh pipeline schema mm = do
     renderer <- LC.allocRenderer pipeline
     compat <- LC.setStorage renderer storage -- check schema compatibility
     -- putStrLn $ "setStorage compat = " ++ show compat
-    x <- uploadState mesh (mmWidget mm) storage
+    x <- uploadState mesh mm storage
     let r = Realized
             { stStorage  = storage
             , stRenderer = renderer
@@ -748,7 +762,6 @@ onEvent mm realized ev = do
 
         EventTypeButtonPress -> do
             widgetGrabFocus w
-            addToGroupsPane (mmListStore mm) True "clicked"
             bev <- get ev #button
             h <- get bev #x
             k <- get bev #y