module System.Taffybar.Widgets.Graph (
GraphHandle,
GraphConfig(..),
GraphDirection(..),
GraphStyle(..),
graphNew,
graphAddSample,
defaultGraphConfig
) where
import Prelude hiding ( mapM_ )
import Control.Concurrent
import Data.Sequence ( Seq, (<|), viewl, ViewL(..) )
import Data.Foldable ( mapM_ )
import Control.Monad ( when )
import Control.Monad.Trans ( liftIO )
import qualified Data.Sequence as S
import qualified Graphics.Rendering.Cairo as C
import qualified Graphics.Rendering.Cairo.Matrix as M
import qualified Graphics.UI.Gtk as Gtk
newtype GraphHandle = GH (MVar GraphState)
data GraphState =
GraphState { graphIsBootstrapped :: Bool
, graphHistory :: [Seq Double]
, graphCanvas :: Gtk.DrawingArea
, graphConfig :: GraphConfig
}
data GraphDirection = LEFT_TO_RIGHT | RIGHT_TO_LEFT deriving (Eq)
data GraphStyle
= Area
| Line
data GraphConfig =
GraphConfig { graphPadding :: Int
, graphBackgroundColor :: (Double, Double, Double)
, graphBorderColor :: (Double, Double, Double)
, graphBorderWidth :: Int
, graphDataColors :: [(Double, Double, Double, Double)]
, graphDataStyles :: [GraphStyle]
, graphHistorySize :: Int
, graphLabel :: Maybe String
, graphWidth :: Int
, graphDirection :: GraphDirection
}
defaultGraphConfig :: GraphConfig
defaultGraphConfig = GraphConfig { graphPadding = 2
, graphBackgroundColor = (0.0, 0.0, 0.0)
, graphBorderColor = (0.5, 0.5, 0.5)
, graphBorderWidth = 1
, graphDataColors = cycle [(1,0,0,0), (0,1,0,0), (0,0,1,0)]
, graphDataStyles = repeat Area
, graphHistorySize = 20
, graphLabel = Nothing
, graphWidth = 50
, graphDirection = LEFT_TO_RIGHT
}
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 })
Gtk.postGUIAsync $ Gtk.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 -> C.Render ()
outlineData pctToY xStep pct = do
(curX,_) <- C.getCurrentPoint
C.lineTo (curX + xStep) (pctToY pct)
renderFrameAndBackground :: GraphConfig -> Int -> Int -> C.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
C.setSourceRGB backR backG backB
C.rectangle fpad fpad (fw 2 * fpad) (fh 2 * fpad)
C.fill
when (graphBorderWidth cfg > 0) $ do
let p = fromIntegral (graphBorderWidth cfg)
C.setLineWidth p
C.setSourceRGB frameR frameG frameB
C.rectangle (fpad + (p / 2)) (fpad + (p / 2)) (fw 2 * fpad p) (fh 2 * fpad p)
C.stroke
renderGraph :: [Seq Double] -> GraphConfig -> Int -> Int -> Double -> C.Render ()
renderGraph hists cfg w h xStep = do
renderFrameAndBackground cfg w h
C.setLineWidth 0.1
let pad = fromIntegral $ graphPadding cfg
let framePad = fromIntegral $ graphBorderWidth cfg
C.translate (pad + framePad) (pad + framePad)
let xS = (fromIntegral w 2 * pad 2 * framePad) / fromIntegral w
yS = (fromIntegral h 2 * pad 2 * framePad) / fromIntegral h
C.scale xS yS
if graphDirection cfg == RIGHT_TO_LEFT
then C.transform $ M.Matrix (1) 0 0 1 (fromIntegral w) 0
else return ()
let pctToY pct = fromIntegral h * (1 pct)
renderDataSet hist color style
| S.length hist <= 1 = return ()
| otherwise = do
let (r, g, b, a) = color
originY = pctToY newestSample
originX = 0
newestSample :< hist' = viewl hist
C.setSourceRGBA r g b a
C.moveTo originX originY
mapM_ (outlineData pctToY xStep) hist'
case style of
Area -> do
(endX, _) <- C.getCurrentPoint
C.lineTo endX (fromIntegral h)
C.lineTo 0 (fromIntegral h)
C.fill
Line -> do
C.setLineWidth 1.0
C.stroke
sequence_ $ zipWith3 renderDataSet hists (graphDataColors cfg) (graphDataStyles cfg)
drawBorder :: MVar GraphState -> Gtk.DrawingArea -> IO ()
drawBorder mv drawArea = do
(w, h) <- Gtk.widgetGetSize drawArea
drawWin <- Gtk.widgetGetDrawWindow drawArea
s <- readMVar mv
let cfg = graphConfig s
Gtk.renderWithDrawable drawWin (renderFrameAndBackground cfg w h)
modifyMVar_ mv (\s' -> return s' { graphIsBootstrapped = True })
return ()
drawGraph :: MVar GraphState -> Gtk.DrawingArea -> IO ()
drawGraph mv drawArea = do
(w, h) <- Gtk.widgetGetSize drawArea
drawWin <- Gtk.widgetGetDrawWindow drawArea
s <- readMVar mv
let hist = graphHistory s
cfg = graphConfig s
histSize = graphHistorySize cfg
xStep = fromIntegral w / fromIntegral (histSize 1)
case hist of
[] -> Gtk.renderWithDrawable drawWin (renderFrameAndBackground cfg w h)
_ -> Gtk.renderWithDrawable drawWin (renderGraph hist cfg w h xStep)
graphNew :: GraphConfig -> IO (Gtk.Widget, GraphHandle)
graphNew cfg = do
drawArea <- Gtk.drawingAreaNew
mv <- newMVar GraphState { graphIsBootstrapped = False
, graphHistory = []
, graphCanvas = drawArea
, graphConfig = cfg
}
Gtk.widgetSetSizeRequest drawArea (graphWidth cfg) (1)
_ <- Gtk.on drawArea Gtk.exposeEvent $ Gtk.tryEvent $ liftIO (drawGraph mv drawArea)
_ <- Gtk.on drawArea Gtk.realize $ liftIO (drawBorder mv drawArea)
box <- Gtk.hBoxNew False 1
case graphLabel cfg of
Nothing -> return ()
Just lbl -> do
l <- Gtk.labelNew (Nothing :: Maybe String)
Gtk.labelSetMarkup l lbl
Gtk.boxPackStart box l Gtk.PackNatural 0
Gtk.boxPackStart box drawArea Gtk.PackGrow 0
Gtk.widgetShowAll box
return (Gtk.toWidget box, GH mv)