diff --git a/.travis.yml b/.travis.yml --- a/.travis.yml +++ b/.travis.yml @@ -1,7 +1,7 @@ # from https://github.com/hvr/multi-ghc-travis env: - - GHCVER=7.6.3 +# - GHCVER=7.6.3 # todo: re-enable this - GHCVER=7.8.3 # see note about Alex/Happy before_install: diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -26,3 +26,8 @@ * Major performance improvements (only draw new data) * Both "history" and custom plot interfaces * Unify this package with the dynobud plotter + +0.5.0.1 +--- +* Hierarchical visibility clicking and inconsistent state +* Merge new signal tree with old diff --git a/Plot-ho-matic.cabal b/Plot-ho-matic.cabal --- a/Plot-ho-matic.cabal +++ b/Plot-ho-matic.cabal @@ -1,5 +1,5 @@ name: Plot-ho-matic -version: 0.5.0.0 +version: 0.5.0.1 synopsis: Real-time line plotter for protobuf-like data license: BSD3 license-file: LICENSE @@ -61,5 +61,5 @@ , Plot-ho-matic , containers - ghc-options: -O2 + ghc-options: -O2 -with-rtsopts=-T ghc-prof-options: -O2 -Wall -prof -fprof-auto -fprof-cafs -rtsopts diff --git a/examples/Example.hs b/examples/Example.hs --- a/examples/Example.hs +++ b/examples/Example.hs @@ -9,36 +9,39 @@ import PlotHo ( Lookup, XAxisType(..), runPlotter, addHistoryChannel ) -data Xyz = MkXyz { x :: Double - , y :: Double - , z :: Double - } deriving Generic +data Xyz a = MkXyz { x :: Double + , y :: Double + , z :: Double + , zz :: a + } deriving Generic data Axyz = MkAxyz { lol :: Double -- , xyzList :: S.Seq Xyz - , xyz :: Xyz + , xyz1 :: Xyz (Xyz (Xyz Double)) + , xyz2 :: Xyz Double } deriving Generic -instance Lookup Xyz +instance Lookup a => Lookup (Xyz a) instance Lookup Axyz axyz0 :: Axyz axyz0 = MkAxyz 7 -- (S.fromList [MkXyz 1 2 3]) - (MkXyz 1 2 3) + (MkXyz 1 2 3 (MkXyz 4 5 6 (MkXyz 7 8 9 10))) + (MkXyz 1 2 3 4) -xyz0 :: Xyz -xyz0 = MkXyz 1 2 3 +xyz0 :: Xyz Double +xyz0 = MkXyz 1 2 3 0.1 incrementAxyz :: Axyz -> Axyz -incrementAxyz (MkAxyz a _) = MkAxyz +incrementAxyz (MkAxyz a _ _) = MkAxyz (a+0.2) --- (S.take 5 (xyz <| xyzs)) - xyz' + (xyz' (xyz' (xyz' (sin (3*a))))) + (xyz' (sin (2*a))) where - xyz' = MkXyz (sin a) (cos a) (sin a * cos a) + xyz' w = MkXyz (sin a) (cos a) (sin a * cos a) w -incrementXyz :: Xyz -> Xyz -incrementXyz (MkXyz a _ _) = MkXyz (a+0.3) (2 * sin a) (3 * cos a) +incrementXyz :: Xyz a -> Xyz a +incrementXyz (MkXyz a _ _ b) = MkXyz (a+0.3) (2 * sin a) (3 * cos a) b -- a random function to write a bunch of data to a chan channelWriter :: Int -> Int -> (a -> a) -> a -> (a -> Bool -> IO ()) -> IO () diff --git a/src/PlotHo.hs b/src/PlotHo.hs --- a/src/PlotHo.hs +++ b/src/PlotHo.hs @@ -321,15 +321,17 @@ -- button to clear history buttonAlsoDoNothing <- Gtk.buttonNewWithLabel "also do nothing" - _ <- Gtk.onClicked buttonAlsoDoNothing $ do - putStrLn "i promise, nothing happens" - -- CC.modifyMVar_ logData (const (return S.empty)) - return () +-- _ <- Gtk.onClicked buttonAlsoDoNothing $ do +-- putStrLn "i promise, nothing happens" +-- -- CC.modifyMVar_ logData (const (return S.empty)) +-- return () + let triggerYo action = Gtk.onClicked buttonAlsoDoNothing action >> return () -- button to make a new graph buttonNew <- Gtk.buttonNewWithLabel "new graph" _ <- Gtk.onClicked buttonNew $ do graphWin <- newGraph + triggerYo (chanName channel) (chanSameSignalTree channel) (chanToSignalTree channel) diff --git a/src/PlotHo/GraphWidget.hs b/src/PlotHo/GraphWidget.hs --- a/src/PlotHo/GraphWidget.hs +++ b/src/PlotHo/GraphWidget.hs @@ -8,6 +8,7 @@ import qualified Control.Concurrent as CC import Control.Monad ( when, unless ) import qualified Data.IORef as IORef +import qualified Data.Map as M import Data.Maybe ( isJust, fromJust ) import qualified Data.Tree as Tree import Graphics.UI.Gtk ( AttrOp( (:=) ) ) @@ -18,16 +19,17 @@ import qualified Graphics.Rendering.Chart as Chart import PlotHo.PlotChart ( AxisScaling(..), displayChart, chartGtkUpdateCanvas ) -import PlotHo.PlotTypes ( GraphInfo(..), ListViewInfo(..) ) +import PlotHo.PlotTypes ( GraphInfo(..), ListViewInfo(..), MarkedState(..) ) -- make a new graph window newGraph :: forall a - . String + . (IO () -> IO ()) + -> String -> (a -> a -> Bool) -> (a -> [Tree.Tree (String, String, Maybe (a -> [[(Double, Double)]]))]) -> Gtk.ListStore a -> IO Gtk.Window -newGraph channame sameSignalTree forestFromMeta msgStore = do +newGraph onButton channame sameSignalTree forestFromMeta msgStore = do win <- Gtk.windowNew _ <- Gtk.set win [ Gtk.containerBorderWidth := 8 @@ -77,7 +79,7 @@ -- the signal selector - treeview' <- newSignalSelectorArea sameSignalTree forestFromMeta graphInfoMVar msgStore redraw + treeview' <- newSignalSelectorArea onButton sameSignalTree forestFromMeta graphInfoMVar msgStore redraw treeview <- Gtk.expanderNew "signals" Gtk.set treeview [ Gtk.containerChild := treeview' , Gtk.expanderExpanded := True @@ -108,12 +110,13 @@ newSignalSelectorArea :: forall a - . (a -> a -> Bool) + . (IO () -> IO ()) + -> (a -> a -> Bool) -> (a -> [Tree.Tree (String, String, Maybe (a -> [[(Double, Double)]]))]) -> CC.MVar (GraphInfo a) -> Gtk.ListStore a -> IO () -> IO Gtk.ScrolledWindow -newSignalSelectorArea sameSignalTree forestFromMeta graphInfoMVar msgStore redraw = do +newSignalSelectorArea onButton sameSignalTree forestFromMeta graphInfoMVar msgStore redraw = do treeStore <- Gtk.treeStoreNew [] treeview <- Gtk.treeViewNewWithModel treeStore @@ -137,8 +140,18 @@ showName Nothing name typeName = name ++ " (" ++ typeName ++ ")" Gtk.cellLayoutSetAttributes col1 renderer1 treeStore $ \(ListViewInfo {lviName = name, lviType = typeName, lviGetter = getter}) -> - [ Gtk.cellText := showName getter name typeName] - Gtk.cellLayoutSetAttributes col2 renderer2 treeStore $ \lvi -> [ Gtk.cellToggleActive := lviMarked lvi] + [ Gtk.cellText := showName getter name typeName + ] + Gtk.cellLayoutSetAttributes col2 renderer2 treeStore $ \lvi -> case lviMarked lvi of + On -> [ Gtk.cellToggleInconsistent := False + , Gtk.cellToggleActive := True + ] + Off -> [ Gtk.cellToggleInconsistent := False + , Gtk.cellToggleActive := False + ] + Inconsistent -> [ Gtk.cellToggleActive := False + , Gtk.cellToggleInconsistent := True + ] _ <- Gtk.treeViewAppendColumn treeview col1 _ <- Gtk.treeViewAppendColumn treeview col2 @@ -154,37 +167,121 @@ theTrees <- getTrees 0 let newGetters = [ (lviName lvi, fromJust $ lviGetter lvi) | lvi <- concatMap Tree.flatten theTrees - , lviMarked lvi + , lviMarked lvi == On , isJust (lviGetter lvi) ] _ <- CC.modifyMVar_ graphInfoMVar (\gi0 -> return $ gi0 { giGetters = newGetters }) return () + i2p i = Gtk.treeModelGetPath treeStore i + p2i p = do + mi <- Gtk.treeModelGetIter treeStore p + case mi of Nothing -> error "no iter at that path" + Just i -> return i + -- update which y axes are visible _ <- on renderer2 Gtk.cellToggled $ \pathStr -> do let treePath = Gtk.stringToTreePath pathStr + + getChildrenPaths path' = do + iter' <- p2i path' + let getChildPath k = do + mc <- Gtk.treeModelIterNthChild treeStore (Just iter') k + case mc of + Nothing -> error "no child" + Just c -> i2p c + n <- Gtk.treeModelIterNChildren treeStore (Just iter') + mapM getChildPath (take n [0..]) + + changeSelfAndChildren change path' = do + childrenPaths <- getChildrenPaths path' + ret <- Gtk.treeStoreChange treeStore path' change + when (not ret) $ error "treeStoreChange fail" + mapM_ (changeSelfAndChildren change) childrenPaths + + fixInconsistent path' = do + mparentIter <- p2i path' >>= Gtk.treeModelIterParent treeStore + case mparentIter of + Nothing -> return () + Just parentIter -> do + parentPath <- i2p parentIter + siblingPaths <- getChildrenPaths parentPath + siblings <- mapM (Gtk.treeStoreGetValue treeStore) siblingPaths + let markedSiblings :: [MarkedState] + markedSiblings = map lviMarked siblings + + changeParent + | all (== On) markedSiblings = + Gtk.treeStoreChange treeStore parentPath (\lvi -> lvi {lviMarked = On}) + | all (== Off) markedSiblings = + Gtk.treeStoreChange treeStore parentPath (\lvi -> lvi {lviMarked = Off}) + | otherwise = + Gtk.treeStoreChange treeStore parentPath (\lvi -> lvi {lviMarked = Inconsistent}) + ret <- changeParent + when (not ret) $ error "fixInconsistent couldn't change parent" + fixInconsistent parentPath + return () + -- toggle the check mark - let g lvi@(ListViewInfo _ _ Nothing _) = lvi - g lvi = lvi {lviMarked = not (lviMarked lvi)} - ret <- Gtk.treeStoreChange treeStore treePath g - unless ret $ putStrLn "treeStoreChange fail" + val <- Gtk.treeStoreGetValue treeStore treePath + case val of + (ListViewInfo _ _ Nothing Off) -> + changeSelfAndChildren (\lvi -> lvi {lviMarked = On}) treePath + (ListViewInfo _ _ Nothing On) -> + changeSelfAndChildren (\lvi -> lvi {lviMarked = Off}) treePath + (ListViewInfo _ _ Nothing Inconsistent) -> + changeSelfAndChildren (\lvi -> lvi {lviMarked = On}) treePath + lvi@(ListViewInfo _ _ (Just _) On) -> + Gtk.treeStoreSetValue treeStore treePath $ lvi {lviMarked = Off} + lvi@(ListViewInfo _ _ (Just _) Off) -> + Gtk.treeStoreSetValue treeStore treePath $ lvi {lviMarked = On} + (ListViewInfo _ _ (Just _) Inconsistent) -> error "cell getter can't be inconsistent" + + fixInconsistent treePath updateGraphInfo redraw + let getTopForest = do + nTopLevelNodes <- Gtk.treeModelIterNChildren treeStore Nothing + mnodes <- mapM (Gtk.treeModelIterNthChild treeStore Nothing) (take nTopLevelNodes [0..]) + let treeFromJust (Just x) = i2p x >>= Gtk.treeStoreGetTree treeStore + treeFromJust Nothing = error "missing top level node" + mapM treeFromJust mnodes -- rebuild the signal tree let rebuildSignalTree :: [Tree.Tree (String, String, Maybe (a -> [[(Double, Double)]]))] -> IO () rebuildSignalTree meta = do - let mkTreeNode (name,typeName,maybeget) = ListViewInfo name typeName maybeget False - newTrees :: [Tree.Tree (ListViewInfo a)] - newTrees = map (fmap mkTreeNode) meta + putStrLn "rebuilding signal tree" + + oldTrees <- getTopForest + let _ = oldTrees :: [Tree.Tree (ListViewInfo a)] + + merge :: forall b + . [Tree.Tree (ListViewInfo b)] + -> [Tree.Tree (String, String, Maybe (a -> [[(Double, Double)]]))] + -> [Tree.Tree (ListViewInfo a)] + merge old new = map convert new + where + oldMap :: M.Map (String, String) (ListViewInfo b, [Tree.Tree (ListViewInfo b)]) + oldMap = M.fromList $ + map (\(Tree.Node lvi lvis) -> ((lviName lvi, lviType lvi), (lvi, lvis))) old + + convert :: Tree.Tree (String, String, Maybe (a -> [[(Double, Double)]])) + -> Tree.Tree (ListViewInfo a) + convert (Tree.Node (name,typ, getter) others) = case M.lookup (name,typ) oldMap of + Nothing -> Tree.Node (ListViewInfo name typ getter Off) (merge [] others) + Just (lvi, oldOthers) -> Tree.Node (ListViewInfo name typ getter (lviMarked lvi)) (merge oldOthers others) + + newTrees = merge oldTrees meta + Gtk.treeStoreClear treeStore Gtk.treeStoreInsertForest treeStore [] 0 newTrees updateGraphInfo oldMetaRef <- IORef.newIORef Nothing - let maybeRebuildSignalTree newMeta = do + let maybeRebuildSignalTree :: a -> IO () + maybeRebuildSignalTree newMeta = do oldMeta <- IORef.readIORef oldMetaRef let sameSignalTree' Nothing _ = False sameSignalTree' (Just x) y = sameSignalTree x y @@ -205,6 +302,11 @@ when (size > 0) $ do newMsg <- Gtk.listStoreGetValue msgStore 0 maybeRebuildSignalTree newMsg >> redraw + + -- for debugging + onButton $ do + newMsg <- Gtk.listStoreGetValue msgStore 0 + rebuildSignalTree (forestFromMeta newMsg) >> redraw scroll <- Gtk.scrolledWindowNew Nothing Nothing diff --git a/src/PlotHo/PlotTypes.hs b/src/PlotHo/PlotTypes.hs --- a/src/PlotHo/PlotTypes.hs +++ b/src/PlotHo/PlotTypes.hs @@ -7,19 +7,25 @@ , GraphInfo(..) , ListViewInfo(..) , AxisScaling(..) + , MarkedState(..) ) where import Data.Tree ( Tree ) import qualified Graphics.UI.Gtk as Gtk import Data.IORef ( IORef ) +data MarkedState = + On | Off | Inconsistent deriving (Eq, Show) + data ListViewInfo a = ListViewInfo { lviName :: String , lviType :: String , lviGetter :: Maybe (a -> [[(Double,Double)]]) - , lviMarked :: Bool + , lviMarked :: MarkedState } +instance Show (ListViewInfo a) where + show (ListViewInfo n t _ m) = "ListViewInfo " ++ show (n,t,m) data AxisScaling = LogScaling | LinearScaling