diff --git a/.gitignore b/.gitignore new file mode 100644 --- /dev/null +++ b/.gitignore @@ -0,0 +1,1 @@ +dist diff --git a/.travis.yml b/.travis.yml new file mode 100644 --- /dev/null +++ b/.travis.yml @@ -0,0 +1,3 @@ +language: haskell +before_install: + - travis/cabal-apt-install diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +0.1 +--- +* Initial release (moved from rawesome repo) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2013, Greg Horn + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Greg Horn nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Plot-ho-matic.cabal b/Plot-ho-matic.cabal new file mode 100644 --- /dev/null +++ b/Plot-ho-matic.cabal @@ -0,0 +1,46 @@ +name: Plot-ho-matic +version: 0.1.0.0 +synopsis: Real-time line plotter for protobuf-like data +license: BSD3 +license-file: LICENSE +author: Greg Horn +maintainer: gregmainland@gmail.com +copyright: Copyright (c) 2013, Greg Horn +category: Graphics +build-type: Simple +cabal-version: >=1.8 +extra-source-files: + .gitignore + .travis.yml + CHANGELOG.md + README.md +description: { +Plot-ho-matic provides real-time plotting of time-series data with a simple interface. +. +Changelo +} + +library + hs-source-dirs: src +-- Example, + exposed-modules: Plotter + other-modules: Accessors, + GraphWidget, + PlotChart, + PlotTypes, + ReadMaybe + build-depends: base >= 4.5.0 && < 4.7, + protocol-buffers, + template-haskell, + containers, + glib, + gtk, + Chart, + time, + data-accessor, + bytestring, + transformers + + ghc-options: -O2 -Wall + ghc-prof-options: -O2 -Wall -prof -fprof-auto -fprof-cafs -rtsopts + other-extensions: TemplateHaskell diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,6 @@ +Plot-ho-matic +== + +[![Build Status](https://travis-ci.org/ghorn/Plot-ho-matic.png?branch=master)](https://travis-ci.org/ghorn/Plot-ho-matic) + +todo: a readme, for one diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Accessors.hs b/src/Accessors.hs new file mode 100644 --- /dev/null +++ b/src/Accessors.hs @@ -0,0 +1,116 @@ +{-# OPTIONS_GHC -Wall #-} +{-# Language TemplateHaskell #-} +{-# Language ExistentialQuantification #-} + +module Accessors ( makeAccessors ) where + +import Data.Map ( Map ) +import qualified Data.Map as M +import Data.Maybe ( fromMaybe ) +import Language.Haskell.TH +import qualified Text.ProtocolBuffers.Header as P' + +import PlotTypes ( PbTree(..), PbPrim(..) ) + +data AccessorTree = APrim ExpQ + | AStruct [(Name,AccessorTree)] + | ASeq AccessorTree + | AMaybe AccessorTree + +atToPbt :: ExpQ -> AccessorTree -> ExpQ +atToPbt getDouble (APrim pbCon) = [| PbtGetter ($pbCon . $getDouble) |] +atToPbt getStruct (AStruct forest) = [| PbtStruct (zip strNames $forestQ) |] + where + forestQ = listE $ zipWith (\n t -> atToPbt [| $(varE n) . $getStruct |] t) names trees + (names,trees) = unzip forest + strNames = map nameBase names +atToPbt getSeq (ASeq pbf) = + [| PbtFunctor PbSeq $getSeq $(atToPbt [| id |] pbf) (\x -> "["++x++"]")|] +atToPbt getMaybe (AMaybe pbf) = + [| PbtFunctor PbMaybe $getMaybe $(atToPbt [| id |] pbf) (\x -> "("++x++")")|] + + +pbPrimMap :: Map Name ExpQ +pbPrimMap = + M.fromList [ (''Double , [| PbDouble |]) + , (''Float , [| PbFloat |]) + , (''P'.Int32 , [| PbInt32 |]) + , (''P'.Int64 , [| PbInt64 |]) + , (''P'.Word32 , [| PbWord32 |]) + , (''P'.Word64 , [| PbWord64 |]) + , (''Bool , [| PbBool |]) + , (''P'.Utf8 , [| PbUtf8 |]) + , (''P'.ByteString, [| PbByteString |]) + ] +getPbPrim :: Name -> Q (Maybe ExpQ) +getPbPrim name = case M.lookup name pbPrimMap of + x@(Just _) -> return x + Nothing -> do + isEnum <- isInstance ''Enum [ConT name] + return $ if isEnum + then Just [| PbEnum . (\x -> (fromEnum x, show x)) |] + else Nothing + + +-- | take a constructor field and return usable stuff +handleField :: Type -> Q AccessorTree +handleField (ConT type') = do + let safeGetInfo :: Q [Con] + safeGetInfo = do + info <- reify type' + case info of + (TyConI (DataD _ _ _ [constructor] _ )) -> return [constructor] + (TyConI (NewtypeD _ _ _ constructor _ )) -> return [constructor] + (TyConI (DataD _ _ _ constructors _ )) -> return constructors + d -> error $ "handleField: safeGetInfo got unsafe info: " ++ show d + constructors <- safeGetInfo + case constructors of + -- recursive protobuf + [RecC _ varStrictTypes] -> do + let (names,types) = unzip $ map (\(x,_,z) -> (x,z)) varStrictTypes + outputs <- mapM handleField types + return $ AStruct (zip names outputs) + + -- empty protobuf + [NormalC _ []] -> return (AStruct []) + + -- everything else + xx -> do + maybePrim <- getPbPrim type' + let msg = "can't find appropriate PbPrim for " ++ show type' ++ "\n" ++ show xx + con = fromMaybe (error msg) maybePrim + + return (APrim con) +-- handle optional fields +handleField x@(AppT (ConT con) (ConT type')) + | con == ''Maybe = fmap AMaybe $ handleField (ConT type') + | con == ''P'.Seq = fmap ASeq $ handleField (ConT type') + | otherwise = error $ "handleField (AppT ...): can't handle constructor "++show con++" in "++show x +handleField x = error $ "handleField _: unhandled case: " ++ show x + + +-- | Take a constructor with multiple fields, call handleFields on each of them, +-- assemble the result +handleConstructor :: Con -> Q AccessorTree +handleConstructor (RecC _ varStrictTypes) = do + let (names,types) = unzip $ map (\(x,_,z) -> (x,z)) varStrictTypes + outputs <- mapM handleField types + return (AStruct (zip names outputs)) +handleConstructor x = fail $ "\"" ++ show x ++ "\" is not a record syntax constructor" + + +makeAccessors :: Name -> Q Exp +makeAccessors typ = do + -- get the type info + let safeGetInfo :: Q Info + safeGetInfo = do + info <- reify typ + case info of + d@(TyConI (DataD _ _ _ [_] _ )) -> return d + (TyConI (DataD _ typeName _ constructors _ )) -> + error $ "setupTelem: too many constructors: " ++ show (typeName, constructors) + d -> error $ "setupTelem: safeGetInfo got unsafe info: " ++ show d + TyConI (DataD _ _typeName _ [constructor] _ ) <- safeGetInfo + + outputs' <- handleConstructor constructor + atToPbt [| id |] outputs' diff --git a/src/GraphWidget.hs b/src/GraphWidget.hs new file mode 100644 --- /dev/null +++ b/src/GraphWidget.hs @@ -0,0 +1,327 @@ +{-# OPTIONS_GHC -Wall #-} + +module GraphWidget ( newGraph ) where + +import qualified Control.Concurrent as CC +import Control.Monad ( unless ) +import Data.Maybe ( mapMaybe, isJust, fromJust ) +import qualified Data.Tree as Tree +import Graphics.UI.Gtk ( AttrOp( (:=) ) ) +import qualified Graphics.UI.Gtk as Gtk +import System.Glib.Signals ( on ) + +import PlotTypes ( Channel(..), XAxisType(..), PbPrim ) +import PlotChart ( GraphInfo(..), AxisScaling(..), newChartCanvas ) +import ReadMaybe ( readMaybe ) + +data ListViewInfo a = ListViewInfo { lviName :: String + , lviFullName :: String + , lviGetter :: Maybe (a -> PbPrim) + , lviMarked :: Bool + } + +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 + + +-- make a new graph window +newGraph :: Channel -> IO Gtk.Window +newGraph chan@(Channel {chanGetters = changetters, chanSeq = chanseq}) = do + win <- Gtk.windowNew + + _ <- Gtk.set win [ Gtk.containerBorderWidth := 8 + , Gtk.windowTitle := chanName chan + ] + + -- mvar with everything the graphs need to plot + graphInfoMVar <- CC.newMVar GraphInfo { giData = chanseq + , giLen = 0 -- changed immediately + , giXAxis = XAxisStaticCounter + , giXScaling = LinearScaling + , giYScaling = LinearScaling + , giXRange = Nothing + , giYRange = Nothing + , giGetters = [] + } + + -- the thing where users select stuff + options' <- makeOptionsWidget graphInfoMVar changetters + options <- Gtk.expanderNew "options" + Gtk.set options [ Gtk.containerChild := options' + , Gtk.expanderExpanded := True + ] + + + -- create a new tree model + treeview' <- newTreeViewArea changetters graphInfoMVar + treeview <- Gtk.expanderNew "signals" + Gtk.set treeview [ Gtk.containerChild := treeview' + , Gtk.expanderExpanded := True + ] + + vbox <- Gtk.vBoxNew False 4 + Gtk.set vbox [ Gtk.containerChild := options + , Gtk.boxChildPacking options := Gtk.PackNatural + , Gtk.containerChild := treeview + , Gtk.boxChildPacking treeview := Gtk.PackGrow + ] + + -- chart drawing area + chartCanvas <- newChartCanvas graphInfoMVar + + -- hbox to hold eveything + hbox <- Gtk.hBoxNew False 4 + Gtk.set hbox [ Gtk.containerChild := vbox + , Gtk.boxChildPacking vbox := Gtk.PackNatural + , Gtk.containerChild := chartCanvas + ] + _ <- Gtk.set win [ Gtk.containerChild := hbox ] + + Gtk.widgetShowAll win + return win + + +makeOptionsWidget :: CC.MVar (GraphInfo a) -> Tree.Tree (String, String, Maybe (a -> PbPrim)) + -> IO Gtk.VBox +makeOptionsWidget graphInfoMVar changetters = do + -- how many to show? + plotLength <- Gtk.entryNew + plotLengthBox <- labeledWidget "# points to plot:" plotLength + + Gtk.set plotLength [Gtk.entryText := "100"] + let updatePlotLength = do + txt <- Gtk.get plotLength Gtk.entryText + gi <- CC.readMVar graphInfoMVar + case readMaybe txt of + Nothing -> do + putStrLn $ "invalid non-integer range entry: " ++ txt + Gtk.set plotLength [Gtk.entryText := show (giLen gi)] + Just k -> if k < 0 + then do + putStrLn $ "invalid negative range entry: " ++ txt + Gtk.set plotLength [Gtk.entryText := show (giLen gi)] + return () + else do + _ <- CC.swapMVar graphInfoMVar (gi {giLen = k}) + return () + updatePlotLength + _ <- on plotLength Gtk.entryActivate updatePlotLength + + -- which one is the x axis? + xaxisSelector <- Gtk.comboBoxNewText + let xaxisSelectorStrings = ["(static counter)","(counter)","(timestamp)"] + mapM_ (Gtk.comboBoxAppendText xaxisSelector) xaxisSelectorStrings + let f (_,_,Nothing) = Nothing + f (_,x,Just y) = Just (x,y) + xaxisGetters = mapMaybe f (Tree.flatten changetters) + mapM_ (Gtk.comboBoxAppendText xaxisSelector. fst) xaxisGetters + Gtk.comboBoxSetActive xaxisSelector 0 + xaxisBox <- labeledWidget "x axis:" xaxisSelector + + let updateXAxis = do + k <- Gtk.comboBoxGetActive xaxisSelector + _ <- case k of + 0 -> CC.modifyMVar_ graphInfoMVar $ + \gi -> return $ gi {giXAxis = XAxisStaticCounter} + 1 -> CC.modifyMVar_ graphInfoMVar $ + \gi -> return $ gi {giXAxis = XAxisCounter} + 2 -> CC.modifyMVar_ graphInfoMVar $ + \gi -> return $ gi {giXAxis = XAxisTime} + _ -> CC.modifyMVar_ graphInfoMVar $ + \gi -> return $ gi {giXAxis = XAxisFun (xaxisGetters !! (k - length xaxisSelectorStrings))} + return () + updateXAxis + _ <- on xaxisSelector Gtk.changed updateXAxis + + + -- user selectable range + xRange <- Gtk.entryNew + yRange <- Gtk.entryNew + Gtk.set xRange [ Gtk.entryEditable := False + , Gtk.widgetSensitive := False + ] + Gtk.set yRange [ Gtk.entryEditable := False + , Gtk.widgetSensitive := False + ] + xRangeBox <- labeledWidget "x range:" xRange + yRangeBox <- labeledWidget "y range:" yRange + Gtk.set xRange [Gtk.entryText := "(-10,10)"] + Gtk.set yRange [Gtk.entryText := "(-10,10)"] + let updateXRange = do + Gtk.set xRange [ Gtk.entryEditable := True + , Gtk.widgetSensitive := True + ] + txt <- Gtk.get xRange Gtk.entryText + gi <- CC.readMVar graphInfoMVar + case readMaybe txt of + Nothing -> do + putStrLn $ "invalid x range entry: " ++ txt + Gtk.set xRange [Gtk.entryText := "(min,max)"] + Just (z0,z1) -> if z0 >= z1 + then do + putStrLn $ "invalid x range entry (min >= max): " ++ txt + Gtk.set xRange [Gtk.entryText := "(min,max)"] + return () + else do + _ <- CC.swapMVar graphInfoMVar (gi {giXRange = Just (z0,z1)}) + return () + let updateYRange = do + Gtk.set yRange [ Gtk.entryEditable := True + , Gtk.widgetSensitive := True + ] + txt <- Gtk.get yRange Gtk.entryText + gi <- CC.readMVar graphInfoMVar + case readMaybe txt of + Nothing -> do + putStrLn $ "invalid y range entry: " ++ txt + Gtk.set yRange [Gtk.entryText := "(min,max)"] + Just (z0,z1) -> if z0 >= z1 + then do + putStrLn $ "invalid y range entry (min >= max): " ++ txt + Gtk.set yRange [Gtk.entryText := "(min,max)"] + return () + else do + _ <- CC.swapMVar graphInfoMVar (gi {giYRange = Just (z0,z1)}) + return () + _ <- on xRange Gtk.entryActivate updateXRange + _ <- on yRange Gtk.entryActivate updateYRange + + -- linear or log scaling on the x and y axis? + xScalingSelector <- Gtk.comboBoxNewText + yScalingSelector <- Gtk.comboBoxNewText + mapM_ (Gtk.comboBoxAppendText xScalingSelector) + ["linear (auto)","linear (manual)","logarithmic (auto)"] + mapM_ (Gtk.comboBoxAppendText yScalingSelector) + ["linear (auto)","linear (manual)","logarithmic (auto)"] + Gtk.comboBoxSetActive xScalingSelector 0 + Gtk.comboBoxSetActive yScalingSelector 0 + xScalingBox <- labeledWidget "x scaling:" xScalingSelector + yScalingBox <- labeledWidget "y scaling:" yScalingSelector + let updateXScaling = do + k <- Gtk.comboBoxGetActive xScalingSelector + _ <- case k of + 0 -> do + Gtk.set xRange [ Gtk.entryEditable := False + , Gtk.widgetSensitive := False + ] + CC.modifyMVar_ graphInfoMVar $ + \gi -> return $ gi {giXScaling = LinearScaling, giXRange = Nothing} + 1 -> do + CC.modifyMVar_ graphInfoMVar $ + \gi -> return $ gi {giXScaling = LinearScaling, giXRange = Nothing} + updateXRange + 2 -> do + Gtk.set xRange [ Gtk.entryEditable := False + , Gtk.widgetSensitive := False + ] + CC.modifyMVar_ graphInfoMVar $ + \gi -> return $ gi {giXScaling = LogScaling, giXRange = Nothing} + _ -> error "the \"impossible\" happened: x scaling comboBox index should be < 3" + return () + let updateYScaling = do + k <- Gtk.comboBoxGetActive yScalingSelector + _ <- case k of + 0 -> do + Gtk.set yRange [ Gtk.entryEditable := False + , Gtk.widgetSensitive := False + ] + CC.modifyMVar_ graphInfoMVar $ + \gi -> return $ gi {giYScaling = LinearScaling, giYRange = Nothing} + 1 -> do + CC.modifyMVar_ graphInfoMVar $ + \gi -> return $ gi {giYScaling = LinearScaling, giYRange = Nothing} + updateYRange + 2 -> do + Gtk.set yRange [ Gtk.entryEditable := False + , Gtk.widgetSensitive := False + ] + CC.modifyMVar_ graphInfoMVar $ + \gi -> return $ gi {giYScaling = LogScaling, giYRange = Nothing} + _ -> error "the \"impossible\" happened: y scaling comboBox index should be < 3" + return () + updateXScaling + updateYScaling + _ <- on xScalingSelector Gtk.changed updateXScaling + _ <- on yScalingSelector Gtk.changed updateYScaling + + -- vbox to hold the little window on the left + vbox <- Gtk.vBoxNew False 4 + + Gtk.set vbox [ Gtk.containerChild := plotLengthBox + , Gtk.boxChildPacking plotLengthBox := Gtk.PackNatural + , Gtk.containerChild := xaxisBox + , Gtk.boxChildPacking xaxisBox := Gtk.PackNatural + , 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 + + +newTreeViewArea :: Tree.Tree (String, String, Maybe (a -> PbPrim)) + -> CC.MVar (GraphInfo a) -> IO Gtk.ScrolledWindow +newTreeViewArea changetters graphInfoMVar = do + let mkTreeNode (name,fullName,maybeget) = ListViewInfo name fullName maybeget False + model <- Gtk.treeStoreNew [fmap mkTreeNode changetters] + treeview <- Gtk.treeViewNewWithModel model + + Gtk.treeViewSetHeadersVisible treeview True + + -- add some columns + col1 <- Gtk.treeViewColumnNew + col2 <- Gtk.treeViewColumnNew + + Gtk.treeViewColumnSetTitle col1 "name" + Gtk.treeViewColumnSetTitle col2 "visible?" + + renderer1 <- Gtk.cellRendererTextNew + renderer2 <- Gtk.cellRendererToggleNew + + Gtk.cellLayoutPackStart col1 renderer1 True + Gtk.cellLayoutPackStart col2 renderer2 True + + Gtk.cellLayoutSetAttributes col1 renderer1 model $ \lvi -> [ Gtk.cellText := lviName lvi] + Gtk.cellLayoutSetAttributes col2 renderer2 model $ \lvi -> [ Gtk.cellToggleActive := lviMarked lvi] + + _ <- Gtk.treeViewAppendColumn treeview col1 + _ <- Gtk.treeViewAppendColumn treeview col2 + + + let -- update the graph information + updateGraphInfo = do + lvis <- Gtk.treeStoreGetTree model [0] + let newGetters = [(lviFullName lvi, fromJust $ lviGetter lvi) | lvi <- Tree.flatten lvis, lviMarked lvi, isJust (lviGetter lvi)] + + _ <- CC.modifyMVar_ graphInfoMVar (\gi0 -> return $ gi0 { giGetters = newGetters }) + return () + + -- update which y axes are visible + _ <- on renderer2 Gtk.cellToggled $ \pathStr -> do + -- toggle the check mark + let treePath = Gtk.stringToTreePath pathStr + g lvi@(ListViewInfo _ _ Nothing _) = putStrLn "yeah, that's not gonna work" >> return lvi + g lvi = return $ lvi {lviMarked = not (lviMarked lvi)} + ret <- Gtk.treeStoreChangeM model treePath g + unless ret $ putStrLn "treeStoreChange fail" + updateGraphInfo + + scroll <- Gtk.scrolledWindowNew Nothing Nothing + Gtk.containerAdd scroll treeview + Gtk.set scroll [ Gtk.scrolledWindowHscrollbarPolicy := Gtk.PolicyNever + , Gtk.scrolledWindowVscrollbarPolicy := Gtk.PolicyAutomatic + ] + return scroll diff --git a/src/PlotChart.hs b/src/PlotChart.hs new file mode 100644 --- /dev/null +++ b/src/PlotChart.hs @@ -0,0 +1,141 @@ +{-# OPTIONS_GHC -Wall #-} + +module PlotChart ( AxisScaling(..), GraphInfo(..), newChartCanvas, updateCanvas ) where + +import qualified Control.Concurrent as CC +import Data.Accessor +import qualified Data.Foldable as F +import Data.Maybe ( mapMaybe ) +import Data.Sequence ( Seq, ViewR(..) ) +import qualified Data.Sequence as S +import Data.Time ( NominalDiffTime ) +import qualified Graphics.UI.Gtk as Gtk +import qualified Graphics.Rendering.Chart as Chart + +import PlotTypes ( XAxisType(..), PbPrim(..) ) + +data AxisScaling = LogScaling + | LinearScaling + +-- what the graph should draw +data GraphInfo a = GraphInfo { giData :: CC.MVar (S.Seq (a,Int,NominalDiffTime)) + , giLen :: Int + , giXAxis :: XAxisType a + , giXScaling :: AxisScaling + , giYScaling :: AxisScaling + , giXRange :: Maybe (Double,Double) + , giYRange :: Maybe (Double,Double) + , giGetters :: [(String, a -> PbPrim)] + } + +-- milliseconds for draw time +animationWaitTime :: Int +animationWaitTime = 33 + +newChartCanvas :: CC.MVar (GraphInfo a) -> IO Gtk.DrawingArea +newChartCanvas graphInfoMVar = do + -- chart drawing area + chartCanvas <- Gtk.drawingAreaNew + _ <- Gtk.widgetSetSizeRequest chartCanvas 250 250 + _ <- Gtk.onExpose chartCanvas $ const (updateCanvas graphInfoMVar chartCanvas) + _ <- Gtk.timeoutAddFull (do + Gtk.widgetQueueDraw chartCanvas + return True) + Gtk.priorityDefaultIdle animationWaitTime + return chartCanvas + +pbpToFrac :: Fractional a => PbPrim -> Maybe a +pbpToFrac (PbDouble c) + | isNaN c = Nothing + | otherwise = Just $ realToFrac c +pbpToFrac (PbFloat c) + | isNaN c = Nothing + | otherwise = Just $ realToFrac c +pbpToFrac (PbInt32 c) = Just $ realToFrac c +pbpToFrac (PbInt64 c) = Just $ realToFrac c +pbpToFrac (PbWord32 c) = Just $ realToFrac c +pbpToFrac (PbWord64 c) = Just $ realToFrac c +pbpToFrac (PbBool c) = Just $ (\x -> if x then 1 else 0) c +pbpToFrac (PbUtf8 _) = Nothing +pbpToFrac (PbByteString _) = Nothing +pbpToFrac (PbSeq _) = Nothing +pbpToFrac (PbMaybe x) = x >>= pbpToFrac +pbpToFrac (PbEnum (k,_)) = Just $ realToFrac k + +-- convert Seq PbPrim to Seq (Maybe Double) +getSeq :: Seq PbPrim -> Seq (Maybe Double) +getSeq xs = case S.viewr xs of + -- if it's empty do nothing + EmptyR -> S.empty + -- otherwise examine the first element + -- if the first element is a sequence, we'll plot the embedded sequence, not the history + _ :> PbSeq xs' -> getSeq xs' + -- if it's a primitive, map pbpToFrac over the list + _ -> fmap pbpToFrac xs + + +updateCanvas :: Gtk.WidgetClass widget => CC.MVar (GraphInfo a) -> widget -> IO Bool +updateCanvas graphInfoMVar canvas = do + gi <- CC.readMVar graphInfoMVar + datalog <- CC.readMVar (giData gi) + let -- drop values that are in history but are not to be plotted + shortLog = S.drop (S.length datalog - giLen gi) datalog + f (name,getter) = (name,fmap (\(x,_,_) -> (getter x)) shortLog :: Seq PbPrim) + + -- convert to list of (name,Seq PbPrim) + namePcs' :: [(String, Seq PbPrim)] + namePcs' = map f (giGetters gi) + + -- convert Seq PbPrim to [Maybe Double] + namePcs = map (\(name,xs) -> (name, getSeq xs)) namePcs' + + xaxisVals :: [Maybe Double] + (xaxisName, xaxisVals) = case giXAxis gi of + XAxisCounter -> + ("count", map (\(_,k,_) -> Just (fromIntegral k)) (F.toList shortLog)) + XAxisStaticCounter -> ("static count", map Just [0..]) + XAxisTime -> + ("msg receive timestamp [s]", map (\(_,_,t) -> Just (realToFrac t)) (F.toList shortLog)) + XAxisFun (name,getx) -> + (name, F.toList $ getSeq $ fmap (\(x,_,_) -> getx x) shortLog) + (width, height) <- Gtk.widgetGetSize canvas + let sz = (fromIntegral width,fromIntegral height) + win <- Gtk.widgetGetDrawWindow canvas + let myGraph = displayChart (giXScaling gi, giYScaling gi) (giXRange gi, giYRange gi) + xaxisName xaxisVals namePcs + _ <- Gtk.renderWithDrawable win $ Chart.runCRender (Chart.render myGraph sz) Chart.vectorEnv + return True + +displayChart :: (Chart.PlotValue a, Show a, RealFloat a) => + (AxisScaling, AxisScaling) -> (Maybe (a,a),Maybe (a,a)) -> String -> + [Maybe a] -> [(String, Seq (Maybe a))] -> Chart.Renderable () +displayChart (xScaling,yScaling) (xRange,yRange) xaxisName xaxis namePcs = Chart.toRenderable layout + where + f (Just x, Just y) = Just (x,y) + f _ = Nothing + drawOne (name,pc) col + = Chart.plot_lines_values ^= [mapMaybe f $ zip xaxis (F.toList pc)] + $ Chart.plot_lines_style .> Chart.line_color ^= col +-- $ Chart.plot_points_style ^= Chart.filledCircles 2 red + $ Chart.plot_lines_title ^= name + $ Chart.defaultPlotLines + allLines = zipWith drawOne namePcs Chart.defaultColorSeq + + xscaleFun = case xScaling of + LogScaling -> Chart.layout1_bottom_axis .> Chart.laxis_generate ^= Chart.autoScaledLogAxis Chart.defaultLogAxis + LinearScaling -> case xRange of + Nothing -> id + Just range -> Chart.layout1_bottom_axis .> Chart.laxis_generate ^= Chart.scaledAxis Chart.defaultLinearAxis range + + yscaleFun = case yScaling of + LogScaling -> Chart.layout1_left_axis .> Chart.laxis_generate ^= Chart.autoScaledLogAxis Chart.defaultLogAxis + LinearScaling -> case yRange of + Nothing -> id + Just range -> Chart.layout1_left_axis .> Chart.laxis_generate ^= Chart.scaledAxis Chart.defaultLinearAxis range + + layout = Chart.layout1_plots ^= map (Left . Chart.toPlot) allLines +-- $ Chart.layout1_title ^= "Wooo, Party Graph!" + $ Chart.layout1_bottom_axis .> Chart.laxis_title ^= xaxisName + $ xscaleFun + $ yscaleFun + Chart.defaultLayout1 diff --git a/src/PlotTypes.hs b/src/PlotTypes.hs new file mode 100644 --- /dev/null +++ b/src/PlotTypes.hs @@ -0,0 +1,82 @@ +{-# OPTIONS_GHC -Wall #-} +{-# Language ExistentialQuantification #-} +{-# Language GADTs #-} + +module PlotTypes ( Channel(..) + , PbPrim(..) + , PbTree(..) + , PbTree'(..) + , XAxisType(..) + , pbTreeToTree + ) where + +import Control.Concurrent ( MVar, ThreadId ) +import qualified Data.ByteString.Lazy as BSL +import Data.Sequence ( Seq ) +import Data.Time ( NominalDiffTime ) +import Data.Tree ( Tree(..) ) +import qualified Text.ProtocolBuffers.Header as P' +import Data.Functor.Compose +import Data.Functor.Identity + +data XAxisType a = XAxisTime + | XAxisCounter + | XAxisStaticCounter + | XAxisFun (String, a -> PbPrim) + +data Channel = forall a. Channel { chanName :: String + , chanGetters :: Tree (String, String, Maybe (a -> PbPrim)) + , chanSeq :: MVar (Seq (a,Int,NominalDiffTime)) + , chanMaxHist :: MVar Int + , chanServerThreadId :: ThreadId + , chanGetByteStrings :: IO [(BSL.ByteString, Int, NominalDiffTime)] + } + +data PbTree a where + PbtGetter :: (a -> PbPrim) -> PbTree a + PbtStruct :: [(String,PbTree a)] -> PbTree a + PbtFunctor :: Functor g => (g PbPrim -> PbPrim) -> (a -> g b) -> PbTree b -> (String -> String) -> PbTree a + +data PbTree' a = PbtGetter' (a -> PbPrim) + | PbtStruct' [(String,PbTree' a)] + | PbtFunctor' (PbTree' a) (String -> String) + +pbTreeToTree :: String -> PbTree a -> Tree (String, String, Maybe (a -> PbPrim)) +pbTreeToTree name tree = pbTreeToTree' "" name (please tree) + +cat :: String -> String -> String +cat [] y = y +cat x y = x ++ "." ++ y + +pbTreeToTree' :: String -> String -> PbTree' a -> Tree (String, String, Maybe (a -> PbPrim)) +pbTreeToTree' prefix name (PbtGetter' get) = Node (name, cat prefix name, Just get) [] +pbTreeToTree' prefix name (PbtStruct' stuff) = + Node (name, cat prefix name, Nothing) (map (uncurry (pbTreeToTree' (cat prefix name))) stuff) +pbTreeToTree' prefix name (PbtFunctor' tree s2s) = pbTreeToTree' prefix (s2s name) tree + +please :: PbTree a -> PbTree' a +please = f Identity runIdentity + +f :: Functor f => (a -> f b) -> (f PbPrim -> PbPrim) -> PbTree b -> PbTree' a +f afb unfunct (PbtGetter get) = PbtGetter' $ \a -> unfunct $ fmap get (afb a) +f afb unfunct (PbtStruct stuff) = PbtStruct' $ zip names (map (f afb unfunct) trees) + where + (names,trees) = unzip stuff +f afb unfunct (PbtFunctor unfunct' h theRest s2s) = PbtFunctor' (f wow blah theRest) s2s + where + wow a = Compose (fmap h (afb a)) + blah fga = unfunct $ fmap unfunct' (getCompose fga) + +data PbPrim = PbDouble Double + | PbFloat Float + | PbInt32 P'.Int32 + | PbInt64 P'.Int64 + | PbWord32 P'.Word32 + | PbWord64 P'.Word64 + | PbBool Bool + | PbUtf8 P'.Utf8 +-- | PbByteString P'.ByteString + | PbByteString BSL.ByteString + | PbSeq (Seq PbPrim) + | PbMaybe (Maybe PbPrim) + | PbEnum (Int,String) diff --git a/src/Plotter.hs b/src/Plotter.hs new file mode 100644 --- /dev/null +++ b/src/Plotter.hs @@ -0,0 +1,199 @@ +{-# OPTIONS_GHC -Wall #-} + +module Plotter ( newChannel, runPlotter, makeAccessors, Channel ) where + +import Control.Monad ( void ) +import qualified Control.Concurrent as CC +import qualified Data.Foldable as F +import Data.Sequence ( (|>) ) +import qualified Data.Sequence as S +import Data.Time ( getCurrentTime, diffUTCTime ) +import Graphics.UI.Gtk ( AttrOp( (:=) ) ) +import qualified Graphics.UI.Gtk as Gtk +import System.Glib.Signals ( on ) +import System.IO ( withFile, IOMode ( WriteMode ) ) +import qualified Text.ProtocolBuffers as PB +import qualified Data.ByteString.Lazy as BSL + +import Accessors ( makeAccessors ) +import PlotTypes ( Channel(..), PbTree, pbTreeToTree ) +import GraphWidget ( newGraph ) +import ReadMaybe ( readMaybe ) + +data ListView = ListView { lvChan :: Channel + , lvMaxHist :: Int + } + +newChannel :: (PB.ReflectDescriptor a, PB.Wire a) => String -> PbTree a -> IO (Channel, CC.Chan a) +newChannel name pbTree = do + time0 <- getCurrentTime + + seqChan <- CC.newChan + seqMv <- CC.newMVar S.empty + maxHistMv <- CC.newMVar (10000 :: Int) + + let serverLoop k = do + -- wait until a new message is written to the Chan + newMsg <- CC.readChan seqChan + -- grab the timestamp + time <- getCurrentTime + -- append this to the Seq in the MVar, dropping the excess old messages + maxNum <- CC.readMVar maxHistMv + let f seq0 = return $ S.drop (S.length seq0 + 1 - maxNum) (seq0 |> (newMsg, k, diffUTCTime time time0)) + CC.modifyMVar_ seqMv f + -- loop forever + serverLoop (k+1) + + serverTid <- CC.forkIO $ serverLoop 0 + let retChan = Channel { chanName = name + , chanGetters = pbTreeToTree name pbTree + , chanSeq = seqMv + , chanMaxHist = maxHistMv + , chanServerThreadId = serverTid + , chanGetByteStrings = cgb + } + cgb = do + s <- CC.readMVar seqMv + return $ map (\(x,y,z) -> (PB.messagePut x,y,z)) $ F.toList s + + return (retChan, seqChan) + +runPlotter :: [Channel] -> [CC.ThreadId] -> IO () +runPlotter channels backgroundThreadsToKill = do + _ <- Gtk.initGUI + + -- start the main window + win <- Gtk.windowNew + _ <- Gtk.set win [ Gtk.containerBorderWidth := 8 + , Gtk.windowTitle := "Plot-ho-matic" + ] + + -- on close, kill all the windows and threads + graphWindowsToBeKilled <- CC.newMVar [] + let killEverything = do + gws <- CC.readMVar graphWindowsToBeKilled + mapM_ Gtk.widgetDestroy gws + mapM_ CC.killThread backgroundThreadsToKill + mapM_ (CC.killThread . chanServerThreadId) channels + Gtk.mainQuit + _ <- Gtk.onDestroy win killEverything + + --------------- main widget ----------------- + -- button to clear history + buttonClear <- Gtk.buttonNewWithLabel "clear history" + _ <- Gtk.onClicked buttonClear $ do + let clearChan (Channel {chanSeq=cs}) = void (CC.swapMVar cs S.empty) + mapM_ clearChan channels + + -- list of channels + chanWidget <- newChannelWidget channels graphWindowsToBeKilled + + -- vbox to hold buttons + vbox <- Gtk.vBoxNew False 4 + Gtk.set vbox [ Gtk.containerChild := buttonClear + , Gtk.containerChild := chanWidget + ] + + -- add widget to window and show + _ <- Gtk.set win [ Gtk.containerChild := vbox ] + Gtk.widgetShowAll win + Gtk.mainGUI + + +-- the list of channels +newChannelWidget :: [Channel] -> CC.MVar [Gtk.Window] -> IO Gtk.TreeView +newChannelWidget channels graphWindowsToBeKilled = do + -- create a new tree model + let toListView ch = do + k <- CC.readMVar $ chanMaxHist ch + return ListView { lvChan = ch, lvMaxHist = k } + model <- mapM toListView channels >>= Gtk.listStoreNew + treeview <- Gtk.treeViewNewWithModel model + Gtk.treeViewSetHeadersVisible treeview True + + -- add some columns + col0 <- Gtk.treeViewColumnNew + col1 <- Gtk.treeViewColumnNew + col2 <- Gtk.treeViewColumnNew + col3 <- Gtk.treeViewColumnNew + + Gtk.treeViewColumnSetTitle col0 "channel" + Gtk.treeViewColumnSetTitle col1 "history" + Gtk.treeViewColumnSetTitle col2 "new" + Gtk.treeViewColumnSetTitle col3 "save" + + renderer0 <- Gtk.cellRendererTextNew + renderer1 <- Gtk.cellRendererTextNew + renderer2 <- Gtk.cellRendererToggleNew + renderer3 <- Gtk.cellRendererToggleNew + + Gtk.cellLayoutPackStart col0 renderer0 True + Gtk.cellLayoutPackStart col1 renderer1 True + Gtk.cellLayoutPackStart col2 renderer2 True + Gtk.cellLayoutPackStart col3 renderer3 True + + Gtk.cellLayoutSetAttributes col0 renderer0 model $ \lv -> [ Gtk.cellText := chanName (lvChan lv)] + Gtk.cellLayoutSetAttributes col1 renderer1 model $ \lv -> [ Gtk.cellText := show (lvMaxHist lv) + , Gtk.cellTextEditable := True + ] + Gtk.cellLayoutSetAttributes col2 renderer2 model $ const [ Gtk.cellToggleActive := False] + Gtk.cellLayoutSetAttributes col3 renderer3 model $ const [ Gtk.cellToggleActive := False] + + + _ <- Gtk.treeViewAppendColumn treeview col0 + _ <- Gtk.treeViewAppendColumn treeview col1 + _ <- Gtk.treeViewAppendColumn treeview col2 + _ <- Gtk.treeViewAppendColumn treeview col3 + + -- spawn a new graph when a checkbox is clicked + _ <- on renderer2 Gtk.cellToggled $ \pathStr -> do + let (i:_) = Gtk.stringToTreePath pathStr + lv <- Gtk.listStoreGetValue model i + graphWin <- newGraph (lvChan lv) + + -- add this window to the list to be killed on exit + CC.modifyMVar_ graphWindowsToBeKilled (return . (graphWin:)) + + + -- 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 () + + + -- how long to make the history + _ <- on renderer1 Gtk.edited $ \treePath txt -> do + let (i:_) = treePath + lv <- Gtk.listStoreGetValue model i + case readMaybe txt of + Nothing -> do + putStrLn $ "invalid non-integer range entry: " ++ txt + k0 <- CC.readMVar $ chanMaxHist (lvChan lv) + Gtk.listStoreSetValue model i (lv {lvMaxHist = k0}) + Just k -> if k < 0 + then do + putStrLn $ "invalid negative range entry: " ++ txt + k0 <- CC.readMVar $ chanMaxHist (lvChan lv) + Gtk.listStoreSetValue model i (lv {lvMaxHist = k0}) + else do + _ <- CC.swapMVar (chanMaxHist (lvChan lv)) k + Gtk.listStoreSetValue model i (lv {lvMaxHist = k}) + return () + + return treeview diff --git a/src/ReadMaybe.hs b/src/ReadMaybe.hs new file mode 100644 --- /dev/null +++ b/src/ReadMaybe.hs @@ -0,0 +1,8 @@ +{-# OPTIONS_GHC -Wall #-} + +module ReadMaybe ( readMaybe ) where + +readMaybe :: Read a => String -> Maybe a +readMaybe s = case reads s of + [(x, "")] -> Just x + _ -> Nothing