1 files changed, 47 insertions, 17 deletions

diff --git a/MeshSketch.hs b/MeshSketch.hs
index 7ab0d7a..f31c7cf 100644
--- a/MeshSketch.hs
+++ b/MeshSketch.hs
@@ -66,11 +66,12 @@ import Matrix
 import qualified GPURing as GPU
 import qualified VectorRing as Vector
 import RingBuffer
-import MaskableStream (AttributeKey,(@<-))
+import MaskableStream (AttributeKey,(@<-),updateCommands)
 import SmallRing
 import Camera
 import FitCurves
 import Bezier
+import Mask
 
 prettyDebug :: GL.DebugMessage -> String
 prettyDebug (GL.DebugMessage src typ (GL.DebugMessageID mid) severity msg) = unwords ws
@@ -113,6 +114,8 @@ data State = State
     , stDragPlane    :: IORef (Maybe (Vector Float,Plane))
     , stRecentPts    :: IORef (Giver (Vector Double))
     , stAngle        :: IORef Int
+    , stObjects      :: IORef [MaskableObject]
+    , stMasks        :: IORef [Mask]
     }
 
 initCamera :: Camera
@@ -138,9 +141,14 @@ realToFracVector v = Math.fromList $ map realToFrac $ Math.toList v
 
 data MaskableObject = MaskableObject
     { maskableObject :: LC.Object
-    , groupMasks :: Map Text [(Int32,Int32)]
+    , groupMasks :: Map Text Mask
     }
 
+objSpan :: LC.Object -> Mask
+objSpan obj = case Map.elems (objAttributes obj) of
+        Stream { streamLength = x }:_ -> Mask [(0,fromIntegral x)]
+        _                             -> Mask [(0,1)]
+
 addOBJToObjectArray :: GLStorage -> String -> [(GPUMesh, Maybe Text)] -> Map Text (ObjMaterial,TextureData)
                                  -> IO [MaskableObject]
 addOBJToObjectArray storage slotName objMesh mtlLib = forM objMesh $ \(mesh,mat) -> do
@@ -151,10 +159,7 @@ 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)
-  let len = case Map.elems (objAttributes obj) of
-        Stream { streamLength = x }:_ -> x
-        _                             -> 1
-  return $ MaskableObject obj $ maybe Map.empty (`Map.singleton` [(0,1)]) mat
+  return $ MaskableObject obj $ maybe Map.empty (`Map.singleton` objSpan obj) mat
 
 mkFullscreenToggle :: IsWindow a => a -> IO (IO ())
 mkFullscreenToggle w = do
@@ -182,6 +187,8 @@ uploadState obj mm storage = do
     let gs = Map.keys $ foldr (\a ms -> Map.union (groupMasks a) ms) Map.empty bufs
     forM_ gs $ \groupname -> do
         addToGroupsPane (mmListStore mm) True groupname
+    objsRef <- newIORef bufs
+    masksRef <- newIORef $ map (objSpan . maskableObject) bufs
 
     -- grid plane
     uploadMeshToGPU xzplane >>= addMeshToObjectArray storage "plane" []
@@ -239,6 +246,8 @@ uploadState obj mm storage = do
             , stDragPlane    = dragPlane
             , stRecentPts    = recentPts
             , stAngle        = angle
+            , stObjects      = objsRef
+            , stMasks        = masksRef
             }
     -- _ <- addAnimation tm (whirlingCamera st)
 
@@ -336,17 +345,15 @@ new = do
     either (\e _ -> hPutStrLn stderr e >> throwIO (userError e)) (&) m $ \(obj,pipeline) -> do
         mapM_ (putStrLn . ppShow) (targets $ dynamicPipeline pipeline)
         ref <- newIORef Nothing
-        (groups,liststore) <- newGroupsListWidget
+        g <- gLAreaNew
+        (groups,liststore) <- newGroupsListWidget (\store itr b -> onMaskedGroup g ref store itr b)
         panes <- panedNew OrientationHorizontal
-        g <- do
-            g <- gLAreaNew
-            let mm = MeshSketch g panes groups liststore ref
-            gLAreaSetHasDepthBuffer g True
-            st <- return g
-            _ <- on g #realize       $ withCurrentGL g (onRealize obj (dynamicPipeline pipeline) (dynamicSchema pipeline) mm)
-            _ <- on g #unrealize     $ onUnrealize mm
-            _ <- on g #createContext $ nullableContext (onCreateContext g)
-            return g
+        let mm = MeshSketch g panes groups liststore ref
+        gLAreaSetHasDepthBuffer g True
+        st <- return g
+        _ <- on g #realize       $ withCurrentGL g (onRealize obj (dynamicPipeline pipeline) (dynamicSchema pipeline) mm)
+        _ <- on g #unrealize     $ onUnrealize mm
+        _ <- on g #createContext $ nullableContext (onCreateContext g)
         panedPack1 panes g True True
         return panes
 
@@ -357,7 +364,7 @@ addToGroupsPane liststore isEnabled groupName = do
     iter <- listStoreAppend liststore
     listStoreSet liststore iter [0,1] [gtrue,gvalue]
 
-newGroupsListWidget = do
+newGroupsListWidget changedListStore = do
     liststore <- listStoreNew [gtypeBoolean,gtypeString]
     treeView <- treeViewNewWithModel liststore
     treeViewSetHeadersVisible treeView False
@@ -379,6 +386,7 @@ newGroupsListWidget = do
                 b <- fromGValue gval
                 notb <- toGValue (not b)
                 listStoreSetValue liststore itr 0 notb
+                changedListStore liststore itr (not b)
         return togc
     groupc <- do
         groupr <- cellRendererTextNew
@@ -876,3 +884,25 @@ onCreateContext w = do
     putStrLn "onCreateContext!"
     mwin <- widgetGetWindow w
     forM mwin $ \win -> windowCreateGlContext win
+
+onMaskedGroup g ref store itr b = do
+    gval <- treeModelGetValue store itr 1
+    mtxt <- fromGValue gval
+    let _ = mtxt :: Maybe Text
+    putStrLn $ "Mask changed " ++ show (mtxt,b)
+    mr <- readIORef ref
+    forM_ ((,) <$> mr <*> mtxt) $ \(r,txt) -> do
+        let st = stState r
+        os <- readIORef (stObjects st) -- stObjects :: IORef [MaskableObject]
+        ms <- readIORef (stMasks st) -- stMasks :: IORef [Mask]
+        ms' <- forM (zip os ms) $ \(o,m) -> do
+            let mmask = Map.lookup txt (groupMasks o)
+                op = maybe id (flip $ bool maskSubtract maskPlus b) mmask
+                m' = op m
+                unmask (Mask is) = is
+            updateCommands (stStorage r) (maskableObject o) (const $ unmask m')
+            return m'
+        writeIORef (stMasks st) ms'
+        mwin <- widgetGetWindow g
+        forM_ mwin $ \win -> windowInvalidateRect win Nothing False
+    return ()