Added a right pane to select/deselect mesh groups.

1 files changed, 53 insertions, 24 deletions

diff --git a/MeshSketch.hs b/MeshSketch.hs
index 4ddfec0..3253008 100644
--- a/MeshSketch.hs
+++ b/MeshSketch.hs
@@ -34,6 +34,7 @@ import GI.GObject.Functions (signalHandlerDisconnect)
 import GI.Gdk.Objects
 import GI.GLib.Constants
 import GI.Gtk hiding (IsWindow,windowFullscreen,windowUnfullscreen)
+import qualified GI.Gtk.Objects as Gtk
 import LambdaCube.GL             as LC
 import LambdaCube.GL.Mesh        as LC
 import Numeric.LinearAlgebra as Math hiding ((<>))
@@ -268,8 +269,11 @@ setUniforms gl storage st = do
     -- updateRingUniforms storage (stRingBuffer st)
 
 data MeshSketch = MeshSketch
-    { mmWidget   :: GLArea
-    , mmRealized :: IORef (Maybe Realized)
+    { mmWidget      :: GLArea
+    , mmPaned       :: Gtk.Paned
+    , mmGroupsPanel :: Gtk.TreeView
+    , mmListStore   :: Gtk.ListStore
+    , mmRealized    :: IORef (Maybe Realized)
     }
 
 type SignalHandlerId = Foreign.C.Types.CULong
@@ -281,7 +285,7 @@ data Realized = Realized
     , stSigs     :: [SignalHandlerId] -- Signals attached by onRealize.
     }
 
-new :: IO GLArea
+new :: IO Gtk.Paned
 new = do
     putStrLn "new!"
     m <- do
@@ -315,36 +319,52 @@ new = do
             "diffuseColor"    @: V4F
         return $ (,) <$> mobj <*> mpipeline
     either (\e _ -> hPutStrLn stderr e >> throwIO (userError e)) (&) m $ \(obj,pipeline) -> do
-
-        {-
-        let pipeline = pipeline0 { dynamicPipeline = (dynamicPipeline pipeline0) 
-                                    { targets = fmap nocolorv (targets $ dynamicPipeline pipeline0) } }
-            nocolorv (RenderTarget v) = RenderTarget (fmap nocolor v)
-            nocolor (TargetItem LC.Color (Just (Framebuffer LC.Color))) = TargetItem LC.Color Nothing
-            nocolor x = x -}
-
-        -- putStrLn $ ppShow (dynamicPipeline pipeline)
         mapM_ (putStrLn . ppShow) (targets $ dynamicPipeline pipeline)
-        {-
-        RenderTarget
-          { renderTargets =
-              [ TargetItem { targetSemantic = Depth , targetRef = Just (Framebuffer Depth) }
-              , TargetItem { targetSemantic = Color , targetRef = Just (Framebuffer Color) }
-              ]
-          }
-        -}
-
         ref <- newIORef Nothing
-        -- glarea <- newGLWidget return (lambdaRender app glmethods)
-        do
+        (groups,liststore) <- newGroupsListWidget
+        panes <- panedNew OrientationHorizontal
+        g <- do
             g <- gLAreaNew
-            let mm = MeshSketch g ref
+            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
+        panedPack1 panes g True True
+        return panes
+
+
+newGroupsListWidget = do
+    liststore <- listStoreNew [gtypeBoolean,gtypeString]
+    treeView <- treeViewNewWithModel liststore
+    togc <- do
+        togr <- cellRendererToggleNew
+        togc <- treeViewColumnNew
+        treeViewColumnPackStart togc togr False
+        return togc
+    groupc <- do
+        groupr <- cellRendererTextNew
+        -- grey <- newZeroRGBA
+        -- -- b <- rGBAParse grey "rgb(128,128,128)"
+        -- setCellRendererTextBackgroundRgba groupr grey
+        -- setCellRendererTextForegroundRgba groupr grey
+        -- -- rGBAFree grey
+        groupc <- treeViewColumnNew
+        -- treeViewColumnSetTitle groupc "group"
+        treeViewColumnPackStart groupc groupr False
+        return groupc
+    one <- treeViewAppendColumn treeView togc
+    two <- treeViewAppendColumn treeView groupc
+    iter <- listStoreAppend liststore
+    gvalue <- toGValue (Just "sample text" :: Maybe Text)
+    gtrue <- toGValue True
+    listStoreSetValue liststore iter 0 gtrue
+    listStoreSetValue liststore iter 1 gvalue
+    return (treeView,liststore)
+
+
 
 onUnrealize :: MeshSketch -> IO ()
 onUnrealize mm = do
@@ -392,6 +412,14 @@ onRealize mesh pipeline schema mm = do
     sigr <- on w #render $ onRender w r
     sigs <- on w #resize $ onResize w r
 
+    do
+        panedWin <- widgetGetWindow (mmPaned mm)
+        widgetShow (mmGroupsPanel mm)
+        panedPack2 (mmPaned mm) (mmGroupsPanel mm) True True
+        forM_ panedWin $ \win -> do
+            panedW <- windowGetWidth win
+            panedSetPosition (mmPaned mm) (panedW * 8 `div` 10)
+    -- widgetQueueAllocate (mmPaned mm)
     writeIORef (mmRealized mm) $ Just r { stSigs = [sige,sigr,sigs] }
 
 onRender :: w -> Realized -> GLContext -> IO Bool
@@ -694,6 +722,7 @@ onEvent w realized ev = do
                 -- end doDragPlane
 
         EventTypeButtonPress -> do
+            widgetGrabFocus w
             bev <- get ev #button
             h <- get bev #x
             k <- get bev #y