Plot-ho-matic 0.6.0.0 → 0.7.0.0
raw patch · 6 files changed
+178/−43 lines, 6 filesdep +vectorPVP ok
version bump matches the API change (PVP)
Dependencies added: vector
API changes (from Hackage documentation)
+ PlotHo: addHistoryChannel' :: String -> ((Double -> Vector Double -> Maybe Meta -> IO ()) -> IO ()) -> Plotter ()
+ PlotHo: type Meta = [Tree ([String], String, Maybe Int)]
- PlotHo: addChannel :: String -> (a -> a -> Bool) -> (a -> [Tree (String, String, Maybe (a -> [[(Double, Double)]]))]) -> ((a -> IO ()) -> IO ()) -> Plotter ()
+ PlotHo: addChannel :: String -> (a -> a -> Bool) -> (a -> [Tree ([String], String, Maybe (a -> [[(Double, Double)]]))]) -> ((a -> IO ()) -> IO ()) -> Plotter ()
Files
- CHANGELOG.md +4/−0
- Plot-ho-matic.cabal +2/−1
- src/PlotHo.hs +93/−16
- src/PlotHo/GraphWidget.hs +64/−19
- src/PlotHo/PlotChart.hs +12/−5
- src/PlotHo/PlotTypes.hs +3/−2
CHANGELOG.md view
@@ -39,3 +39,7 @@ 0.5.0.5 --- * Compatability with generic-accessors 0.2++0.7.0.0+---+* Better legend and title.
Plot-ho-matic.cabal view
@@ -1,5 +1,5 @@ name: Plot-ho-matic-version: 0.6.0.0+version: 0.7.0.0 synopsis: Real-time line plotter for generic data license: BSD3 license-file: LICENSE@@ -40,6 +40,7 @@ , Chart-cairo >= 1.1 , cairo , text+ , vector , generic-accessors >= 0.5.0.0 ghc-options: -O2 -Wall
src/PlotHo.hs view
@@ -7,6 +7,8 @@ , runPlotter , XAxisType(..) , addHistoryChannel+ , Meta+ , addHistoryChannel' , addChannel -- * re-exported for convenience , Lookup@@ -24,6 +26,8 @@ import Data.Time ( NominalDiffTime, getCurrentTime, diffUTCTime ) import Data.Tree ( Tree ) import qualified Data.Tree as Tree+import Data.Vector ( Vector )+import qualified Data.Vector as V import Graphics.UI.Gtk ( AttrOp( (:=) ) ) import qualified Graphics.UI.Gtk as Gtk import Text.Printf ( printf )@@ -78,7 +82,7 @@ -- The worker should pass True to reset the message history, so sending True the first message and False subsequent messages is a good starting place. -- You will have to recompile the plotter if the types change. -- If you don't want to do this, use the more generic "addChannel" interface--- and use a type like a Tree to represent your data.+-- and use a type like a Tree to represent your data, or use the "addHistoryChannel'" function. addHistoryChannel :: Lookup a => String -- ^ channel name@@ -92,6 +96,18 @@ , csMkChanEntry = newChannelWidget chan } +-- | Dynamic time-series channel which can change its signal tree without recompiling the plotter.+addHistoryChannel' ::+ String -- ^ channel name+ -> ((Double -> Vector Double -> Maybe Meta -> IO ()) -> IO ()) -- ^ worker which is passed a "new message" function, this will be forked with 'forkIO'+ -> Plotter ()+addHistoryChannel' name action = do+ (chan, newMessage) <- liftIO $ newHistoryChannel' name+ workerTid <- liftIO $ CC.forkIO (action newMessage)+ tell ChannelStuff { csKillThreads = CC.killThread workerTid+ , csMkChanEntry = newChannelWidget chan+ }+ -- | This is the general interface to plot whatever you want. -- Use this when you want to give the whole time series in one go, rather than one at a time -- such as with 'addHistoryChannel'.@@ -100,7 +116,7 @@ addChannel :: String -- ^ channel name -> (a -> a -> Bool) -- ^ Is the signal tree the same? This is used for instance if signals have changed and the plotter needs to rebuild the signal tree. This lets you keep the plotter running and change other programs which send messages to the plotter.- -> (a -> [Tree (String, String, Maybe (a -> [[(Double, Double)]]))]) -- ^ how to build the signal tree+ -> (a -> [Tree ([String], String, Maybe (a -> [[(Double, Double)]]))]) -- ^ how to build the signal tree -> ((a -> IO ()) -> IO ()) -- ^ worker which is passed a "new message" function, this will be forked with 'forkIO' -> Plotter () addChannel name sameSignalTree toSignalTree action = do@@ -115,7 +131,7 @@ forall a . String -> (a -> a -> Bool)- -> (a -> [Tree (String, String, Maybe (a -> [[(Double, Double)]]))])+ -> (a -> [Tree ([String], String, Maybe (a -> [[(Double, Double)]]))]) -> IO (Channel a, a -> IO ()) newChannel name sameSignalTree toSignalTree = do msgStore <- Gtk.listStoreNew []@@ -141,8 +157,7 @@ data History a = History (S.Seq (a, Int, NominalDiffTime))--type SignalTree a = Tree.Forest (String, String, Maybe (History a -> [[(Double, Double)]]))+type HistorySignalTree a = Tree.Forest ([String], String, Maybe (History a -> [[(Double, Double)]])) data XAxisType = XAxisTime -- ^ time since the first message@@ -150,19 +165,19 @@ | XAxisCount -- ^ message index | XAxisCount0 -- ^ message index, normalized to 0 (to reduce plot jitter) -historySignalTree :: forall a . Lookup a => XAxisType -> SignalTree a+historySignalTree :: forall a . Lookup a => XAxisType -> HistorySignalTree a historySignalTree axisType = case accessors of (Field _) -> error "historySignalTree: got a Field right away"- d -> Tree.subForest $ head $ makeSignalTree' "" "" d+ d -> Tree.subForest $ head $ makeSignalTree' [] "" d where- makeSignalTree' :: String -> String -> AccessorTree a -> SignalTree a- makeSignalTree' myName parentName (Data (pn,_) children) =+ makeSignalTree' :: [String] -> String -> AccessorTree a -> HistorySignalTree a+ makeSignalTree' myFieldName parentTypeName (Data (ptn,_) children) = [Tree.Node- (myName, parentName, Nothing)- (concatMap (\(getterName,child) -> makeSignalTree' getterName pn child) children)+ (reverse myFieldName, parentTypeName, Nothing)+ (concatMap (\(getterName, child) -> makeSignalTree' (getterName:myFieldName) ptn child) children) ]- makeSignalTree' myName parentName (Field field) =- [Tree.Node (myName, parentName, Just (toHistoryGetter (toDoubleGetter field))) []]+ makeSignalTree' myFieldName parentTypeName (Field field) =+ [Tree.Node (reverse myFieldName, parentTypeName, Just (toHistoryGetter (toDoubleGetter field))) []] toDoubleGetter :: Field a -> (a -> Double) toDoubleGetter (FieldDouble f) = (^. f)@@ -230,13 +245,12 @@ then Gtk.listStorePrepend msgStore (History (S.singleton val)) else do History vals0 <- Gtk.listStoreGetValue msgStore 0 maxHistory <- IORef.readIORef maxHist- let undropped = vals0 S.|> val- dropped = S.drop (S.length undropped - maxHistory) undropped+ let dropped = S.drop (1 + S.length vals0 - maxHistory) (vals0 S.|> val) Gtk.listStoreSetValue msgStore 0 (History dropped) when reset $ Gtk.listStoreSetValue msgStore 0 (History (S.singleton val)) - let tst :: History a -> [Tree ( String+ let tst :: History a -> [Tree ( [String] , String , Maybe (History a -> [[(Double, Double)]]) )]@@ -246,6 +260,69 @@ , chanMsgStore = msgStore , chanSameSignalTree = \_ _ -> True , chanToSignalTree = tst+ , chanMaxHistory = maxHist+ }++ return (retChan, newMessage)++type Meta = [Tree ([String], String, Maybe Int)]+data History' = History' Bool (S.Seq (Double, Vector Double)) Meta++-- History channel which does NOT automatically generates the signal tree for you.+-- This is the internal part which should be wrapped by addHistoryChannel'.+newHistoryChannel' ::+ String -> IO (Channel History', Double -> Vector Double -> Maybe Meta -> IO ())+newHistoryChannel' name = do+ maxHist <- IORef.newIORef 200++ msgStore <- Gtk.listStoreNew []++ let newMessage :: Double -> Vector Double -> Maybe Meta -> IO ()+ newMessage nextTime nextVal maybeMeta = do+ Gtk.postGUIAsync $ do+ let val = (nextTime, nextVal)+ size <- Gtk.listStoreGetSize msgStore+ if size == 0+ then case maybeMeta of+ Just meta -> Gtk.listStorePrepend msgStore (History' True (S.singleton val) meta)+ Nothing -> error "history channel got size 0 message store but no reset"+ else do History' _ vals0 meta <- Gtk.listStoreGetValue msgStore 0+ maxHistory <- IORef.readIORef maxHist+ let dropped = S.drop (1 + S.length vals0 - maxHistory) (vals0 S.|> val)+ Gtk.listStoreSetValue msgStore 0 (History' False dropped meta)++ -- reset on new meta+ case maybeMeta of+ Nothing -> return () -- no reset+ Just meta -> Gtk.listStoreSetValue msgStore 0 (History' True (S.singleton val) meta)++ let toSignalTree :: History'+ -> [Tree ( [String]+ , String+ , Maybe (History' -> [[(Double, Double)]])+ )]+ toSignalTree (History' _ _ meta) = map (fmap f) meta+ where+ f :: ([String], String, Maybe Int)+ -> ([String], String, Maybe (History' -> [[(Double, Double)]]))+ f (n0, n1, Nothing) = (n0, n1, Nothing)+ f (n0, n1, Just k) = (n0, n1, Just g)+ where+ g :: History' -> [[(Double, Double)]]+ g (History' _ vals _) = [map toVal (F.toList vals)]+ where+ toVal (t, x) = (t, x V.! k)++ sameSignalTree :: History' -> History' -> Bool+ -- assume the signal trees are the same if it's not a reset+ sameSignalTree (History' _ _ _) (History' False _ _) = True+ -- if it's a reset, then compare the signal trees+ sameSignalTree (History' _ _ old) (History' True _ new) = old == new++ let retChan = Channel { chanName = name+ , chanMsgStore = msgStore+ , chanSameSignalTree = sameSignalTree+ , chanToSignalTree = toSignalTree , chanMaxHistory = maxHist }
src/PlotHo/GraphWidget.hs view
@@ -8,8 +8,9 @@ import qualified Control.Concurrent as CC import Control.Monad ( void, when, unless ) import qualified Data.IORef as IORef+import Data.List ( intercalate ) import qualified Data.Map as M-import Data.Maybe ( isJust, fromJust )+import Data.Maybe ( isNothing, isJust, fromJust ) import qualified Data.Tree as Tree import Graphics.UI.Gtk ( AttrOp( (:=) ) ) import qualified Graphics.UI.Gtk as Gtk@@ -27,7 +28,7 @@ . (IO () -> IO ()) -> String -> (a -> a -> Bool)- -> (a -> [Tree.Tree (String, String, Maybe (a -> [[(Double, Double)]]))])+ -> (a -> [Tree.Tree ([String], String, Maybe (a -> [[(Double, Double)]]))]) -> Gtk.ListStore a -> IO Gtk.Window newGraph onButton channame sameSignalTree forestFromMeta msgStore = do win <- Gtk.windowNew@@ -42,6 +43,7 @@ , giXRange = Nothing , giYRange = Nothing , giGetters = []+ , giTitle = Nothing } :: IO (CC.MVar (GraphInfo a)) let makeRenderable :: IO (Chart.Renderable ())@@ -56,7 +58,7 @@ let ret :: [(String, [[(Double,Double)]])] ret = map (fmap (\g -> g datalog)) (giGetters gi) return ret- return $ displayChart (giXScaling gi, giYScaling gi) (giXRange gi, giYRange gi) namePcs+ return $ displayChart (giXScaling gi, giYScaling gi) (giXRange gi, giYRange gi) (giTitle gi) namePcs -- chart drawing area chartCanvas <- Gtk.drawingAreaNew@@ -118,13 +120,43 @@ Gtk.widgetShowAll win return win +-- The greatest common prefix will be the title.+-- Everything after that is the field name.+gettersAndTitle :: forall a . [([String], a)] -> ([(String, a)], Maybe String)+gettersAndTitle getters0 = (getters2, titles'')+ where+ titles'' = case titles' of+ [] -> Nothing+ ts -> Just $ intercalate "." (reverse ts)+ titles' :: [String] + (titles', getters1) = f [] getters0+ getters2 = map (\(x,y) -> (intercalate "." x, y)) getters1 + extractHead (x:xs, y) = Just (x, (xs, y))+ extractHead ([], _) = Nothing++ f titles xs0+ | any isNothing xs = (titles, xs0)+ | otherwise = case xs' of+ [] -> (titles, xs0)+ (prefix, _):others+ -- if all prefixes match, do another recursion+ | all ((prefix ==) . fst) others -> f (prefix:titles) (map snd xs')+ -- otherwise we're done+ | otherwise -> (titles, xs0)+ where+ xs :: [Maybe (String, ([String], a))]+ xs = map extractHead xs0++ xs' :: [(String, ([String], a))]+ xs' = map fromJust xs+ newSignalSelectorArea :: forall a . (IO () -> IO ()) -> (a -> a -> Bool)- -> (a -> [Tree.Tree (String, String, Maybe (a -> [[(Double, Double)]]))])+ -> (a -> [Tree.Tree ([String], String, Maybe (a -> [[(Double, Double)]]))]) -> CC.MVar (GraphInfo a) -> Gtk.ListStore a -> IO () -> IO Gtk.ScrolledWindow@@ -147,12 +179,19 @@ Gtk.cellLayoutPackStart col1 renderer1 True Gtk.cellLayoutPackStart col2 renderer2 True - let showName (Just _) name _ = name- showName Nothing name "" = name- showName Nothing name typeName = name ++ " (" ++ typeName ++ ")"+ let showName :: Maybe (a -> [[(Double, Double)]]) -> [String] -> String -> String+ -- show a getter name+ showName (Just _) (name:_) _ = name+ showName (Just _) [] _ = error "showName on field got an empty list"+ -- show a parent without type info+ showName Nothing (name:_) "" = name+ -- show a parent with type info+ showName Nothing (name:_) typeName = name ++ " (" ++ typeName ++ ")"+ showName Nothing [] _ = error "showName on parent got an empty list"+ Gtk.cellLayoutSetAttributes col1 renderer1 treeStore $ \(ListViewInfo {lviName = name, lviType = typeName, lviGetter = getter}) ->- [ Gtk.cellText := showName getter name typeName+ [ Gtk.cellText := showName getter (reverse name) typeName ] Gtk.cellLayoutSetAttributes col2 renderer2 treeStore $ \lvi -> case lviMarked lvi of On -> [ Gtk.cellToggleInconsistent := False@@ -177,12 +216,18 @@ case tree' of Nothing -> return [] Just tree -> fmap (tree:) (getTrees (k+1)) theTrees <- getTrees 0- let newGetters = [ (lviName lvi, fromJust $ lviGetter lvi)- | lvi <- concatMap Tree.flatten theTrees- , lviMarked lvi == On- , isJust (lviGetter lvi)- ]- _ <- CC.modifyMVar_ graphInfoMVar (\gi0 -> return $ gi0 { giGetters = newGetters })+ let newGetters0 :: [([String], a -> [[(Double, Double)]])]+ newGetters0 = [ (lviName lvi, fromJust $ lviGetter lvi)+ | lvi <- concatMap Tree.flatten theTrees+ , lviMarked lvi == On+ , isJust (lviGetter lvi)+ ]+ let newGetters :: [(String, a -> [[(Double, Double)]])]+ newTitle :: Maybe String+ (newGetters, newTitle) = gettersAndTitle newGetters0++ _ <- CC.modifyMVar_ graphInfoMVar $+ \gi0 -> return $ gi0 {giGetters = newGetters, giTitle = newTitle} return () i2p i = Gtk.treeModelGetPath treeStore i@@ -261,7 +306,7 @@ mapM treeFromJust mnodes -- rebuild the signal tree- let rebuildSignalTree :: [Tree.Tree (String, String, Maybe (a -> [[(Double, Double)]]))]+ let rebuildSignalTree :: [Tree.Tree ([String], String, Maybe (a -> [[(Double, Double)]]))] -> IO () rebuildSignalTree meta = do putStrLn "rebuilding signal tree"@@ -271,17 +316,17 @@ merge :: forall b . [Tree.Tree (ListViewInfo b)]- -> [Tree.Tree (String, String, Maybe (a -> [[(Double, Double)]]))]+ -> [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.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)]]))+ 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+ 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)
src/PlotHo/PlotChart.hs view
@@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE ScopedTypeVariables #-} module PlotHo.PlotChart ( AxisScaling(..)@@ -42,10 +43,12 @@ Gtk.drawWindowEndPaint win Gtk.threadsLeave -displayChart :: (Chart.PlotValue a, Show a, RealFloat a) =>- (AxisScaling, AxisScaling) -> (Maybe (a,a),Maybe (a,a)) ->- [(String, [[(a,a)]])] -> Chart.Renderable ()-displayChart (xScaling,yScaling) (xRange,yRange) namePcs = Chart.toRenderable layout+displayChart :: forall a+ . (Chart.PlotValue a, Show a, RealFloat a)+ => (AxisScaling, AxisScaling) -> (Maybe (a,a), Maybe (a,a))+ -> Maybe String+ -> [(String, [[(a,a)]])] -> Chart.Renderable ()+displayChart (xScaling, yScaling) (xRange, yRange) mtitle namePcs = Chart.toRenderable layout where drawOne (name,pc) col = Chart.plot_lines_values .~ pc@@ -53,6 +56,7 @@ -- $ Chart.plot_points_style ~. Chart.filledCircles 2 red $ Chart.plot_lines_title .~ name $ def+ allLines :: [Chart.PlotLines a a] allLines = zipWith drawOne namePcs Chart.defaultColorSeq xscaleFun = case xScaling of@@ -67,8 +71,11 @@ Nothing -> id Just range -> Chart.layout_y_axis . Chart.laxis_generate .~ Chart.scaledAxis def range + title = case mtitle of+ Nothing -> id+ Just t -> Chart.layout_title .~ t layout = Chart.layout_plots .~ map Chart.toPlot allLines--- $ Chart.layout_title .~ "Wooo, Party Graph!"+ $ title $ Chart.layout_x_axis . Chart.laxis_title .~ "time [s]" $ xscaleFun $ yscaleFun
src/PlotHo/PlotTypes.hs view
@@ -19,7 +19,7 @@ data ListViewInfo a = ListViewInfo- { lviName :: String+ { lviName :: [String] , lviType :: String , lviGetter :: Maybe (a -> [[(Double,Double)]]) , lviMarked :: MarkedState@@ -38,13 +38,14 @@ , giXRange :: Maybe (Double,Double) , giYRange :: Maybe (Double,Double) , giGetters :: [(String, a -> [[(Double,Double)]])]+ , giTitle :: Maybe String } data Channel a = Channel { chanName :: String , chanMsgStore :: Gtk.ListStore a , chanSameSignalTree :: a -> a -> Bool- , chanToSignalTree :: a -> [Tree ( String+ , chanToSignalTree :: a -> [Tree ( [String] , String , Maybe (a -> [[(Double, Double)]]) )]