From 40b339a401a82610d16601e9a1ce34af9b159d56 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Mon, 17 Jun 2019 17:33:18 -0400 Subject: Maskable materials. --- Mask.hs | 63 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ MeshSketch.hs | 64 +++++++++++++++++++++++++++++++++++++++++--------------- lambda-gtk.cabal | 2 +- 3 files changed, 111 insertions(+), 18 deletions(-) create mode 100644 Mask.hs 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 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, -- cgit v1.2.3