module System.Taffybar.Widgets.Graph (
GraphHandle,
GraphConfig(..),
graphNew,
graphAddSample,
defaultGraphConfig
) where
import Prelude hiding ( mapM_ )
import Control.Concurrent
import Data.Sequence ( Seq, (<|), viewl, ViewL(..) )
import Data.Foldable ( mapM_ )
import qualified Data.Sequence as S
import Graphics.Rendering.Cairo
import Graphics.UI.Gtk
newtype GraphHandle = GH (MVar GraphState)
data GraphState =
GraphState { graphIsBootstrapped :: Bool
, graphHistory :: [Seq Double]
, graphCanvas :: DrawingArea
, graphConfig :: GraphConfig
}
data GraphConfig =
GraphConfig { graphPadding :: Int
, graphBackgroundColor :: (Double, Double, Double)
, graphBorderColor :: (Double, Double, Double)
, graphDataColors :: [(Double, Double, Double, Double)]
, graphHistorySize :: Int
, graphLabel :: Maybe String
, graphWidth :: Int
}
defaultGraphConfig :: GraphConfig
defaultGraphConfig = GraphConfig { graphPadding = 2
, graphBackgroundColor = (0.0, 0.0, 0.0)
, graphBorderColor = (0.5, 0.5, 0.5)
, graphDataColors = []
, graphHistorySize = 20
, graphLabel = Nothing
, graphWidth = 50
}
graphAddSample :: GraphHandle -> [Double] -> IO ()
graphAddSample (GH mv) rawData = do
s <- readMVar mv
let drawArea = graphCanvas s
histSize = graphHistorySize (graphConfig s)
histsAndNewVals = zip pcts (graphHistory s)
newHists = case graphHistory s of
[] -> map S.singleton pcts
_ -> map (\(p,h) -> S.take histSize $ p <| h) histsAndNewVals
case graphIsBootstrapped s of
False -> return ()
True -> do
modifyMVar_ mv (\s' -> return s' { graphHistory = newHists })
postGUIAsync $ widgetQueueDraw drawArea
where
pcts = map (clamp 0 1) rawData
clamp :: Double -> Double -> Double -> Double
clamp lo hi d = max lo $ min hi d
outlineData :: (Double -> Double) -> Double -> Double -> Render ()
outlineData pctToY xStep pct = do
(curX,_) <- getCurrentPoint
lineTo (curX + xStep) (pctToY pct)
renderFrameAndBackground :: GraphConfig -> Int -> Int -> Render ()
renderFrameAndBackground cfg w h = do
let (backR, backG, backB) = graphBackgroundColor cfg
(frameR, frameG, frameB) = graphBorderColor cfg
pad = graphPadding cfg
fpad = fromIntegral pad
fw = fromIntegral w
fh = fromIntegral h
setSourceRGB backR backG backB
rectangle fpad fpad (fw 2 * fpad) (fh 2 * fpad)
fill
setLineWidth 1.0
setSourceRGB frameR frameG frameB
rectangle fpad fpad (fw 2 * fpad) (fh 2 * fpad)
stroke
renderGraph :: [Seq Double] -> GraphConfig -> Int -> Int -> Double -> Render ()
renderGraph hists cfg w h xStep = do
renderFrameAndBackground cfg w h
setLineWidth 0.1
let pad = graphPadding cfg
translate (fromIntegral pad + 1) (fromIntegral pad + 1)
let xS = fromIntegral (w 2 * pad 2) / fromIntegral w
yS = fromIntegral (h 2 * pad 2) / fromIntegral h
scale xS yS
let pctToY pct = fromIntegral h * (1 pct)
histsAndColors = zip hists (graphDataColors cfg)
renderDataSet (hist, color)
| S.length hist <= 1 = return ()
| otherwise = do
let (r, g, b, a) = color
originY = pctToY newestSample
originX = 0
newestSample :< hist' = viewl hist
setSourceRGBA r g b a
moveTo originX originY
mapM_ (outlineData pctToY xStep) hist'
(endX, _) <- getCurrentPoint
lineTo endX (fromIntegral h)
lineTo 0 (fromIntegral h)
fill
mapM_ renderDataSet histsAndColors
drawBorder :: MVar GraphState -> DrawingArea -> IO ()
drawBorder mv drawArea = do
(w, h) <- widgetGetSize drawArea
drawWin <- widgetGetDrawWindow drawArea
s <- readMVar mv
let cfg = graphConfig s
renderWithDrawable drawWin (renderFrameAndBackground cfg w h)
modifyMVar_ mv (\s' -> return s' { graphIsBootstrapped = True })
return ()
drawGraph :: MVar GraphState -> DrawingArea -> IO ()
drawGraph mv drawArea = do
(w, h) <- widgetGetSize drawArea
drawWin <- widgetGetDrawWindow drawArea
s <- readMVar mv
let hist = graphHistory s
cfg = graphConfig s
histSize = graphHistorySize cfg
xStep = fromIntegral w / fromIntegral (histSize 1)
case hist of
[] -> renderWithDrawable drawWin (renderFrameAndBackground cfg w h)
_ -> renderWithDrawable drawWin (renderGraph hist cfg w h xStep)
graphNew :: GraphConfig -> IO (Widget, GraphHandle)
graphNew cfg = do
drawArea <- drawingAreaNew
mv <- newMVar GraphState { graphIsBootstrapped = False
, graphHistory = []
, graphCanvas = drawArea
, graphConfig = cfg
}
widgetSetSizeRequest drawArea (graphWidth cfg) (1)
_ <- on drawArea exposeEvent $ tryEvent $ liftIO (drawGraph mv drawArea)
_ <- on drawArea realize $ liftIO (drawBorder mv drawArea)
box <- hBoxNew False 1
case graphLabel cfg of
Nothing -> return ()
Just lbl -> do
l <- labelNew Nothing
labelSetMarkup l lbl
boxPackStart box l PackNatural 0
boxPackStart box drawArea PackGrow 0
widgetShowAll box
return (toWidget box, GH mv)