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 qualified Data.Sequence as S
import Accessors
import PlotHo.GraphWidget ( newGraph )
import PlotHo.Plotter ( Plotter, ChannelStuff(..), tell )
import PlotHo.PlotTypes ( Channel(..), PlotterOptions(..) )
plotterOptions :: PlotterOptions
plotterOptions =
PlotterOptions
{ maxDrawRate = 40
}
addHistoryChannel ::
Lookup a
=> String
-> XAxisType
-> ((a -> Bool -> IO ()) -> IO ())
-> 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
}
addHistoryChannel' ::
String
-> ((Double -> Vector Double -> Maybe Meta -> IO ()) -> IO ())
-> 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
}
addChannel ::
String
-> (a -> a -> Bool)
-> (a -> [Tree ([String], Either String (a -> [[(Double, Double)]]))])
-> ((a -> IO ()) -> IO ())
-> 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
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
| XAxisTime0
| XAxisCount
| XAxisCount0
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
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
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
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)
case maybeMeta of
Nothing -> return ()
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
sameSignalTree (History' _ _ _) (History' False _ _) = True
sameSignalTree (History' _ _ old) (History' True _ new) = old == new
let retChan = Channel { chanName = name
, chanMsgStore = msgStore
, chanSameSignalTree = sameSignalTree
, chanToSignalTree = toSignalTree
, chanMaxHistory = maxHist
}
return (retChan, newMessage)
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
buttonAlsoDoNothing <- Gtk.buttonNewWithLabel "also do nothing"
let triggerYo action = on buttonAlsoDoNothing Gtk.buttonActivated action >> return ()
buttonNew <- Gtk.buttonNewWithLabel "new graph"
void $ on buttonNew Gtk.buttonActivated $ do
graphWin <-
newGraph plotterOptions triggerYo (chanName channel)
(chanSameSignalTree channel)
(chanToSignalTree channel)
(chanMsgStore channel)
CC.modifyMVar_ graphWindowsToBeKilled (return . (graphWin:))
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
]
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
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
]
return hbox