Maskable materials.

3 files changed, 111 insertions, 18 deletions

diff --git a/Mask.hs b/Mask.hs
new file mode 100644
index 0000000..0b91e42
--- /dev/null
+++ b/Mask.hs
@@ -0,0 +1,63 @@
+module Mask where
+
+import Data.Int
+
+newtype Mask = Mask [(Int32,Int32)]
+ deriving (Eq,Ord,Show)
+
+{-
+merge ((x0,x):xs) ((y0,y):ys) =
+    if x0 <= y0
+        then case compare x y0 of
+            LT -> (x0 x) (y0 y)
+            EQ -> (x0 x=y0 y)
+            GT -> if x <= y then -> (x0 y0 x y)
+                            else -> (x0 y0 y x)
+        else case compare x0 y of
+            LT -> if x <= y then (y0 x0 x y)
+                            else (y0 x0 y x)
+            EQ -> (y0 y=x0 x)
+            GT -> (y0 y) (x0 x)
+-}
+
+subtr [] ys = []
+subtr xs [] = xs
+subtr ((x0,x):xs) ((y0,y):ys) =
+    if x0 <= y0
+        then case compare x y0 of
+            LT -> subtr ((x0,x):xs) ys
+            EQ -> (x0,x) : subtr xs ((y0,y):ys)
+            GT -> if x <= y then (if x0<y0 then ((x0,y0) :) else id) $ subtr xs ((y0,y):ys)
+                            else (if x0<y0 then ((x0,y0) :) else id) $ subtr ((y,x):xs) ys
+        else case compare x0 y of
+            LT -> if x <= y then subtr xs ((y0,y):ys)
+                            else subtr ((y,x):xs) ys
+            EQ -> subtr ((x0,x):xs) ys
+            GT -> subtr ((x0,x):xs) ys
+
+union [] ys = ys
+union xs [] = xs
+union ((x0,x):xs) ((y0,y):ys) =
+    if x0 <= y0
+        then case compare x y0 of
+            LT -> (x0,x) : union xs ((y0,y):ys)
+            EQ -> (x0,y) : union xs ys
+            GT -> if x <= y then union xs ((x0,y):ys)
+                            else union ((x0,x):xs) ys
+        else case compare x0 y of
+            LT -> if x <= y then union xs ((y0,y):ys)
+                            else union ((y0,x):xs) ys
+            EQ -> (y0,x) : union xs ys
+            GT -> (y0,y) : union ((x0,x):xs) ys
+
+endpts :: (Int32,Int32) -> (Int32,Int32)
+endpts (x0,sz) = (x0,x0 + sz)
+
+sized :: (Int32,Int32) -> (Int32,Int32)
+sized (x0,x) = (x0, x - x0)
+
+maskPlus :: Mask -> Mask -> Mask
+maskPlus (Mask xs) (Mask ys) = Mask $ sized <$> union (endpts <$> xs) (endpts <$> ys)
+
+maskSubtract :: Mask -> Mask -> Mask
+maskSubtract (Mask xs) (Mask ys) = Mask $ sized <$> subtr (endpts <$> xs) (endpts <$> ys)
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 ()
diff --git a/lambda-gtk.cabal b/lambda-gtk.cabal
index 75bcdfc..08e9ff2 100644
--- a/lambda-gtk.cabal
+++ b/lambda-gtk.cabal
@@ -50,7 +50,7 @@ executable meshsketch
   other-modules:       InfinitePlane LambdaCubeWidget GLWidget LambdaCube.Gtk TimeKeeper
                        LoadMesh MtlParser Matrix LambdaCube.GL.HMatrix
                        Animator MeshSketch CubeMap AttributeData GPURing MaskableStream
-                       RingBuffer SmallRing VectorRing Camera Bezier FitCurves
+                       RingBuffer SmallRing VectorRing Camera Bezier FitCurves Mask
   extensions:          NondecreasingIndentation
   other-extensions:    OverloadedLabels, OverloadedLists, OverloadedStrings
   build-depends:       base, containers >=0.5 && <0.6, bytestring >=0.10 && <0.11,