Plot-ho-matic 0.9.0.3 → 0.9.0.4
raw patch · 12 files changed
+899/−682 lines, 12 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
- PlotHo: instance Control.Monad.IO.Class.MonadIO PlotHo.Plotter
- PlotHo: instance GHC.Base.Applicative PlotHo.Plotter
- PlotHo: instance GHC.Base.Functor PlotHo.Plotter
- PlotHo: instance GHC.Base.Monad PlotHo.Plotter
Files
- .travis.yml +16/−4
- CHANGELOG.md +7/−0
- Plot-ho-matic.cabal +15/−11
- README.md +19/−2
- examples/PlotExample.hs +3/−3
- src/PlotHo.hs +47/−512
- src/PlotHo/Channels.hs +417/−0
- src/PlotHo/ChartRender.hs +61/−0
- src/PlotHo/GraphWidget.hs +164/−65
- src/PlotHo/PlotChart.hs +0/−83
- src/PlotHo/PlotTypes.hs +9/−2
- src/PlotHo/Plotter.hs +141/−0
.travis.yml view
@@ -1,13 +1,26 @@ # from https://github.com/hvr/multi-ghc-travis +# explicitly request container-based infrastructure+sudo: false+ env: - CABALVER=1.22 GHCVER=7.8.4 # see note about Alex/Happy - CABALVER=1.22 GHCVER=7.10.3 # see note about Alex/Happy +addons:+ apt:+ sources:+ - hvr-ghc+ packages:+ - ghc-7.6.3+ - ghc-7.8.4+ - ghc-7.10.3+ - cabal-install-1.22+ - libgsl0-dev+ - liblapack-dev+ - libgtk-3-dev+ before_install:- - travis_retry sudo add-apt-repository -y ppa:hvr/ghc- - travis_retry sudo apt-get update- - travis_retry sudo apt-get install libgtk-3-dev cabal-install-$CABALVER ghc-$GHCVER libgsl0-dev liblapack-dev - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH install:@@ -16,7 +29,6 @@ - cabal install happy - cabal install gtk2hs-buildtools - for pkg in $(ghc-pkg list --user); do ghc-pkg unregister --force ${pkg}; done- - cabal install Cabal - cabal install --only-dependencies --enable-tests --enable-benchmarks --reorder-goals # Here starts the actual work to be performed for the package under test; any command which exits with a non-zero exit code causes the build to fail.
CHANGELOG.md view
@@ -1,3 +1,10 @@+0.9.0.4+---+* code cleanup+* use Gtk draw signal instead of expose signal (fixes buggy behavior)+* more understandable and maintainable concurrency strategy+* change default max history length to 500+ 0.9.0.3 --- * initial settings selector box is big enough to see some fields
Plot-ho-matic.cabal view
@@ -1,5 +1,5 @@ name: Plot-ho-matic-version: 0.9.0.3+version: 0.9.0.4 synopsis: Real-time line plotter for generic data license: BSD3 license-file: LICENSE@@ -25,27 +25,31 @@ hs-source-dirs: src default-language: Haskell2010 exposed-modules: PlotHo, SetHo- other-modules: PlotHo.GraphWidget,- PlotHo.PlotChart,++ other-modules: PlotHo.Channels,+ PlotHo.ChartRender,+ PlotHo.GraphWidget,+ PlotHo.Plotter, PlotHo.PlotTypes, SetHo.LookupTree SetHo.OptionsWidget+ build-depends: base >= 4.6.0.0 && < 5+ , bytestring+ , cairo , cereal+ , Chart >= 1.1+ , Chart-cairo >= 1.1 , containers- , bytestring- , lens , data-default-class+ , generic-accessors >= 0.6.0.0 , glib , gtk3 >= 0.14.2- , time- , Chart >= 1.1- , Chart-cairo >= 1.1- , cairo+ , lens , text- , vector+ , time , transformers- , generic-accessors >= 0.6.0.0+ , vector ghc-options: -O2 -Wall ghc-prof-options: -O2 -Wall -prof -fprof-auto -fprof-cafs -rtsopts
README.md view
@@ -1,10 +1,27 @@-Plot-ho-matic+Plot-ho-matic (and Set-ho-matic) == [](https://hackage.haskell.org/package/Plot-ho-matic) [](https://travis-ci.org/ghorn/Plot-ho-matic) -See the example in the examples folder for usage.+Plot-ho-matic is a GUI for high-performance real-time plotting with a convenient TreeView interface for+selecting which elements to draw from a data structure. The focus is on ease of use, with optional advanced interfaces for more features. +++The sister library Set-ho-matic is a GUI for editing haskell data and sending those changes to some running program. It can also query the program for it's latest data and has save and load features.++++Both Plot-ho-matic and Set-ho-matic rely heavily on [generic-accessors](http://hackage.haskell.org/package/generic-accessors) which uses GHC.Generics to create trees from haskell data.++# usage+See the hackage docs starting with the main [PlotHo](http://hackage.haskell.org/package/Plot-ho-matic/docs/PlotHo.html) module for documentation.+There is also an [examples](https://github.com/ghorn/Plot-ho-matic/tree/master/examples) folder in the git repository.++# FAQ "user error: out of memory" If you get this ^ error on OSX your cairo/pango/gtk may be linked to an XQuartz library. Add --extra-lib-dirs=/usr/local/lib (or wherever the correct libraries are) to your .cabal/config++==+Special thanks to Chart and gtk2hs, which do all the heavy lifting.
examples/PlotExample.hs view
@@ -58,7 +58,7 @@ -- ekgTid <- fmap EKG.serverThreadId $ EKG.forkServer "localhost" 8000 runPlotter $ do- addHistoryChannel "Foo (XAxisTime)" XAxisTime $ channelWriter 0 50000 incrementFoo foo0- addHistoryChannel "Bar (XAxisCount)" XAxisCount $ channelWriter 0 60000 incrementBar bar0- addHistoryChannel "Foo (XAxisTime0)" XAxisTime0 $ channelWriter 0 50000 incrementFoo foo0+ addHistoryChannel "Foo (XAxisTime)" XAxisTime $ channelWriter 0 50000 incrementFoo foo0+ addHistoryChannel "Bar (XAxisCount)" XAxisCount $ channelWriter 0 60000 incrementBar bar0+ addHistoryChannel "Foo (XAxisTime0)" XAxisTime0 $ channelWriter 0 50000 incrementFoo foo0 addHistoryChannel "Bar (XAxisCount0)" XAxisCount0 $ channelWriter 0 60000 incrementBar bar0
src/PlotHo.hs view
@@ -4,7 +4,13 @@ {-# LANGUAGE PackageImports #-} module PlotHo- ( Plotter+ ( -- * Usage+ -- $simple++ -- ** Dynamic data+ -- $dynamic++ Plotter , runPlotter , XAxisType(..) , addHistoryChannel@@ -15,519 +21,48 @@ , Lookup ) where -import qualified GHC.Stats--import Control.Applicative ( Applicative(..), liftA2 )-import Control.Lens ( (^.) )-import Data.Monoid ( mappend, mempty )-import Control.Monad ( when )-import Control.Monad.IO.Class ( MonadIO(..) )-import qualified Control.Concurrent as CC-import qualified Data.Foldable as F-import qualified Data.IORef as IORef-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 "gtk3" Graphics.UI.Gtk ( AttrOp( (:=) ) )-import qualified "gtk3" Graphics.UI.Gtk as Gtk-import Text.Printf ( printf )-import Text.Read ( readMaybe )-import System.Glib.Signals ( on )---import System.IO ( withFile, IOMode ( WriteMode ) )---import qualified Data.ByteString.Lazy as BSL-import qualified Data.Sequence as S--import Accessors--import PlotHo.PlotTypes ( Channel(..) )-import PlotHo.GraphWidget ( newGraph )---- | add channels to this, then run it with 'runPlotter'-newtype Plotter a = Plotter { unPlotter :: IO (a, [ChannelStuff]) } deriving Functor--instance Applicative Plotter where- pure x = Plotter $ pure (x, [])- f <*> v = Plotter $ liftA2 k (unPlotter f) (unPlotter v)- where k ~(a, w) ~(b, w') = (a b, w `mappend` w')--instance Monad Plotter where- return a = Plotter $ return (a, [])- m >>= k = Plotter $ do- ~(a, w) <- unPlotter m- ~(b, w') <- unPlotter (k a)- return (b, w `mappend` w')- fail msg = Plotter $ fail msg--instance MonadIO Plotter where- liftIO m = Plotter $ do- a <- m- return (a, mempty)--tell :: ChannelStuff -> Plotter ()-tell w = Plotter (return ((), [w]))--execPlotter :: Plotter a -> IO [ChannelStuff]-execPlotter m = do- ~(_, w) <- unPlotter m- return w--data ChannelStuff =- ChannelStuff- { csKillThreads :: IO ()- , csMkChanEntry :: CC.MVar [Gtk.Window] -> IO Gtk.VBox- }---- | Simplified time-series channel which passes a "send message" function to a worker and forks it using 'forkIO'.--- The plotter will plot a time series of messages sent by the worker.--- 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, or use the "addHistoryChannel'" function.-addHistoryChannel ::- Lookup a- => String -- ^ channel name- -> XAxisType -- ^ what to use for the X axis- -> ((a -> Bool -> IO ()) -> IO ()) -- ^ worker which is passed a "new message" function, this will be forked with 'forkIO'- -> Plotter ()-addHistoryChannel name xaxisType action = do- (chan, newMessage) <- liftIO $ newHistoryChannel name xaxisType- workerTid <- liftIO $ CC.forkIO (action newMessage)- tell ChannelStuff { csKillThreads = CC.killThread workerTid- , 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'.--- Using types or data, you must encode the signal tree with the message so that--- the plotter can build you the nice message toggle tree.-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], Either String (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- (chan, newMessage) <- liftIO $ newChannel name sameSignalTree toSignalTree- workerTid <- liftIO $ CC.forkIO (action newMessage)- tell ChannelStuff { csKillThreads = CC.killThread workerTid- , csMkChanEntry = newChannelWidget chan- }---newChannel ::- forall a- . String- -> (a -> a -> Bool)- -> (a -> [Tree ([String], Either String (a -> [[(Double, Double)]]))])- -> IO (Channel a, a -> IO ())-newChannel name sameSignalTree toSignalTree = do- msgStore <- Gtk.listStoreNew []- maxHist <- IORef.newIORef 0-- let newMessage :: a -> IO ()- newMessage next = do- -- grab the time and counter- Gtk.postGUIAsync $ do- size <- Gtk.listStoreGetSize msgStore- if size == 0- then Gtk.listStorePrepend msgStore next- else Gtk.listStoreSetValue msgStore 0 next-- let retChan = Channel { chanName = name- , chanMsgStore = msgStore- , chanSameSignalTree = sameSignalTree- , chanToSignalTree = toSignalTree- , chanMaxHistory = maxHist- }-- return (retChan, newMessage)---data History a = History (S.Seq (a, Int, NominalDiffTime))-type HistorySignalTree a = Tree.Forest ([String], Either String (History a -> [[(Double, Double)]]))--data XAxisType =- XAxisTime -- ^ time since the first message- | XAxisTime0 -- ^ time since the first message, normalized to 0 (to reduce plot jitter)- | XAxisCount -- ^ message index- | XAxisCount0 -- ^ message index, normalized to 0 (to reduce plot jitter)--historySignalTree :: forall a . Lookup a => XAxisType -> HistorySignalTree a-historySignalTree axisType = case accessors of- Left _ -> error "historySignalTree: got a Field right away"- acc -> Tree.subForest $ head $ makeSignalTree' [] acc- where- makeSignalTree' :: [String] -> AccessorTree a -> HistorySignalTree a- makeSignalTree' myFieldName (Right (GAData _ (GAConstructor cname children))) =- [Tree.Node- (reverse myFieldName, Left cname)- (concatMap (\(getterName, child) -> makeSignalTree' (fromMName getterName:myFieldName) child) children)- ]- makeSignalTree' myFieldName (Right (GAData _ (GASum enum))) =- [Tree.Node (reverse myFieldName, Right (toHistoryGetter (fromIntegral . eToIndex enum))) []]- makeSignalTree' myFieldName (Left field) =- [Tree.Node (reverse myFieldName, Right (toHistoryGetter (toDoubleGetter field))) []]- fromMName (Just x) = x- fromMName Nothing = "()"-- toDoubleGetter :: GAField a -> (a -> Double)- toDoubleGetter (FieldDouble f) = (^. f)- toDoubleGetter (FieldFloat f) = realToFrac . (^. f)- toDoubleGetter (FieldInt f) = fromIntegral . (^. f)- toDoubleGetter (FieldString _) = const 0- toDoubleGetter FieldSorry = const 0-- toHistoryGetter :: (a -> Double) -> History a -> [[(Double, Double)]]- toHistoryGetter = case axisType of- XAxisTime -> timeGetter- XAxisTime0 -> timeGetter0- XAxisCount -> countGetter- XAxisCount0 -> countGetter0-- timeGetter get (History s) = [map (\(val, _, time) -> (realToFrac time, get val)) (F.toList s)]- timeGetter0 get (History s) = [map (\(val, _, time) -> (realToFrac time - time0, get val)) (F.toList s)]- where- time0 :: Double- time0 = case S.viewl s of- (_, _, time0') S.:< _ -> realToFrac time0'- S.EmptyL -> 0- countGetter get (History s) = [map (\(val, k, _) -> (fromIntegral k, get val)) (F.toList s)]- countGetter0 get (History s) = [map (\(val, k, _) -> (fromIntegral k - k0, get val)) (F.toList s)]- where- k0 :: Double- k0 = case S.viewl s of- (_, k0', _) S.:< _ -> realToFrac k0'- S.EmptyL -> 0---- History channel which automatically generates the signal tree for you--- based on the Lookup instance. You have to recompile the plotter if--- the types change.--- This is the internal part which should be wrapped by addHistoryChannel.-newHistoryChannel ::- forall a- . Lookup a- => String- -> XAxisType- -> IO (Channel (History a), a -> Bool -> IO ())-newHistoryChannel name xaxisType = do- time0 <- getCurrentTime >>= IORef.newIORef- counter <- IORef.newIORef 0- maxHist <- IORef.newIORef 200-- msgStore <- Gtk.listStoreNew []-- let newMessage :: a -> Bool -> IO ()- newMessage next reset = do- -- grab the time and counter- time <- getCurrentTime- when reset $ do- IORef.writeIORef time0 time- IORef.writeIORef counter 0-- k <- IORef.readIORef counter- time0' <- IORef.readIORef time0-- IORef.writeIORef counter (k+1)- Gtk.postGUIAsync $ do- let val = (next, k, diffUTCTime time time0')- size <- Gtk.listStoreGetSize msgStore- if size == 0- then Gtk.listStorePrepend msgStore (History (S.singleton val))- else do History vals0 <- 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 dropped)-- when reset $ Gtk.listStoreSetValue msgStore 0 (History (S.singleton val))-- let tst :: History a -> [Tree ( [String]- , Either String (History a -> [[(Double, Double)]])- )]- tst = const (historySignalTree xaxisType)-- let retChan = Channel { chanName = name- , chanMsgStore = msgStore- , chanSameSignalTree = \_ _ -> True- , chanToSignalTree = tst- , chanMaxHistory = maxHist- }-- return (retChan, newMessage)--type Meta = [Tree ([String], Either String 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 $ unlines- [ "error: History channel has size 0 message store but no reset."- , "This means that the first message the plotter saw didn't contain the meta-data."- , "This was probably caused by starting the plotter AFTER sending the first telemetry message."- ]- 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]- , Either String (History' -> [[(Double, Double)]])- )]- toSignalTree (History' _ _ meta) = map (fmap f) meta- where- f :: ([String], Either String Int)- -> ([String], Either String (History' -> [[(Double, Double)]]))- f (n0, Left n1) = (n0, Left n1)- f (n0, Right k) = (n0, Right 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- }-- return (retChan, newMessage)---- | fire up the the GUI-runPlotter :: Plotter () -> IO ()-runPlotter plotterMonad = do- statsEnabled <- GHC.Stats.getGCStatsEnabled-- _ <- Gtk.initGUI- _ <- Gtk.timeoutAddFull (CC.yield >> return True) Gtk.priorityDefault 50-- -- start the main window- win <- Gtk.windowNew- _ <- Gtk.set win [ Gtk.containerBorderWidth := 8- , Gtk.windowTitle := "Plot-ho-matic"- ]-- statsLabel <- Gtk.labelNew (Nothing :: Maybe String)- let statsWorker = do- CC.threadDelay 500000- msg <- if statsEnabled- then do- stats <- GHC.Stats.getGCStats- return $ printf "The current memory usage is %.2f MB"- ((realToFrac (GHC.Stats.currentBytesUsed stats) :: Double) /(1024*1024))- else return "(enable GHC statistics with +RTS -T)"- Gtk.postGUISync $ Gtk.labelSetText statsLabel ("Welcome to Plot-ho-matic!\n" ++ msg)- statsWorker-- statsThread <- CC.forkIO statsWorker- -- on close, kill all the windows and threads- graphWindowsToBeKilled <- CC.newMVar []-- channels <- execPlotter plotterMonad- let windows = map csMkChanEntry channels-- chanWidgets <- mapM (\x -> x graphWindowsToBeKilled) windows---- let killEverything :: IO ()- killEverything = do- CC.killThread statsThread- gws <- CC.readMVar graphWindowsToBeKilled- mapM_ Gtk.widgetDestroy gws- mapM_ csKillThreads channels- Gtk.mainQuit- _ <- on win Gtk.deleteEvent $ liftIO (killEverything >> return False)-- --------------- main widget ------------------ -- button to clear history- buttonDoNothing <- Gtk.buttonNewWithLabel "this button does absolutely nothing"- _ <- on buttonDoNothing Gtk.buttonActivated $- putStrLn "seriously, it does nothing"-- -- box to hold list of channels- channelBox <- Gtk.vBoxNew False 4- Gtk.set channelBox $- concatMap (\x -> [ Gtk.containerChild := x- , Gtk.boxChildPacking x := Gtk.PackNatural- ]) chanWidgets-- -- scroll to hold channel box- scroll <- Gtk.scrolledWindowNew Nothing Nothing- Gtk.scrolledWindowAddWithViewport scroll channelBox- Gtk.set scroll [ Gtk.scrolledWindowHscrollbarPolicy := Gtk.PolicyNever- , Gtk.scrolledWindowVscrollbarPolicy := Gtk.PolicyAutomatic- ]-- -- vbox to hold everything- vbox <- Gtk.vBoxNew False 4- Gtk.set vbox $- [ Gtk.containerChild := statsLabel- , Gtk.boxChildPacking statsLabel := Gtk.PackNatural- , Gtk.containerChild := buttonDoNothing- , Gtk.boxChildPacking buttonDoNothing := Gtk.PackNatural- , Gtk.containerChild := scroll- ]-- -- add widget to window and show- _ <- Gtk.set win [ Gtk.containerChild := vbox ]- Gtk.widgetShowAll win- Gtk.mainGUI----- the list of channels-newChannelWidget :: Channel a- -> CC.MVar [Gtk.Window] -> IO Gtk.VBox-newChannelWidget channel graphWindowsToBeKilled = do- vbox <- Gtk.vBoxNew False 4-- nameBox' <- Gtk.hBoxNew False 4- nameBox <- labeledWidget (chanName channel) nameBox'-- buttonsBox <- Gtk.hBoxNew False 4-- -- 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 ()- let triggerYo action = on buttonAlsoDoNothing Gtk.buttonActivated action >> return ()-- -- button to make a new graph- buttonNew <- Gtk.buttonNewWithLabel "new graph"- _ <- on buttonNew Gtk.buttonActivated $ do- graphWin <- newGraph- triggerYo- (chanName channel)- (chanSameSignalTree channel)- (chanToSignalTree channel)- (chanMsgStore channel)-- -- add this window to the list to be killed on exit- CC.modifyMVar_ graphWindowsToBeKilled (return . (graphWin:))--- -- entry to set history length- entryAndLabel <- Gtk.hBoxNew False 4- entryLabel <- Gtk.vBoxNew False 4 >>= labeledWidget "max history:"- entryEntry <- Gtk.entryNew- Gtk.set entryEntry [ Gtk.entryEditable := True- , Gtk.widgetSensitive := True- ]- Gtk.entrySetText entryEntry "200"- let updateMaxHistory = do- txt <- Gtk.get entryEntry Gtk.entryText- let reset = Gtk.entrySetText entryEntry "(max)"- case readMaybe txt :: Maybe Int of- Nothing ->- putStrLn ("max history: couldn't make an Int out of \"" ++ show txt ++ "\"") >> reset- Just 0 -> putStrLn ("max history: must be greater than 0") >> reset- Just k -> IORef.writeIORef (chanMaxHistory channel) k-- _ <- on entryEntry Gtk.entryActivate updateMaxHistory- updateMaxHistory--- Gtk.set entryAndLabel [ Gtk.containerChild := entryLabel- , Gtk.boxChildPacking entryLabel := Gtk.PackNatural- , Gtk.containerChild := entryEntry- , Gtk.boxChildPacking entryEntry := Gtk.PackNatural- ]--- -- put all the buttons/entries together- Gtk.set buttonsBox [ Gtk.containerChild := buttonNew- , Gtk.boxChildPacking buttonNew := Gtk.PackNatural- , Gtk.containerChild := buttonAlsoDoNothing- , Gtk.boxChildPacking buttonAlsoDoNothing := Gtk.PackNatural- , Gtk.containerChild := entryAndLabel- , Gtk.boxChildPacking entryAndLabel := Gtk.PackNatural- ]-- Gtk.set vbox [ Gtk.containerChild := nameBox- , Gtk.boxChildPacking nameBox := Gtk.PackNatural- , Gtk.containerChild := buttonsBox- , Gtk.boxChildPacking buttonsBox := Gtk.PackNatural- ]-- return vbox+import Accessors ( Lookup ) +import PlotHo.Channels ( Meta, XAxisType(..), addHistoryChannel, addHistoryChannel', addChannel )+import PlotHo.Plotter ( Plotter, runPlotter ) ----- -- save all channel data when this button is pressed----- _ <- on renderer3 Gtk.cellToggled $ \pathStr -> do----- let (i:_) = Gtk.stringToTreePath pathStr----- lv <- Gtk.listStoreGetValue model i----- let writerThread = do----- bct <- chanGetByteStrings (lvChan lv)----- let filename = chanName (lvChan lv) ++ "_log.dat"----- blah _ sizes [] = return (reverse sizes)----- blah handle sizes ((x,_,_):xs) = do----- BSL.hPut handle x----- blah handle (BSL.length x : sizes) xs----- putStrLn $ "trying to write file \"" ++ filename ++ "\"..."----- sizes <- withFile filename WriteMode $ \handle -> blah handle [] bct----- putStrLn $ "finished writing file, wrote " ++ show (length sizes) ++ " protos"---------- putStrLn "writing file with sizes..."----- writeFile (filename ++ ".sizes") (unlines $ map show sizes)----- putStrLn "done"----- _ <- CC.forkIO writerThread--- return ()+-- $simple ----- return treeview+-- The easiest way to use this library is to use 'GHC.Generics.Generic' to derive an instance of 'Accessors.Lookup' for your data type, and then use 'addHistoryChannel' to create a time series.+-- You need to pass 'addHistoryChannel' an action which periodically sends a new message.+--+-- For example:+--+-- > {-# LANGUAGE DeriveGeneric #-}+-- >+-- > import GHC.Generics ( Generic )+-- > import Accessors ( Lookup )+-- > import PlotHo+-- >+-- > data Foo =+-- > = Foo+-- > { value1 :: Double+-- > , value2 :: Double+-- > } deriving Generic+-- > instance Lookup Foo+-- >+-- > messageSender :: (Foo -> True -> IO ()) -> IO ()+-- > messageSender newMessage = forever $ do+-- > CC.threadDelay 100000+-- > foo <- receiveFooFromNetworkOrSomething :: IO Foo+-- > let reset = False -- never reset in this example+-- > newMessage foo reset+-- >+-- > main :: IO ()+-- > main = runPlotter $+-- > addHistoryChannel "it's foo" XAxisCount messageSender+--+-- When the plotter executes, @messageSender@ will be forked and will+-- forever listen for new messages. Every time it receives a new message+-- it will call the @newMessage@ action which instructs the plotter to+-- add a data point and redraw. --- helper to make an hbox with a label-labeledWidget :: Gtk.WidgetClass a => String -> a -> IO Gtk.HBox-labeledWidget name widget = do- label <- Gtk.labelNew (Just name)- hbox <- Gtk.hBoxNew False 4- Gtk.set hbox [ Gtk.containerChild := label- , Gtk.containerChild := widget- , Gtk.boxChildPacking label := Gtk.PackNatural--- , Gtk.boxChildPacking widget := Gtk.PackNatural- ]- return hbox+-- $dynamic+--+-- (Placeholder)
+ src/PlotHo/Channels.hs view
@@ -0,0 +1,417 @@+{-# OPTIONS_GHC -Wall #-}+{-# Language ScopedTypeVariables #-}+{-# Language DeriveFunctor #-}+{-# LANGUAGE PackageImports #-}++module PlotHo.Channels+ ( XAxisType(..)+ , addHistoryChannel+ , Meta+ , addHistoryChannel'+ , addChannel+ ) where++import Control.Lens ( (^.) )+import Control.Monad ( void, when )+import Control.Monad.IO.Class ( MonadIO(..) )+import qualified Control.Concurrent as CC+import qualified Data.Foldable as F+import qualified Data.IORef as IORef+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 "gtk3" Graphics.UI.Gtk ( AttrOp( (:=) ) )+import qualified "gtk3" Graphics.UI.Gtk as Gtk+import Text.Read ( readMaybe )+import System.Glib.Signals ( on )+--import System.IO ( withFile, IOMode ( WriteMode ) )+--import qualified Data.ByteString.Lazy as BSL+import qualified Data.Sequence as S++import Accessors++import PlotHo.GraphWidget ( newGraph )+import PlotHo.Plotter ( Plotter, ChannelStuff(..), tell )+import PlotHo.PlotTypes ( Channel(..), PlotterOptions(..) )++-- hardcode options for now+plotterOptions :: PlotterOptions+plotterOptions =+ PlotterOptions+ { maxDrawRate = 40+ }++-- | Simplified time-series channel which passes a "send message" function to a worker and forks it using 'Control.Concurrent.forkIO'.+-- The plotter will plot a time series of messages sent by the worker.+-- 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, or use the 'addHistoryChannel' function.+addHistoryChannel ::+ Lookup a+ => String -- ^ channel name+ -> XAxisType -- ^ what to use for the X axis+ -> ((a -> Bool -> IO ()) -> IO ()) -- ^ worker which is passed a "new message" function, this will be forked with 'Control.Concurrent.forkIO'+ -> Plotter ()+addHistoryChannel name xaxisType action = do+ (chan, newMessage) <- liftIO $ newHistoryChannel name xaxisType+ workerTid <- liftIO $ CC.forkIO (action newMessage)+ tell ChannelStuff { csKillThreads = CC.killThread workerTid+ , 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'.+-- Using types or data, you must encode the signal tree with the message so that+-- the plotter can build you the nice message toggle tree.+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], Either String (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+ (chan, newMessage) <- liftIO $ newChannel name sameSignalTree toSignalTree+ workerTid <- liftIO $ CC.forkIO (action newMessage)+ tell ChannelStuff { csKillThreads = CC.killThread workerTid+ , csMkChanEntry = newChannelWidget chan+ }+++newChannel ::+ forall a+ . String+ -> (a -> a -> Bool)+ -> (a -> [Tree ([String], Either String (a -> [[(Double, Double)]]))])+ -> IO (Channel a, a -> IO ())+newChannel name sameSignalTree toSignalTree = do+ msgStore <- Gtk.listStoreNew []+ maxHist <- IORef.newIORef 0++ let newMessage :: a -> IO ()+ newMessage next = do+ -- grab the time and counter+ Gtk.postGUIAsync $ do+ size <- Gtk.listStoreGetSize msgStore+ if size == 0+ then Gtk.listStorePrepend msgStore next+ else Gtk.listStoreSetValue msgStore 0 next++ let retChan = Channel { chanName = name+ , chanMsgStore = msgStore+ , chanSameSignalTree = sameSignalTree+ , chanToSignalTree = toSignalTree+ , chanMaxHistory = maxHist+ }++ return (retChan, newMessage)+++data History a = History (S.Seq (a, Int, NominalDiffTime))+type HistorySignalTree a = Tree.Forest ([String], Either String (History a -> [[(Double, Double)]]))++data XAxisType =+ XAxisTime -- ^ time since the first message+ | XAxisTime0 -- ^ time since the first message, normalized to 0 (to reduce plot jitter)+ | XAxisCount -- ^ message index+ | XAxisCount0 -- ^ message index, normalized to 0 (to reduce plot jitter)++historySignalTree :: forall a . Lookup a => XAxisType -> HistorySignalTree a+historySignalTree axisType = case accessors of+ Left _ -> error "historySignalTree: got a Field right away"+ acc -> Tree.subForest $ head $ makeSignalTree' [] acc+ where+ makeSignalTree' :: [String] -> AccessorTree a -> HistorySignalTree a+ makeSignalTree' myFieldName (Right (GAData _ (GAConstructor cname children))) =+ [Tree.Node+ (reverse myFieldName, Left cname)+ (concatMap (\(getterName, child) -> makeSignalTree' (fromMName getterName:myFieldName) child) children)+ ]+ makeSignalTree' myFieldName (Right (GAData _ (GASum enum))) =+ [Tree.Node (reverse myFieldName, Right (toHistoryGetter (fromIntegral . eToIndex enum))) []]+ makeSignalTree' myFieldName (Left field) =+ [Tree.Node (reverse myFieldName, Right (toHistoryGetter (toDoubleGetter field))) []]+ fromMName (Just x) = x+ fromMName Nothing = "()"++ toDoubleGetter :: GAField a -> (a -> Double)+ toDoubleGetter (FieldDouble f) = (^. f)+ toDoubleGetter (FieldFloat f) = realToFrac . (^. f)+ toDoubleGetter (FieldInt f) = fromIntegral . (^. f)+ toDoubleGetter (FieldString _) = const 0+ toDoubleGetter FieldSorry = const 0++ toHistoryGetter :: (a -> Double) -> History a -> [[(Double, Double)]]+ toHistoryGetter = case axisType of+ XAxisTime -> timeGetter+ XAxisTime0 -> timeGetter0+ XAxisCount -> countGetter+ XAxisCount0 -> countGetter0++ timeGetter get (History s) = [map (\(val, _, time) -> (realToFrac time, get val)) (F.toList s)]+ timeGetter0 get (History s) = [map (\(val, _, time) -> (realToFrac time - time0, get val)) (F.toList s)]+ where+ time0 :: Double+ time0 = case S.viewl s of+ (_, _, time0') S.:< _ -> realToFrac time0'+ S.EmptyL -> 0+ countGetter get (History s) = [map (\(val, k, _) -> (fromIntegral k, get val)) (F.toList s)]+ countGetter0 get (History s) = [map (\(val, k, _) -> (fromIntegral k - k0, get val)) (F.toList s)]+ where+ k0 :: Double+ k0 = case S.viewl s of+ (_, k0', _) S.:< _ -> realToFrac k0'+ S.EmptyL -> 0++-- | History channel which automatically generates the signal tree for you+-- based on the Lookup instance. You have to recompile the plotter if+-- the types change.+-- This is the internal part which should be wrapped by 'addHistoryChannel'.+newHistoryChannel ::+ forall a+ . Lookup a+ => String+ -> XAxisType+ -> IO (Channel (History a), a -> Bool -> IO ())+newHistoryChannel name xaxisType = do+ time0 <- getCurrentTime >>= IORef.newIORef+ counter <- IORef.newIORef 0+ maxHist <- IORef.newIORef 500++ msgStore <- Gtk.listStoreNew []++ let newMessage :: a -> Bool -> IO ()+ newMessage next reset = do+ -- grab the time and counter+ time <- getCurrentTime+ when reset $ do+ IORef.writeIORef time0 time+ IORef.writeIORef counter 0++ k <- IORef.readIORef counter+ time0' <- IORef.readIORef time0++ IORef.writeIORef counter (k+1)+ Gtk.postGUIAsync $ do+ let val = (next, k, diffUTCTime time time0')+ size <- Gtk.listStoreGetSize msgStore+ if size == 0+ then Gtk.listStorePrepend msgStore (History (S.singleton val))+ else do History vals0 <- 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 dropped)++ when reset $ Gtk.listStoreSetValue msgStore 0 (History (S.singleton val))++ let tst :: History a -> [Tree ( [String]+ , Either String (History a -> [[(Double, Double)]])+ )]+ tst = const (historySignalTree xaxisType)++ let retChan = Channel { chanName = name+ , chanMsgStore = msgStore+ , chanSameSignalTree = \_ _ -> True+ , chanToSignalTree = tst+ , chanMaxHistory = maxHist+ }++ return (retChan, newMessage)++type Meta = [Tree ([String], Either String 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 500++ 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 $ unlines+ [ "error: History channel has size 0 message store but no reset."+ , "This means that the first message the plotter saw didn't contain the meta-data."+ , "This was probably caused by starting the plotter AFTER sending the first telemetry message."+ ]+ 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]+ , Either String (History' -> [[(Double, Double)]])+ )]+ toSignalTree (History' _ _ meta) = map (fmap f) meta+ where+ f :: ([String], Either String Int)+ -> ([String], Either String (History' -> [[(Double, Double)]]))+ f (n0, Left n1) = (n0, Left n1)+ f (n0, Right k) = (n0, Right 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+ }++ return (retChan, newMessage)++-- the list of channels+newChannelWidget :: Channel a -> CC.MVar [Gtk.Window] -> IO Gtk.VBox+newChannelWidget channel graphWindowsToBeKilled = do+ vbox <- Gtk.vBoxNew False 4++ nameBox' <- Gtk.hBoxNew False 4+ nameBox <- labeledWidget (chanName channel) nameBox'++ buttonsBox <- Gtk.hBoxNew False 4++ -- button to clear history+ buttonAlsoDoNothing <- Gtk.buttonNewWithLabel "also do nothing"+-- void $ Gtk.onClicked buttonAlsoDoNothing $ do+-- putStrLn "i promise, nothing happens"+-- -- CC.modifyMVar_ logData (const (return S.empty))+-- return ()+ let triggerYo action = on buttonAlsoDoNothing Gtk.buttonActivated action >> return ()++ -- button to make a new graph+ buttonNew <- Gtk.buttonNewWithLabel "new graph"+ void $ on buttonNew Gtk.buttonActivated $ do+ graphWin <-+ newGraph plotterOptions triggerYo (chanName channel)+ (chanSameSignalTree channel)+ (chanToSignalTree channel)+ (chanMsgStore channel)++ -- add this window to the list to be killed on exit+ CC.modifyMVar_ graphWindowsToBeKilled (return . (graphWin:))+++ -- entry to set history length+ maxHistoryEntryAndLabel <- Gtk.hBoxNew False 4+ maxHistoryLabel <- Gtk.vBoxNew False 4 >>= labeledWidget "max history:"+ maxHistoryEntry <- Gtk.entryNew+ Gtk.set maxHistoryEntry+ [ Gtk.entryEditable := True+ , Gtk.widgetSensitive := True+ ]+ Gtk.entrySetText maxHistoryEntry "500"+ let updateMaxHistory = do+ txt <- Gtk.get maxHistoryEntry Gtk.entryText+ let reset = Gtk.entrySetText maxHistoryEntry "(max)"+ case readMaybe txt :: Maybe Int of+ Nothing ->+ putStrLn ("max history: couldn't make an Int out of \"" ++ show txt ++ "\"") >> reset+ Just 0 -> putStrLn ("max history: must be greater than 0") >> reset+ Just k -> IORef.writeIORef (chanMaxHistory channel) k++ void $ on maxHistoryEntry Gtk.entryActivate updateMaxHistory+ updateMaxHistory+++ Gtk.set maxHistoryEntryAndLabel+ [ Gtk.containerChild := maxHistoryLabel+ , Gtk.boxChildPacking maxHistoryLabel := Gtk.PackNatural+ , Gtk.containerChild := maxHistoryEntry+ , Gtk.boxChildPacking maxHistoryEntry := Gtk.PackNatural+ ]+++ -- put all the buttons/entries together+ Gtk.set buttonsBox+ [ Gtk.containerChild := buttonNew+ , Gtk.boxChildPacking buttonNew := Gtk.PackNatural+ , Gtk.containerChild := buttonAlsoDoNothing+ , Gtk.boxChildPacking buttonAlsoDoNothing := Gtk.PackNatural+ , Gtk.containerChild := maxHistoryEntryAndLabel+ , Gtk.boxChildPacking maxHistoryEntryAndLabel := Gtk.PackNatural+ ]++ Gtk.set vbox+ [ Gtk.containerChild := nameBox+ , Gtk.boxChildPacking nameBox := Gtk.PackNatural+ , Gtk.containerChild := buttonsBox+ , Gtk.boxChildPacking buttonsBox := Gtk.PackNatural+ ]++ return vbox+++---- -- save all channel data when this button is pressed+---- void $ on renderer3 Gtk.cellToggled $ \pathStr -> do+---- let (i:_) = Gtk.stringToTreePath pathStr+---- lv <- Gtk.listStoreGetValue model i+---- let writerThread = do+---- bct <- chanGetByteStrings (lvChan lv)+---- let filename = chanName (lvChan lv) ++ "_log.dat"+---- blah _ sizes [] = return (reverse sizes)+---- blah handle sizes ((x,_,_):xs) = do+---- BSL.hPut handle x+---- blah handle (BSL.length x : sizes) xs+---- putStrLn $ "trying to write file \"" ++ filename ++ "\"..."+---- sizes <- withFile filename WriteMode $ \handle -> blah handle [] bct+---- putStrLn $ "finished writing file, wrote " ++ show (length sizes) ++ " protos"+----+---- putStrLn "writing file with sizes..."+---- writeFile (filename ++ ".sizes") (unlines $ map show sizes)+---- putStrLn "done"+---- void $ CC.forkIO writerThread+-- return ()+--+-- return treeview+++-- helper to make an hbox with a label+labeledWidget :: Gtk.WidgetClass a => String -> a -> IO Gtk.HBox+labeledWidget name widget = do+ label <- Gtk.labelNew (Just name)+ hbox <- Gtk.hBoxNew False 4+ Gtk.set hbox [ Gtk.containerChild := label+ , Gtk.containerChild := widget+ , Gtk.boxChildPacking label := Gtk.PackNatural+-- , Gtk.boxChildPacking widget := Gtk.PackNatural+ ]+ return hbox
+ src/PlotHo/ChartRender.hs view
@@ -0,0 +1,61 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE ScopedTypeVariables #-}++module PlotHo.ChartRender+ ( AxisScaling(..)+ , toChartRender+ ) where++import Control.Lens ( (.~) )+import Control.Monad ( void )+import Data.Default.Class ( def )+import qualified Graphics.Rendering.Chart as Chart+import Graphics.Rendering.Chart.Backend.Cairo ( runBackend, defaultEnv )+import qualified Graphics.Rendering.Cairo as Cairo++import PlotHo.PlotTypes ( AxisScaling(..) )++-- take the data and use Chart to make a Renderable ()+toChartRender :: forall a+ . (Chart.PlotValue a, Show a, RealFloat a)+ => (AxisScaling, AxisScaling) -> (Maybe (a,a), Maybe (a,a))+ -> Maybe String+ -> [(String, [[(a,a)]])]+ -> Chart.RectSize+ -> Cairo.Render ()+toChartRender (xScaling, yScaling) (xRange, yRange) mtitle namePcs rectSize =+ void $ runBackend (defaultEnv Chart.bitmapAlignmentFns) (Chart.render renderable rectSize)+ where+ renderable :: Chart.Renderable ()+ renderable = Chart.toRenderable layout++ drawOne (name,pc) col+ = Chart.plot_lines_values .~ pc+ $ Chart.plot_lines_style . Chart.line_color .~ col+-- $ 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+ LogScaling -> Chart.layout_x_axis . Chart.laxis_generate .~ Chart.autoScaledLogAxis def+ LinearScaling -> case xRange of+ Nothing -> id+ Just range -> Chart.layout_x_axis . Chart.laxis_generate .~ Chart.scaledAxis def range++ yscaleFun = case yScaling of+ LogScaling -> Chart.layout_y_axis . Chart.laxis_generate .~ Chart.autoScaledLogAxis def+ LinearScaling -> case yRange of+ 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+ $ title+ $ Chart.layout_x_axis . Chart.laxis_title .~ "time [s]"+ $ xscaleFun+ $ yscaleFun+ def
src/PlotHo/GraphWidget.hs view
@@ -6,15 +6,18 @@ ( newGraph ) where +import Control.Concurrent ( MVar ) import qualified Control.Concurrent as CC-import Control.Monad ( void, when, unless )-import Control.Monad.IO.Class ( liftIO )+import Control.Monad ( forever, unless, void, when )+import Control.Monad.IO.Class ( MonadIO, liftIO ) import Data.Either ( isRight ) import qualified Data.IORef as IORef import Data.List ( intercalate ) import qualified Data.Map as M import Data.Maybe ( isNothing, fromJust )+import Data.Time.Clock ( getCurrentTime, diffUTCTime ) import qualified Data.Tree as Tree+import qualified Graphics.Rendering.Cairo as Cairo import "gtk3" Graphics.UI.Gtk ( AttrOp( (:=) ) ) import qualified "gtk3" Graphics.UI.Gtk as Gtk import System.Glib.Signals ( on )@@ -22,23 +25,29 @@ import qualified Data.Text as T import qualified Graphics.Rendering.Chart as Chart -import PlotHo.PlotChart ( AxisScaling(..), displayChart, chartGtkUpdateCanvas )-import PlotHo.PlotTypes ( GraphInfo(..), ListViewInfo(..), MarkedState(..) )+import PlotHo.ChartRender ( AxisScaling(..), toChartRender )+import PlotHo.PlotTypes ( GraphInfo(..), ListViewInfo(..), MarkedState(..), PlotterOptions(..) ) +debug :: MonadIO m => String -> m ()+--debug = liftIO . putStrLn+debug = const (return ())+ -- make a new graph window newGraph :: forall a- . (IO () -> IO ())+ . PlotterOptions+ -> (IO () -> IO ()) -> String -> (a -> a -> Bool) -> (a -> [Tree.Tree ([String], Either String (a -> [[(Double, Double)]]))]) -> Gtk.ListStore a -> IO Gtk.Window-newGraph onButton channame sameSignalTree forestFromMeta msgStore = do+newGraph options onButton channame sameSignalTree forestFromMeta msgStore = do win <- Gtk.windowNew - _ <- Gtk.set win [ Gtk.containerBorderWidth := 8- , Gtk.windowTitle := channame- ]+ void $ Gtk.set win+ [ Gtk.containerBorderWidth := 8+ , Gtk.windowTitle := channame+ ] -- mvar with all the user input graphInfoMVar <- CC.newMVar GraphInfo { giXScaling = LinearScaling@@ -49,51 +58,137 @@ , giTitle = Nothing } :: IO (CC.MVar (GraphInfo a)) - let makeRenderable :: IO (Chart.Renderable ())- makeRenderable = do+ let -- turn latest signals into a Chart render+ prepareRenderFromLatestData :: IO (Chart.RectSize -> Cairo.Render ())+ prepareRenderFromLatestData = do+ -- get the latest signals gi <- CC.readMVar graphInfoMVar size <- Gtk.listStoreGetSize msgStore+ namePcs <-+ if size == 0+ then return []+ else do datalog <- Gtk.listStoreGetValue msgStore 0+ return $ map (fmap (\g -> g datalog)) (giGetters gi)+ :: IO [(String, [[(Double,Double)]])]+ return $+ toChartRender+ (giXScaling gi, giYScaling gi)+ (giXRange gi, giYRange gi)+ (giTitle gi)+ namePcs - namePcs <- if size == 0- then return []- else do- datalog <- Gtk.listStoreGetValue msgStore 0- 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) (giTitle gi) namePcs - -- chart drawing area+ -- new chart drawing area chartCanvas <- Gtk.drawingAreaNew- _ <- Gtk.widgetSetSizeRequest chartCanvas 250 250+ void $ Gtk.widgetSetSizeRequest chartCanvas 250 250 - latestRenderableMVar <- CC.newEmptyMVar+ -- some mvars for syncronizing rendering with drawing+ needRedrawMVar <- CC.newMVar False+ latestOneToRenderMVar <-+ CC.newEmptyMVar :: IO (MVar (Chart.RectSize -> Cairo.Render (), (Int, Int)))+ latestSurfaceMVar <-+ CC.newMVar Nothing :: IO (MVar (Maybe (Cairo.Surface, (Int, Int)))) let redraw :: IO () redraw = do- renderable <- makeRenderable- maybeLatestRenderable <- CC.tryTakeMVar latestRenderableMVar- case maybeLatestRenderable of- -- the other action is still waiting- Just _ -> CC.putMVar latestRenderableMVar renderable- -- there is no action waiting, post the action- Nothing -> do CC.putMVar latestRenderableMVar renderable- void $ flip Gtk.idleAdd Gtk.priorityDefaultIdle $ do- -- this might not be the same one if the messages have accumulated- latestRenderable <- CC.takeMVar latestRenderableMVar- chartGtkUpdateCanvas latestRenderable chartCanvas- return False -- we're done now, don't call this again+ debug "redraw called"+ void $ CC.swapMVar needRedrawMVar True+ Gtk.widgetQueueDraw chartCanvas - _ <- on chartCanvas Gtk.exposeEvent $ liftIO (redraw >> return True)+ renderWorker :: IO ()+ renderWorker = do+ debug "renderWorker: waiting for new render"+ -- block until we have to render something+ (render, (width, height)) <- CC.takeMVar latestOneToRenderMVar+ renderStartTime <- getCurrentTime+ debug "renderWorker: starting render" + -- create an image to draw on+ surface <- liftIO $ Cairo.createImageSurface Cairo.FormatARGB32 width height + -- do the drawing+ Cairo.renderWith surface (render (realToFrac width, realToFrac height))++ -- put our new drawing in the latest surface variable+ debug "renderWorker: putting finished surface"+ void $ CC.swapMVar latestSurfaceMVar (Just (surface, (width, height)))++ -- queue another draw+ debug "renderWorker: queing draw"+ Gtk.postGUIAsync (Gtk.widgetQueueDraw chartCanvas)++ -- At this point the render worker will immediately start the next render if needed.+ -- This could cause us to draw at an unneccesarily high rate which would could+ -- overload the system. So we only draw at maximum rate given by 'maxDrawRate'.+ -- If we are already slower than 'maxDrawRate' we don't sleep,+ -- we just update as quickly as possible.+ renderFinishTime <- getCurrentTime+ let renderTime :: Double+ renderTime = realToFrac $ diffUTCTime renderFinishTime renderStartTime++ sleepTime = 1 / maxDrawRate options - renderTime+ when (sleepTime < 0) $+ CC.threadDelay (round (1e6 * sleepTime))++ -- fork that bad boy+ void $ CC.forkIO (forever renderWorker)++ let handleDraw :: Cairo.Render ()+ handleDraw = do+ debug "handleDraw: called"++ -- get the size of the surface we have to draw+ Gtk.Rectangle _ _ width height <- liftIO $ Gtk.widgetGetAllocation chartCanvas++ -- handleDraw always immediately takes the last drawn surface and draws it+ -- this is just a copy and very efficient+ maybeLatestSurface <- liftIO $ CC.readMVar latestSurfaceMVar+ needFirstDrawOrResizeDraw <- case maybeLatestSurface of+ Just (latestSurface, (lastWidth, lastHeight)) -> do+ debug "handleDraw: painting latest surface"+ Cairo.setSourceSurface latestSurface 0 0+ Cairo.paint+ return ((lastWidth, lastHeight) /= (width, height))+ Nothing -> do+ debug "handleDraw: no surface yet"+ return True++ -- then we determine if we actually need to re-generate a new surface+ needRedraw <- liftIO $ CC.swapMVar needRedrawMVar False+ when (needRedraw || needFirstDrawOrResizeDraw) $ liftIO $ do+ -- if we need to redraw for whatever reason+ case (needRedraw, needFirstDrawOrResizeDraw) of+ (True, True) -> debug $ "handleDraw: putting a redraw in because " +++ "needRedraw && needFirstDrawOrResizeDraw"+ (True, False) -> debug $ "handleDraw: putting a redraw in because " +++ "needRedraw"+ (False, True) -> debug $ "handleDraw: putting a redraw in because " +++ "needFirstDrawOrResizeDraw"+ _ -> return () -- (impossible)++ -- get the latest data to draw based on use messages and GUI signal selections+ render <- prepareRenderFromLatestData++ -- Empty the mvar if it is full.+ -- If we are getting lots of messages quickly this+ -- will descard any undrawn requests.+ void $ CC.tryTakeMVar latestOneToRenderMVar++ -- Put the latest request in the draw thread's queue+ -- The MVar is now definitely empty so we will never block+ -- by putting something in it.+ CC.putMVar latestOneToRenderMVar (render, (width, height))++ -- connect the draw signal to our draw handler+ void $ on chartCanvas Gtk.draw handleDraw+ -- the options widget optionsWidget <- makeOptionsWidget graphInfoMVar redraw- options <- Gtk.expanderNew "options"- Gtk.set options [ Gtk.containerChild := optionsWidget- , Gtk.expanderExpanded := False- ]- _ <- Gtk.afterActivate options redraw+ optionsExpander <- Gtk.expanderNew "options"+ Gtk.set optionsExpander+ [ Gtk.containerChild := optionsWidget+ , Gtk.expanderExpanded := False+ ] -- the signal selector treeview' <- newSignalSelectorArea onButton sameSignalTree forestFromMeta graphInfoMVar msgStore redraw@@ -101,13 +196,12 @@ Gtk.set treeview [ Gtk.containerChild := treeview' , Gtk.expanderExpanded := True ]- _ <- Gtk.afterActivate treeview redraw -- options and signal selector packed in vbox vboxOptionsAndSignals <- Gtk.vBoxNew False 4 Gtk.set vboxOptionsAndSignals- [ Gtk.containerChild := options- , Gtk.boxChildPacking options := Gtk.PackNatural+ [ Gtk.containerChild := optionsExpander+ , Gtk.boxChildPacking optionsExpander := Gtk.PackNatural , Gtk.containerChild := treeview , Gtk.boxChildPacking treeview := Gtk.PackGrow ]@@ -119,7 +213,8 @@ , Gtk.boxChildPacking vboxOptionsAndSignals := Gtk.PackNatural , Gtk.containerChild := chartCanvas ]- _ <- Gtk.set win [ Gtk.containerChild := hboxEverything ]+ void $ Gtk.set win+ [ Gtk.containerChild := hboxEverything ] Gtk.widgetShowAll win return win@@ -208,8 +303,8 @@ , Gtk.cellToggleInconsistent := True ] - _ <- Gtk.treeViewAppendColumn treeview col1- _ <- Gtk.treeViewAppendColumn treeview col2+ void $ Gtk.treeViewAppendColumn treeview col1+ void $ Gtk.treeViewAppendColumn treeview col2 let -- update the graph information@@ -232,9 +327,8 @@ newTitle :: Maybe String (newGetters, newTitle) = gettersAndTitle newGetters0 - _ <- CC.modifyMVar_ graphInfoMVar $- \gi0 -> return $ gi0 {giGetters = newGetters, giTitle = newTitle}- return ()+ void $ CC.modifyMVar_ graphInfoMVar $+ \gi0 -> return $ gi0 {giGetters = newGetters, giTitle = newTitle} i2p i = Gtk.treeModelGetPath treeStore i p2i p = do@@ -361,24 +455,28 @@ IORef.writeIORef oldMetaRef (Just newMeta) rebuildSignalTree (forestFromMeta newMeta) - -- on insert or change, rebuild the signal tree+ -- on new message (insert or change), rebuild the signal tree and redraw _ <- on msgStore Gtk.rowChanged $ \_ changedPath -> do newMsg <- Gtk.listStoreGetValue msgStore (Gtk.listStoreIterToIndex changedPath)- maybeRebuildSignalTree newMsg >> redraw+ maybeRebuildSignalTree newMsg+ redraw _ <- on msgStore Gtk.rowInserted $ \_ changedPath -> do newMsg <- Gtk.listStoreGetValue msgStore (Gtk.listStoreIterToIndex changedPath)- maybeRebuildSignalTree newMsg >> redraw+ maybeRebuildSignalTree newMsg+ redraw -- rebuild the signal tree right now if it exists size <- Gtk.listStoreGetSize msgStore when (size > 0) $ do newMsg <- Gtk.listStoreGetValue msgStore 0- maybeRebuildSignalTree newMsg >> redraw+ maybeRebuildSignalTree newMsg+ redraw -- for debugging onButton $ do newMsg <- Gtk.listStoreGetValue msgStore 0- rebuildSignalTree (forestFromMeta newMsg) >> redraw+ rebuildSignalTree (forestFromMeta newMsg)+ redraw scroll <- Gtk.scrolledWindowNew Nothing Nothing@@ -499,21 +597,22 @@ redraw updateXScaling updateYScaling- _ <- on xScalingSelector Gtk.changed updateXScaling- _ <- on yScalingSelector Gtk.changed updateYScaling+ void $ on xScalingSelector Gtk.changed updateXScaling+ void $ on yScalingSelector Gtk.changed updateYScaling -- vbox to hold the little window on the left vbox <- Gtk.vBoxNew False 4 - Gtk.set vbox [ Gtk.containerChild := xScalingBox- , Gtk.boxChildPacking xScalingBox := Gtk.PackNatural- , Gtk.containerChild := xRangeBox- , Gtk.boxChildPacking xRangeBox := Gtk.PackNatural- , Gtk.containerChild := yScalingBox- , Gtk.boxChildPacking yScalingBox := Gtk.PackNatural- , Gtk.containerChild := yRangeBox- , Gtk.boxChildPacking yRangeBox := Gtk.PackNatural- ]+ Gtk.set vbox+ [ Gtk.containerChild := xScalingBox+ , Gtk.boxChildPacking xScalingBox := Gtk.PackNatural+ , Gtk.containerChild := xRangeBox+ , Gtk.boxChildPacking xRangeBox := Gtk.PackNatural+ , Gtk.containerChild := yScalingBox+ , Gtk.boxChildPacking yScalingBox := Gtk.PackNatural+ , Gtk.containerChild := yRangeBox+ , Gtk.boxChildPacking yRangeBox := Gtk.PackNatural+ ] return vbox
− src/PlotHo/PlotChart.hs
@@ -1,83 +0,0 @@-{-# OPTIONS_GHC -Wall #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE PackageImports #-}--module PlotHo.PlotChart- ( AxisScaling(..)- , displayChart- , chartGtkUpdateCanvas- ) where--import Control.Lens ( (.~) )-import Data.Default.Class ( def )---import qualified Data.Foldable as F---import qualified Data.Sequence as S-import qualified "gtk3" Graphics.UI.Gtk as Gtk-import qualified Graphics.Rendering.Chart as Chart-import Graphics.Rendering.Chart.Backend.Cairo ( runBackend, defaultEnv )-import Graphics.Rendering.Cairo- ( Render, Format(..)- , renderWith, withImageSurface, setSourceSurface, paint- )--import PlotHo.PlotTypes ( AxisScaling(..) )--chartGtkUpdateCanvas :: Chart.Renderable () -> Gtk.DrawingArea -> IO ()-chartGtkUpdateCanvas chart canvas = do- Gtk.threadsEnter- maybeWin <- Gtk.widgetGetWindow canvas- case maybeWin of- Nothing -> Gtk.threadsLeave >> return ()- Just win -> do- Gtk.Rectangle _ _ width height <- Gtk.widgetGetAllocation canvas- Gtk.threadsLeave- let sz = (fromIntegral width,fromIntegral height)- let render0 :: Render (Chart.PickFn ())- render0 = runBackend (defaultEnv Chart.bitmapAlignmentFns) (Chart.render chart sz)-- withImageSurface FormatARGB32 width height $ \surface -> do- _ <- renderWith surface render0- let render1 = setSourceSurface surface 0 0 >> paint- Gtk.threadsEnter- Gtk.drawWindowBeginPaintRect win (Gtk.Rectangle 0 0 width height)- _ <- Gtk.renderWithDrawWindow win render1- Gtk.drawWindowEndPaint win- Gtk.threadsLeave--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- $ Chart.plot_lines_style . Chart.line_color .~ col--- $ 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- LogScaling -> Chart.layout_x_axis . Chart.laxis_generate .~ Chart.autoScaledLogAxis def- LinearScaling -> case xRange of- Nothing -> id- Just range -> Chart.layout_x_axis . Chart.laxis_generate .~ Chart.scaledAxis def range-- yscaleFun = case yScaling of- LogScaling -> Chart.layout_y_axis . Chart.laxis_generate .~ Chart.autoScaledLogAxis def- LinearScaling -> case yRange of- 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- $ title- $ Chart.layout_x_axis . Chart.laxis_title .~ "time [s]"- $ xscaleFun- $ yscaleFun- def
src/PlotHo/PlotTypes.hs view
@@ -4,11 +4,12 @@ {-# Language PackageImports #-} module PlotHo.PlotTypes- ( Channel(..)+ ( AxisScaling(..)+ , Channel(..) , GraphInfo(..) , ListViewInfo(..)- , AxisScaling(..) , MarkedState(..)+ , PlotterOptions(..) ) where import Data.Tree ( Tree )@@ -51,3 +52,9 @@ )] , chanMaxHistory :: IORef Int }++-- | Some options+data PlotterOptions+ = PlotterOptions+ { maxDrawRate :: Double -- ^ limit the draw frequency to this number in Hz+ }
+ src/PlotHo/Plotter.hs view
@@ -0,0 +1,141 @@+{-# OPTIONS_GHC -Wall #-}+{-# Language ScopedTypeVariables #-}+{-# Language DeriveFunctor #-}+{-# Language MultiParamTypeClasses #-}+{-# LANGUAGE PackageImports #-}++module PlotHo.Plotter+ ( Plotter(..)+ , ChannelStuff(..)+ , runPlotter+ , execPlotter+ , tell+ ) where++import qualified GHC.Stats++import Control.Applicative ( liftA2 )+import Control.Monad ( void )+import Control.Monad.IO.Class ( MonadIO(..) )+import qualified Control.Concurrent as CC+import "gtk3" Graphics.UI.Gtk ( AttrOp( (:=) ) )+import qualified "gtk3" Graphics.UI.Gtk as Gtk+import Text.Printf ( printf )+import System.Glib.Signals ( on )++-- | add channels to this, then run it with 'runPlotter'+newtype Plotter a = Plotter { unPlotter :: IO (a, [ChannelStuff]) } deriving Functor++instance Applicative Plotter where+ pure x = Plotter $ pure (x, [])+ f <*> v = Plotter $ liftA2 k (unPlotter f) (unPlotter v)+ where k ~(a, w) ~(b, w') = (a b, w `mappend` w')++instance Monad Plotter where+ return a = Plotter $ return (a, [])+ m >>= k = Plotter $ do+ ~(a, w) <- unPlotter m+ ~(b, w') <- unPlotter (k a)+ return (b, w `mappend` w')+ fail msg = Plotter $ fail msg++instance MonadIO Plotter where+ liftIO m = Plotter $ do+ a <- m+ return (a, mempty)++tell :: ChannelStuff -> Plotter ()+tell w = Plotter (return ((), [w]))++execPlotter :: Plotter a -> IO [ChannelStuff]+execPlotter m = do+ ~(_, w) <- unPlotter m+ return w++data ChannelStuff =+ ChannelStuff+ { csKillThreads :: IO ()+ , csMkChanEntry :: CC.MVar [Gtk.Window] -> IO Gtk.VBox+ }++-- | fire up the the GUI+runPlotter :: Plotter () -> IO ()+runPlotter plotterMonad = do+ statsEnabled <- GHC.Stats.getGCStatsEnabled++ void Gtk.initGUI+ void $ Gtk.timeoutAddFull (CC.yield >> return True) Gtk.priorityDefault 50++ -- start the main window+ win <- Gtk.windowNew+ void $ Gtk.set win+ [ Gtk.containerBorderWidth := 8+ , Gtk.windowTitle := "Plot-ho-matic"+ ]++ statsLabel <- Gtk.labelNew (Nothing :: Maybe String)+ let statsWorker = do+ CC.threadDelay 500000+ msg <- if statsEnabled+ then do+ stats <- GHC.Stats.getGCStats+ return $ printf "The current memory usage is %.2f MB"+ ((realToFrac (GHC.Stats.currentBytesUsed stats) :: Double) /(1024*1024))+ else return "(enable GHC statistics with +RTS -T)"+ Gtk.postGUISync $ Gtk.labelSetText statsLabel ("Welcome to Plot-ho-matic!\n" ++ msg)+ statsWorker++ statsThread <- CC.forkIO statsWorker+ -- on close, kill all the windows and threads+ graphWindowsToBeKilled <- CC.newMVar []++ channels <- execPlotter plotterMonad+ let windows = map csMkChanEntry channels++ chanWidgets <- mapM (\x -> x graphWindowsToBeKilled) windows++ let killEverything :: IO ()+ killEverything = do+ CC.killThread statsThread+ gws <- CC.readMVar graphWindowsToBeKilled+ mapM_ Gtk.widgetDestroy gws+ mapM_ csKillThreads channels+ Gtk.mainQuit+ void $ on win Gtk.deleteEvent $ liftIO (killEverything >> return False)++ --------------- main widget -----------------+ -- button to clear history+ buttonDoNothing <- Gtk.buttonNewWithLabel "this button does absolutely nothing"+ void $ on buttonDoNothing Gtk.buttonActivated $+ putStrLn "seriously, it does nothing"++ -- box to hold list of channels+ channelBox <- Gtk.vBoxNew False 4+ Gtk.set channelBox $+ concatMap (\x -> [ Gtk.containerChild := x+ , Gtk.boxChildPacking x := Gtk.PackNatural+ ]) chanWidgets++ -- scroll to hold channel box+ scroll <- Gtk.scrolledWindowNew Nothing Nothing+ Gtk.scrolledWindowAddWithViewport scroll channelBox+ Gtk.set scroll [ Gtk.scrolledWindowHscrollbarPolicy := Gtk.PolicyNever+ , Gtk.scrolledWindowVscrollbarPolicy := Gtk.PolicyAutomatic+ ]++ -- vbox to hold everything+ vbox <- Gtk.vBoxNew False 4+ Gtk.set vbox $+ [ Gtk.containerChild := statsLabel+ , Gtk.boxChildPacking statsLabel := Gtk.PackNatural+ , Gtk.containerChild := buttonDoNothing+ , Gtk.boxChildPacking buttonDoNothing := Gtk.PackNatural+ , Gtk.containerChild := scroll+ ]++ void $ Gtk.widgetSetSizeRequest vbox 20 200++ -- add widget to window and show+ void $ Gtk.set win [ Gtk.containerChild := vbox ]+ Gtk.widgetShowAll win+ Gtk.mainGUI