{-# 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