edentv-4.10.0: EdenTvViewer.hs
{- The Eden Trace Viewer (or simply EdenTV) is a tool that can generate diagrams
to visualize the behaviour of Eden programs.
Copyright (C) 2005-2012 Philipps Universitaet Marburg
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software Foundation,
Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
-}
module EdenTvViewer where
import EdenTvType
import EdenTvBasic
import EdenTvInteract
import Control.Monad.State
import Control.Concurrent.MVar
import Data.List (foldl')
import qualified Data.Map.Strict as MS
import Graphics.UI.Gtk hiding (get, rectangle)
import Graphics.UI.Gtk.Gdk.Pixbuf
import Graphics.Rendering.Cairo
import Numeric
--import DeepSeq
import Debug.Trace
-- short terms:
type DrawColor = (Render (), Render (), Render (), Render ())
-- idle running suspended blocked
type ColorButtons = (ColorButton,ColorButton,ColorButton,ColorButton)
-- at first the matrices are sorted and nothing is selected
initMatrix :: Int -> Int -> Int -> [MachineID] -> [ProcessID] -> String -> Bool -> ViewerState
initMatrix m p t lm lp filename ignoreMessages = VS {
selRow = [],
selView = 0, -- machines are the default view
locTime = False, -- local Time off
showMsg = False, -- messages off
matrixM = [1..(fromIntegral m)],
matrixP = [1..(fromIntegral p)],
matrixT = [1..(fromIntegral t)],
matrixGP = [1..(fromIntegral m)],
ommitRedraw = False,
clicked = False,
deleteSel = False,
noDND = False,
oldView = Nothing,
confMachines = [ (mId, (True,True)) | mId <- reverse lm],
confProcesses = [ (pId, (True,True)) | pId <- reverse lp],
autoTicks = True,
tickSkip = 0,
tickMark = 1,
filename = filename,
ignoreMessages = ignoreMessages}
-- draw a piece of text right-justified
showTextR :: String -> Render ()
showTextR str = do
info <- textExtents str
let width = (\ (TextExtents _ _ w _ _ _) -> w) info
relMoveTo (-width) 0
showText str
drawAnyPic :: Bool -> Bool -> Bool -> Bool -> Bool -> Double -> Double -> (Render () -> IO ()) -> (Bool -> Double -> Double -> (Render () -> IO ()) -> Events -> Colors -> DrawingArea -> ViewerState -> (Int -> [(MachineID, Double)] -> Double -> Double) -> (Double -> Double) -> IO (Render ())) -> DrawingArea ->
Events -> MVar ViewerState -> MVar EdenTvState -> Int -> IO ()
drawAnyPic drawBlkMsg drawStartup hideStartupPhase drawDataMsgs drawSystemMsgs transX transY target drawfunc pic traces st edentvState rows = do
target $ do translate transX transY; save
state <- readMVar st
globalState <- readMVar edentvState
let colorsMap = colors globalState
-- if the startup-phase should not be displayed, the mininum startup
-- time is used as minTime
let traces' = if hideStartupPhase
then setMinTimeToStartUpTime traces
else traces
minTime = min_t traces'
maxTime = max_t traces'
maxSTime = max_t_diff traces'
let ommit = ommitRedraw state
when (not ommit) $ do
prepareBackground transX transY target pic colorsMap
-- Returns the time difference for a machine in relation to the
-- local startup time. Only used if startup synchronisation is
-- enabled
--
let getDiffTime :: Int -> [(MachineID, Double)] -> Double -> Double
getDiffTime machineId startTimes minTime
| hideStartupPhase = -((getStartTime machineId startTimes))
| otherwise = -((getStartTime machineId startTimes) + minTime)
-- Returns the relative position in percent for a given point of time
-- in relation to the total duration. The value is used to calculate the
-- absolute position in pixels (which is done automatically by the drawing
-- area).
--
let scaledTime :: Double -> Double
scaledTime time
| not $ locTime state = (time - minTime) / (maxTime - minTime)
| otherwise = (time - minTime) / ((maxTime+maxSTime) - minTime)
-- draw machines/processes/threads
drawAxes <- drawfunc hideStartupPhase transX transY target traces' colorsMap pic state getDiffTime scaledTime
pixelsPerSecond <- getPixelsPerSecond pic state minTime maxTime maxSTime
if selView state < 3
then addSelection transX transY target (fromIntegral rows) pic state
else addSelectionGroupedProcesses transX transY target (fromIntegral rows) pic state [] traces'
drawMessages drawBlkMsg drawDataMsgs drawSystemMsgs hideStartupPhase pixelsPerSecond transX transY target traces' pic state colorsMap
when (drawStartup && (not hideStartupPhase)) $ drawStartupMarker pixelsPerSecond transX transY target traces' pic state colorsMap
target copyPage -- only for pdf export -- otherwise useless
-- finally draw axes on top of everything
target drawAxes
setMinTimeToStartUpTime :: Events -> Events
setMinTimeToStartUpTime events = events {min_t = maxStartup events}
getPixelsPerSecond :: DrawingArea -> ViewerState -> Double -> Double -> Double -> IO Double
getPixelsPerSecond pic state minTime maxTime maxSTime = do
(_,(ulx,uly,lrx,lry)) <- getCorners pic
let pixelsPerSecond
| locTime state = (lrx - ulx) / ((maxTime+maxSTime) - minTime)
| otherwise = (lrx - ulx) / (maxTime - minTime)
return pixelsPerSecond
drawMessages :: Bool -> Bool -> Bool -> Bool -> Double -> Double -> Double -> (Render () -> IO ()) -> Events -> DrawingArea -> ViewerState -> Colors -> IO ()
drawMessages drawBlkMsg drawDataMsgs drawSystemMsgs hideStartupPhase pixelsPerSecond visX visY target events pic state colorsMap = do
--events was ((ms,ps,_),mTimes,(mxs,mxst),(msgs,amsgs,hmsgs,_,rcvtimes),(minTime,maxTime,maxSTime,maxSize,maxLD),_)
if ((v < 2) || (v == 3)) && showMsg state
then do
win <- widgetGetDrawWindow pic
(_,(ulx,uly,lrx,lry)) <- getCorners pic
let ySkip :: Double
ySkip = case v of
1 -> (lry - uly) / (fromIntegral (length (matrixP state)))
0 -> (lry - uly) / (fromIntegral (length (matrixM state)))
3 -> (lry - uly - ((numM-1)*10) )/ (fromIntegral (length (matrixP state)))
-- do not draw trapezoid if each message of a message bulk is
-- drawn individually
when (drawDataMsgs && (not drawBlkMsg)) $ drawHeads win pixelsPerSecond ySkip ulx uly
drawRcvLengths win pixelsPerSecond ySkip ulx uly
drawMsgs win pixelsPerSecond ySkip ulx uly
else return ()
where v = selView state
useDiff = locTime state
sort = case v of
1 -> 0:(reverse (matrixP state))
0 -> reverse (matrixM state)
3 -> reverse (matrixGP state)
iv = 0
ms = machinelist events
ps = processlist events
minTime = min_t events
mxst = startupOffsets events
(msgs,amsgs,hmsgs,_,rcvtimes) = messagelist events
-- Returns the pixel position on the drawing area for a given
-- point of time.
--
getPositionInPx :: Int -> Double -> [(MachineID, Double)] -> Double -> Double
getPositionInPx machineId time startTimes xScale
| useDiff && hideStartupPhase = (time + (getStartTime machineId startTimes) - minTime) * xScale
| useDiff = (time + (getStartTime machineId startTimes)) * xScale
| otherwise = (time - minTime) * xScale
(rowPos,rowOff) = case v of
1 -> ((iv:(rowPosP 0 iv (reverse ps))), [iv..])
0 -> ((iv:(rowPosM iv (reverse ms))), (repeat iv))
where rowPosP :: Num a => MachineID -> a -> [Process] -> [a]
rowPosP _ _ [] = []
rowPosP m' i (p:pss)
| (getMIdFromP p) == m' = rowPosP m' (i+1) pss
| otherwise = i:(rowPosP (getMIdFromP p) (i+1) pss)
rowPosM :: Num a => a -> [Machine] -> [a]
rowPosM _ [] = []
rowPosM i (_:mss) = i:(rowPosM (i+1) mss)
numProcs :: MS.Map MachineID Int --was: [(MachineID, Int)]
numProcs = foldl' (\c m -> MS.insert (getIdM m) (totalProcesses m) c) MS.empty ms
--was: map (\(mId,_,_,(numP,_,_),_) -> (mId, numP)) ms
numM = fromIntegral $ length ms
sortedMachines = [(numM+1) - (posToMachine pos (matrixGP state)) | pos <- [1..numM]]
posToMachine :: Double -> [Double] -> Double
posToMachine pos sort = posAcc 1 pos sort
where posAcc i pos (s:ss)
| pos == s = i
| otherwise = posAcc (i+1) pos ss
posAcc _ _ [] = 0
machineOffsets = buildOffsets (0,0) sortedMachines
where buildOffsets :: (Double, Double) -> [Double] -> [(Double,Double)]
buildOffsets (numP, numSkip) (mId:mIds) = (numP, numSkip) : (buildOffsets ((fromIntegral curP)+numP, numSkip+1) mIds)
where Just curP = MS.lookup (floor mId) numProcs
buildOffsets _ [] = []
messageActive :: ProcessID -> ProcessID -> Bool
messageActive sender receiver = case v of
3 -> let activeProcs = confProcesses state
Just (_,sout) = lookup sender activeProcs
Just (rin,_) = lookup receiver activeProcs
in sout && rin
1 -> let activeProcs = confProcesses state
Just (_,sout) = lookup sender activeProcs
Just (rin,_) = lookup receiver activeProcs
in sout && rin
0 -> let activeMachs = confMachines state
Just (_,sout) = lookup (pId2mId sender) activeMachs
Just (rin,_) = lookup (pId2mId receiver) activeMachs
in sout && rin
_ -> True
drawRcvLengths :: DrawWindow -> Double -> Double -> Double -> Double -> IO ()
drawRcvLengths win xScale yScale ulx uly =
target $ do
translate visX visY
translate ulx (uly- 0.2*yScale)
getColor messagesReceive colorsMap
drawRcvLength rcvtimes
where
pidsOnMachine :: MachineID -> [Int]
pidsOnMachine mId = map (pId.getIdP) $ filter ((== mId).getMIdFromP) ps
row :: Int -> Int -> Double
row m p
| v /= 3 = (((sort)!!(rowPos!!m + rowOff!!p)) * yScale)
| otherwise = ( (numP + ((fromIntegral curP) +1- (fromIntegral p))) * yScale) + (numSkip*10)
where machine = floor $ sort!!(m-1)
(numP,numSkip) = machineOffsets!!(machine-1)
Just curP = MS.lookup m numProcs
drawRcvLength [] = return ()
drawRcvLength (((mID,ptimes),st,et):ts) =
if and (map (0<=) [mID])
then do
drawRcvLength' mID ptimes st
drawRcvLength ts
else drawRcvLength ts
drawRcvLength' mID ((pID,ptime):ptimes) oldSec = do
rectangleLimited hideStartupPhase (getPositionInPx mID oldSec mxst xScale) (row mID pID) ((getPositionInPx mID ptime mxst xScale)-(getPositionInPx mID oldSec mxst xScale)) (yScale/10)
drawRcvLength' mID ptimes ptime
drawRcvLength' _ [] _ = fill
arrow :: Double -> Double -> Double -> Double -> Render ()
arrow fromX fromY toX toY = do
moveTo fromX fromY
lineTo toX toY
arc toX toY 1.5 0 (2 * pi)
stroke
drawMsgs :: DrawWindow -> Double -> Double -> Double -> Double -> IO ()
drawMsgs win xScale yScale ulx uly =
target $ do
translate visX visY
thickness <- getLineWidth
translate ulx (uly - 0.3*yScale)
drawMsg msgs thickness
-- if requested, draw additional messages
if drawBlkMsg then drawMsg amsgs (thickness/2) else return ()
where
row :: Int -> Int -> Double
row m p
| v /= 3 = (((sort)!!(rowPos!!m + rowOff!!p)) * yScale)
| otherwise = ( (numP + ((fromIntegral curP) +1- (fromIntegral p))) * yScale) + (numSkip*10)
where machine = floor $ sort!!(m-1)
(numP,numSkip) = machineOffsets!!(machine-1)
Just curP = MS.lookup m numProcs
drawMsg [] l = setLineWidth l
drawMsg (m@(MSG (spid,o,rpid,i) st rt t s):ms) thickness = do
let sm = pId2mId spid
sp = pId spid
rm = pId2mId rpid
rp = pId rpid
when ((and (map (0<=) [sm,sp,rm,rp])) && (messageActive spid rpid))
(do
if t == DataMes || t == Head || t == LocalDataMes || t == LocalHead-- not a system message (`DataMes` or `Head`)
then
when drawDataMsgs $ do
let colorType = case t of
DataMes -> messagesData
Head -> messagesHead
LocalDataMes -> messagesDataLocal
LocalHead -> messagesHeadLocal
getColor colorType colorsMap
drawMsgArrow thickness sm sp rm rp st rt
-- if t == DataMes
-- then do
-- -- draw data messages with half thickness
-- getColor messagesData colorsMap
-- drawMsgArrow (thickness / 2) sm sp rm rp st rt
-- else do
-- getColor messagesHead colorsMap
-- drawMsgArrow thickness sm sp rm rp st rt
else
-- if requested, draw system msgs with a gray color
-- otherwise skip the system msgs
when drawSystemMsgs $ do
getColor messagesSystem colorsMap
drawMsgArrow thickness sm sp rm rp st rt
)
drawMsg ms thickness
drawMsgArrow width sm sp rm rp st rt
= do
setLineWidth width
arrow (getPositionInPx sm st mxst xScale) ((row sm sp)-0.3*yScale) (getPositionInPx rm rt mxst xScale) (row rm rp)
arrow :: Double -> Double -> Double -> Double -> Render ()
arrow fromX fromY toX toY = do
moveTo fromX fromY
lineTo toX toY
arc toX toY 1.5 0 (2 * pi)
stroke
-- draws a transparent, grey trapezoid for bulk messages
drawHeads :: DrawWindow -> Double -> Double -> Double -> Double -> IO ()
drawHeads win xScale yScale ulx uly =
target $ do
translate visX visY
lWidth <- getLineWidth
setLineWidth (lWidth / 2)
translate ulx (uly - 0.3*yScale)
drawHead hmsgs
setLineWidth lWidth
where
row :: Int -> Int -> Double
row m p
| v /= 3 = (((sort)!!(rowPos!!m + rowOff!!p)) * yScale)
| otherwise = ( (numP + ((fromIntegral curP) +1- (fromIntegral p))) * yScale) + (numSkip*10)
where machine = floor $ sort!!(m-1)
(numP,numSkip) = machineOffsets!!(machine-1)
Just curP = MS.lookup m numProcs
compSize = 2 * (maxMsgSize events)
relSize s = 0.15 + (s / compSize)
drawHead (((spid,_,rpid,_),(ts1,tr1,ts2,tr2),size,_):hs) =
let sm = pId2mId spid
sp = pId spid
rm = pId2mId rpid
rp = pId rpid
in if ((min sp rp) < 0) || (not (messageActive spid rpid))
then drawHead hs -- can't draw this!
else do getColorAlpha messagesBlock colorsMap (relSize size)
trapezoid (getPositionInPx sm ts1 mxst xScale) (getPositionInPx sm ts2 mxst xScale) ((row sm sp)-0.3*yScale)
(getPositionInPx rm tr1 mxst xScale) (getPositionInPx rm tr2 mxst xScale) (row rm rp)
drawHead hs
drawHead [] = return ()
trapezoid :: Double -> Double -> Double -> Double -> Double -> Double -> Render ()
trapezoid x11 x12 y1 x21 x22 y2 = do
moveTo x11 y1
lineTo x12 y1
lineTo x22 y2
lineTo x21 y2
fill
-- Draws a transparent blue box on top of a selected row
--
addSelection ::Double -> Double -> (Render () -> IO ()) -> Double -> DrawingArea -> ViewerState -> IO ()
addSelection visX visY target nRows pic state = do
win <- widgetGetDrawWindow pic
(_,(ulx,uly,lrx,lry)) <- getCorners pic
let xSkip = (lrx - ulx)
ySkip = (lry - uly) / nRows
rows = selRow state
if (not $ null rows)
then sequence_ $ map (\row -> target $ do
translate visX visY
translate ulx uly
--scale xSkip ySkip
translate 0 (ySkip * (row - 1))
setSourceRGBA 0.0 0.0 1.0 0.3
rectangle 0.0 0.0 xSkip ySkip
fill) rows
else return ()
return ()
addSelectionGroupedProcesses :: Double -> Double -> (Render () -> IO ()) -> Double -> DrawingArea -> ViewerState -> [Double] -> Events -> IO ()
addSelectionGroupedProcesses visX visY target nRows pic state lineHeights events= do
--events was ((ms,ps,_),mTimes,(mxs,mxst),(msgs,amsgs,hmsgs,_,rcvtimes),(minTime,maxTime,maxSTime,maxSize,maxLD),_)
win <- widgetGetDrawWindow pic
(_,(ulx,uly,lrx,lry)) <- getCorners pic
let ms = machinelist events
xSkip = (lrx - ulx)
ySkip = (lry - uly) / nRows
rows = selRow state
numProcs :: MS.Map MachineID Int --was: [(MachineID, Int)]
numProcs = foldl' (\c m -> MS.insert (getIdM m) (totalProcesses m) c) MS.empty ms
--was: map (\(mId,_,_,(numP,_,_),_) -> (mId, numP)) ms
numM = fromIntegral $ length ms
procSkip = (lry - uly - ((numM-1)*10) )/ (fromIntegral (length (matrixP state)))
sortedMachines = [(numM+1) - (posToMachine pos (matrixGP state)) | pos <- [1..numM]]
posToMachine :: Double -> [Double] -> Double
posToMachine pos sort = posAcc 1 pos sort
where posAcc i pos (s:ss)
| pos == s = i
| otherwise = posAcc (i+1) pos ss
posAcc _ _ [] = 0
machineOffsets = buildOffsets (0,0) sortedMachines
where buildOffsets :: (Double, Double) -> [Double] -> [(Double,Double)]
buildOffsets (numP, numSkip) (mId:mIds) = (numP, numSkip) : (buildOffsets ((fromIntegral curP)+numP, numSkip+1) mIds)
where Just curP = MS.lookup (floor mId) numProcs
buildOffsets _ [] = []
if (not $ null rows)
then sequence_ $ map (\row -> target $ do
translate visX visY
translate ulx uly
--scale xSkip ySkip
let mach = (floor numM + 1) - (floor (posToMachine row (matrixGP state)))
(numP,numGap) = (machineOffsets!!((floor row) - 1))
Just lenP = MS.lookup mach numProcs
translate 0 (numP*procSkip+numGap*10 - 5)
setSourceRGBA 0.0 0.0 1.0 0.3
rectangle 0.0 0.0 xSkip ((fromIntegral lenP)*procSkip + 5)
fill) rows
else return ()
return ()
-- draws y-axis
--
drawNames :: Double -> Double -> [Double] -> [String] -> Colors -> Render ()
-- x-Offset lry y-Offsets names
drawNames x lry (s:ss) (n:ns) colorsMap = do
moveTo x (s-3)
getColor chartAxesLabel colorsMap
showTextR (n)
moveTo (x+2) s
getColor chartAxes colorsMap
lineTo (x+5) s
drawNames x lry ss ns colorsMap
drawNames x lry _ _ colorsMap = do
moveTo (x+5) (- 5)
getColor chartAxes colorsMap
lineTo (x+5) (lry + 5)
drawName x lry y name colorsMap = do
moveTo x (y-3)
getColor chartAxesLabel colorsMap
showTextR name
drawNameTick x lry y colorsMap = do
moveTo (x+2) y
getColor chartAxes colorsMap
lineTo (x+5) y
drawNameLine x lry colorsMap = do
moveTo (x+5) (- 5)
getColor chartAxes colorsMap
lineTo (x+5) (lry + 5)
drawTimes :: Bool -- True, if ticks/labels should be placed automatically
-> Seconds -- draw tick every `manualSkip` seconds
-> Int -- draw time every `manualMarks` ticks
-> (Seconds, Seconds, Seconds)
-> Bool -- startup sync. enabled
-> DimV -- visible area
-> Dim -- area to draw in
-> Colors
-> Render ()
drawTimes useAuto manualSkip manualMarks (minT,maxT,maxST) useDiff (vx,vy,vw,vh) (ulx,uly,lrx,lry) colors = do
let y = fromIntegral (vy + vh - 20)
xDelta = fromIntegral vw / 15
tDelta
| useDiff = xDelta * ((maxT+maxST) - minT) / (lrx - ulx)
| otherwise = xDelta * (maxT - minT) / (lrx - ulx)
tSkip = if not useAuto then manualSkip else smoothSkip tDelta
xSkip
| useDiff = tSkip * (lrx - ulx) / ((maxT+maxST) - minT)
| otherwise = tSkip * (lrx - ulx) / (maxT - minT)
-- draw the x-axis
moveTo (ulx-5) y
getColor chartAxes colors
lineTo lrx y
stroke
-- draw axis labels and ticks
drawTime 0 xSkip y
where
drawTime :: Double -> Double -> Double -> Render ()
drawTime i x y = if mx < lrx
then do
-- draw tick
moveTo mx y
getColor chartAxes colors
lineTo mx my
stroke
-- draw label
moveTo mx (y + 12)
getColor chartAxesLabel colors
if useAuto
then showText timeString
else if (floor i) `mod` manualMarks == 0
then showText timeString
else return ()
drawTime (i+1) x y
else stroke
where mx = ulx + (i * x)
my = if useAuto
then y + 5
else if ((floor i) `mod` manualMarks == 0) && manualMarks > 1
then y + 6
else y + 5
fullTime
| useDiff = (showFFloat (Just 6) (posToTime minT (maxT+maxST) ulx lrx mx) "")
| otherwise = (showFFloat (Just 6) (posToTime minT maxT ulx lrx mx) "")
-- drop trailing zeros (1.600000 -> 1.6)
(sndStr,fstStr) = splitAt 5 (reverse fullTime)
timeString = (reverse fstStr) ++ (reverse (dropWhile (== '0') sndStr))
smoothSkip :: Seconds -> Double
smoothSkip s
| cmp > 7 = 10^^(exponent+1)
| cmp > 5 = 7.5 * 10^^exponent
| cmp > 2 = 5 * 10^^exponent
| cmp > 1 = 2 * 10^^exponent
| otherwise = 10^^exponent
where exponent = floor (logBase 10 s)
cmp = s * 10^^(-exponent)
drawThreads :: Bool -> Double -> Double -> (Render () -> IO ()) -> Events -> Colors -> DrawingArea -> ViewerState -> (Int -> [(MachineID, Double)] -> Double -> Double) -> (Double -> Double) -> IO (Render ())
drawThreads hideStartupPhase visX visY target events color pic state getDiffTime scaledTime = do
--events was ((_,_,threads),mTimes,(_,mxst),_,(minTime,maxTime,maxSTime,maxSize,maxLD),_)
win <- widgetGetDrawWindow pic
(cv@(vx,vy,vw,vh),cr@(ulx,uly,lrx,lry)) <- getCorners pic
let threads = threadlist events
numT = (fromIntegral (length threads))::Double
ySkip = (lry - uly) / numT
xSkip = (lrx - ulx)
sort = matrixT state
names = map (\((pid,t),_) -> ('T':(show pid) ++ ':': (show t))) threads
target $ do
translate visX visY
save
translate ulx uly
scale xSkip ySkip
if locTime state
then drawLocalThreads threads sort
else drawGlobalThreads threads sort
restore
let maxTime = max_t events
maxSTime = max_t_diff events
drawAxes = do
translate visX visY
drawTimes (autoTicks state) (tickSkip state) (tickMark state) (minTime,maxTime,maxSTime) (locTime state) cv cr color
translate 0 (uly)
drawNames (fromIntegral vx + ulx - 5) (lry-uly) (map (ySkip *) sort) names color
stroke
return drawAxes
where
minTime = min_t events
drawLocalThreads, drawGlobalThreads :: [Thread] -> [Double] -> Render ()
drawLocalThreads (((pid,_),evts):ts) (s:ss) = do
let diff = getDiffTime (pId2mId pid) (startupOffsets events) minTime
drawEvents evts 1 s diff
drawLocalThreads ts ss
drawLocalThreads _ _ = return ()
drawGlobalThreads ((_,evts):ts) (s:ss) = do
drawEvents evts 1 s 0.0
drawGlobalThreads ts ss
drawGlobalThreads _ _ = return ()
drawEvents :: [ThreadEvent] -> Double -> Double -> Double -> Render ()
drawEvents (e:es) oldSec line diff = case e of
(KillThread sec) -> drawEvents es (scaledTime (sec - diff)) line diff
(GCThread sec _ _ _ l) -> do
let (newSec,evtColor) = getTimeAndColor
evtColor
rectangleLimited hideStartupPhase newSec barG (oldSec - newSec) (fromIntegral l * ldScale)
fill
drawEvents es newSec line diff
evt -> do
let (newSec,evtColor) = getTimeAndColor
evtColor -- set the right color
rectangleLimited hideStartupPhase newSec barO (oldSec - newSec) barH
fill
drawEvents es newSec line diff
where getTimeAndColor = case e of
RunThread sec -> (scaledTime (sec - diff), getColor statusRunning color)
SuspendThread sec -> (scaledTime (sec - diff), getColor statusSuspended color)
BlockThread sec _ _ -> (scaledTime (sec - diff), getColor statusBlocked color)
DeblockThread sec -> (scaledTime (sec - diff), getColor statusSuspended color)
GCThread sec _ _ _ _-> (scaledTime (sec - diff), getColor statusIdle color)
NewThread sec _ -> (scaledTime (sec - diff), getColor statusSuspended color)
barO = line - 0.8
barG = line - 0.1
drawEvents _ _ _ _ = return ()
barH = 0.7
ldScale = (-barH) / (maxLD events)
drawProcesses :: Bool -> Double -> Double -> (Render () -> IO ()) -> Events -> Colors -> DrawingArea -> ViewerState -> (Int -> [(MachineID, Double)] -> Double -> Double) -> (Double -> Double) -> IO (Render ())
drawProcesses hideStartupPhase visX visY target events color pic state getDiffTime scaledTime = do
--events was ((_,processes,_),mTimes,(_,mxst),_,(minTime,maxTime,maxSTime,maxSize,maxLD),_)
win <- widgetGetDrawWindow pic
(cv@(vx,vy,vw,vh),cr@(ulx,uly,lrx,lry)) <- getCorners pic
let processes = processlist events
numP = (fromIntegral (length processes))::Double
ySkip = (lry - uly) / numP
xSkip = (lrx - ulx)
sort = matrixP state
names = map (\p' -> let pid = getIdP p' in ('P':(show pid))) processes
target $ do
translate visX visY
save
translate ulx uly
scale xSkip ySkip
if locTime state
then drawLocalProcesses processes sort
else drawGlobalProcesses processes sort
restore
let maxTime = max_t events
maxSTime = max_t_diff events
drawAxes = do
translate visX visY
drawTimes (autoTicks state) (tickSkip state) (tickMark state) (minTime,maxTime,maxSTime) (locTime state) cv cr color
translate 0 (uly)
drawNames (fromIntegral vx + ulx - 5) (lry-uly) (map (ySkip *) sort) names color
stroke
return drawAxes
where
minTime = min_t events
drawLocalProcesses, drawGlobalProcesses :: [Process] -> [Double] -> Render ()
drawLocalProcesses (p:ps) (s:ss) = do
let diff = getDiffTime (getMIdFromP p) (startupOffsets events) minTime
drawEvents (eventlistP p) 1 s diff
drawLocalProcesses ps ss
drawLocalProcesses _ _ = return ()
drawGlobalProcesses (p:ps) (s:ss) = do
drawEvents (eventlistP p) 1 s 0.0
drawGlobalProcesses ps ss
drawGlobalProcesses _ _ = return ()
drawEvents :: [ProcessEvent] -> Double -> Double -> Double -> Render ()
drawEvents [] _ _ _ = return ()
drawEvents (e:es) oldSec line diff = case e of
KillProcess sec _ -> drawEvents es (scaledTime (sec - diff)) line diff
LabelProcess _ _ -> drawEvents es oldSec line diff -- don't care
GCProcess sec _ _ _ l -> do
let (newSec,evtColor,_,_) = getTimeAndColor
evtColor
rectangleLimited hideStartupPhase newSec barG (oldSec - newSec) (fromIntegral l * ldScale)
fill
drawEvents es newSec line diff
_ -> do
let (newSec,evtColor,u,d) = getTimeAndColor
evtColor -- set the right color
rectangleLimited hideStartupPhase newSec u (oldSec - newSec) d
fill
drawEvents es newSec line diff
where getTimeAndColor = case e of
RunningProcess sec -> (scaledTime (sec - diff), getColor statusRunning color,barO,barH)
SuspendedProcess sec -> (scaledTime (sec - diff), getColor statusSuspended color,barO,barH)
BlockedProcess sec -> (scaledTime (sec - diff), getColor statusBlocked color,barO,barH)
GCProcess sec _ _ _ _-> (scaledTime (sec - diff), getColor statusIdle color,barO,barH)
NewProcess sec -> (scaledTime (sec - diff), getColor statusIdle color,barP,barI)
IdleProcess sec -> (scaledTime (sec - diff), getColor statusIdle color,barP,barI)
_ -> trace ("getTimeAndColor: unknown case "++(show e)) (0, getColor chartBackground color, 0, 0)
barO = line - 0.8
barG = line - 0.1
barP = line - 0.5
barH = 0.7
barI = 0.4
ldScale = (-barH) / (maxLD events)
drawGroupProcesses :: Bool -> Double -> Double -> (Render () -> IO ()) -> Events -> Colors -> DrawingArea -> ViewerState -> (Int -> [(MachineID, Double)] -> Double -> Double) -> (Double -> Double) -> IO (Render ())
drawGroupProcesses hideStartupPhase visX visY target events color pic state getDiffTime scaledTime = do
--events was ((machines,processes,_),mTimes,(_,mxst),_,(minTime,maxTime,maxSTime,maxSize,maxLD),_)
let machines = machinelist events
processes = processlist events
win <- widgetGetDrawWindow pic
let groupedProcesses = map (\m -> let mId = getIdM m in filter (\p -> getMIdFromP p == mId) processes) machines
--let sortOrder :: [(Double,
(cv@(vx,vy,vw,vh),cr@(ulx,uly,lrx,lry)) <- getCorners pic
let numP = (fromIntegral (length processes))::Double
numM = (fromIntegral (length machines))::Double
machGap = 10
ySkip = ((lry - uly - ((numM-1)*machGap) ) / numP)
xSkip = (lrx - ulx)
sort = matrixGP state
sortGroup = map (pos 1 sort) [1..numM]
where pos :: Double -> [Double] -> Double -> Double
pos i (y:ys) x
| x == y = i
| otherwise = pos (i+1) ys x
pos _ [] _ = undefined
sortedGroupedProcess = map (\i -> groupedProcesses !! ((floor i)-1)) sortGroup
drawLocalGroupedProcesses :: [[Process]] -> Double -> Render ()
drawLocalGroupedProcesses (p:ps) i = do
let skip = (machGap / ySkip)
drawLocalProcesses p [1..] i
drawLocalGroupedProcesses ps (i + (fromIntegral $ length p) + skip)
drawLocalGroupedProcesses [] _ = return ()
drawGlobalGroupedProcesses :: [[Process]] -> Double -> Render ()
drawGlobalGroupedProcesses (p:ps) i = do
let skip = (machGap / ySkip)
drawGlobalProcesses p [1..] i
drawGlobalGroupedProcesses ps (i + (fromIntegral $ length p) + skip)
drawGlobalGroupedProcesses [] _ = return ()
drawGroupNames :: [[Process]] -> Double -> Render ()
drawGroupNames (p:ps) i = do
let skip = (machGap)
drawPNames p [1..] i color
stroke
drawGroupNames ps (i+ (((fromIntegral $ length p))*ySkip) + skip)
drawGroupNames [] _ = do
drawNameLine (fromIntegral vx + ulx - 5) (lry-uly) color
stroke
drawPNames [p] (s:ss) skip colors = do
let pid = getIdP p
drawName (fromIntegral vx + ulx - 5) (lry-uly) ((s*ySkip)+skip) ("P" ++ (show pid)) colors
drawNameTick (fromIntegral vx + ulx -5) (lry-uly) ((s*ySkip)+skip+5) colors
drawPNames (p:ps) (s:ss) skip colors = do
let pid = getIdP p
drawName (fromIntegral vx + ulx - 5) (lry-uly) ((s*ySkip)+skip) ("P" ++ (show pid)) colors
drawPNames ps ss skip colors
target $ do
translate visX visY
save
translate ulx uly
scale xSkip ySkip
--liftIO $ putStrLn $ "sort" ++ (show sort)
--liftIO $ putStrLn $ "sortGroup" ++ (show sort)
if locTime state
then drawLocalGroupedProcesses sortedGroupedProcess 0
else drawGlobalGroupedProcesses sortedGroupedProcess 0
restore
let maxTime = max_t events
maxSTime = max_t_diff events
drawAxes = do
translate visX visY
drawTimes (autoTicks state) (tickSkip state) (tickMark state) (minTime,maxTime,maxSTime) (locTime state) cv cr color
translate 0 (uly)
drawGroupNames sortedGroupedProcess 0
stroke
return drawAxes
where minTime = min_t events
drawLocalProcesses :: [Process] -> [Double] -> Double -> Render ()
drawLocalProcesses (p:ps) (s:ss) skip = do
let diff = getDiffTime (getMIdFromP p) (startupOffsets events) minTime
drawEvents (eventlistP p) 1 s diff skip
drawLocalProcesses ps ss skip
drawLocalProcesses _ _ _ = return ()
drawGlobalProcesses (p:ps) (s:ss) skip = do
drawEvents (eventlistP p) 1 s 0.0 skip
drawGlobalProcesses ps ss skip
drawGlobalProcesses _ _ _ = return ()
drawEvents :: [ProcessEvent] -> Double -> Double -> Double -> Double -> Render ()
drawEvents [] _ _ _ _ = return ()
drawEvents (e:es) oldSec line diff skip = case e of
KillProcess sec _ -> drawEvents es (scaledTime (sec - diff)) line diff skip
LabelProcess _ _ -> drawEvents es oldSec line diff skip -- don't care
GCProcess sec _ _ _ l -> do
let (newSec,evtColor,_,_) = getTimeAndColor
evtColor
rectangleLimited hideStartupPhase newSec barG (oldSec - newSec) (fromIntegral l * ldScale)
fill
drawEvents es newSec line diff skip
_ -> do
let (newSec,evtColor,u,d) = getTimeAndColor
evtColor -- set the right color
rectangleLimited hideStartupPhase newSec (skip+u) (oldSec - newSec) d
fill
drawEvents es newSec line diff skip
where getTimeAndColor = case e of
RunningProcess sec -> (scaledTime (sec - diff), getColor statusRunning color,barO,barH)
SuspendedProcess sec -> (scaledTime (sec - diff), getColor statusSuspended color,barO,barH)
BlockedProcess sec -> (scaledTime (sec - diff), getColor statusBlocked color,barO,barH)
GCProcess sec _ _ _ _-> (scaledTime (sec - diff), getColor statusIdle color,barO,barH)
NewProcess sec -> (scaledTime (sec - diff), getColor statusIdle color,barP,barI)
IdleProcess sec -> (scaledTime (sec - diff), getColor statusIdle color,barP,barI)
_ -> trace ("getTimeAndColor: unknown case "++(show e)) (0, getColor chartBackground color, 0, 0)
barO = line - 1 -- - 0.7
barG = line - 0.1
barP = line - 0.5
barH = 1
barI = 0.4
ldScale = (-barH) / (maxLD events)
drawMachines :: Bool -> Double -> Double -> (Render () -> IO ()) -> Events -> Colors -> DrawingArea -> ViewerState -> (Int -> [(MachineID, Double)] -> Double -> Double) -> (Double -> Double) -> IO (Render ())
drawMachines hideStartupPhase visX visY target events color pic state getDiffTime scaledTime = do
--events was ((machines,_,_),mTimes,(mxs,mxst),_,(minTime,maxTime,maxSTime,maxSize,maxLD),_)
win <- widgetGetDrawWindow pic
(cv@(vx,vy,vw,vh),cr@(ulx,uly,lrx,lry)) <- getCorners pic
let machines = machinelist events
maxTime = max_t events
maxSTime = max_t_diff events
numM = (fromIntegral (length machines))::Double
ySkip = (lry - uly) / numM
xSkip = (lrx - ulx)
sort = matrixM state
names = map (\m -> ('M':(show $ getIdM m))) machines
target $ do
translate visX visY
translate ulx (uly - ySkip)
scale xSkip ySkip
if locTime state
then drawLocalMachines machines sort
else drawGlobalMachines machines sort
let drawAxes = do
translate visX visY
drawTimes (autoTicks state) (tickSkip state) (tickMark state) (minTime,maxTime,maxSTime) (locTime state) cv cr color
translate 0 (uly)
drawNames (fromIntegral vx + ulx - 5) (lry-uly) (map (ySkip *) sort) names color
stroke
return drawAxes
where
minTime = min_t events
-- startup sync activated
drawLocalMachines, drawGlobalMachines :: [Machine] -> [Double] -> Render ()
drawLocalMachines (m:ms) (s:ss) = do
let diffTime = getDiffTime (getIdM m) (startupOffsets events) minTime
drawEvents (eventlistM m) 1 s diffTime
drawLocalMachines ms ss
drawLocalMachines _ _ = return ()
-- startup sync deactivated
drawGlobalMachines (m:ms) (s:ss) = do
drawEvents (eventlistM m) 1 s 0.0
drawGlobalMachines ms ss
drawGlobalMachines _ _ = return ()
drawEvents :: [MachineEvent] -> Double -> Double -> Double -> Render ()
drawEvents (e:es) oldSec line diff = case e of
(EndMachine sec) ->
drawEvents es (scaledTime (sec - diff)) line diff
(GCMachine sec _ _ _ l) -> do
let (newSec,evtColor,_,_) = getTimeAndColor
evtColor
rectangleLimited hideStartupPhase newSec barG (oldSec - newSec) (fromIntegral l * ldScale)
fill
drawEvents es newSec line diff
_ -> do
let (newSec,evtColor,u,d) = getTimeAndColor
evtColor -- set the right color
rectangleLimited hideStartupPhase newSec u (oldSec - newSec) d
fill
drawEvents es newSec line diff
where getTimeAndColor = case e of
RunningMachine sec -> (scaledTime (sec - diff), getColor statusRunning color,barO,barH)
SuspendedMachine sec -> (scaledTime (sec - diff), getColor statusSuspended color,barO,barH)
BlockedMachine sec -> (scaledTime (sec - diff), getColor statusBlocked color,barO,barH)
GCMachine sec _ _ _ _-> (scaledTime (sec - diff), getColor statusIdle color,barO,barH)
StartMachine sec -> (scaledTime (sec - diff), getColor statusIdle color,barP,barI)
IdleMachine sec -> (scaledTime (sec - diff), getColor statusIdle color,barP,barI)
_ -> trace ("getTimeAndColor: unknown case "++(show e)) (0, getColor chartBackground color, 0, 0)
barO = line + 0.2
barG = line + 0.9
barP = line + 0.5
drawEvents _ _ _ _ = return ()
barH = 0.7
barI = 0.4
ldScale = (-barH) / (maxLD events)
prepareBackground :: Double -> Double -> (Render () -> IO ()) -> DrawingArea -> Colors -> IO ()
prepareBackground visX visY target area colors = do
win <- widgetGetDrawWindow area
(w,h) <- widgetGetSize area
(_,(ulx,uly,lrx,lry)) <- getCorners area
let width = realToFrac w
height = realToFrac h
width' = width - 2 * border
height' = height - 2 * border
target $ do
translate visX visY
-- setLineWidth 1
-- Background
colorGray
rectangle 0 0 width height
fill
colorBlack
-- Shadow of paper
save
translate shadow shadow
rectangle border border width' height'
fill
restore
-- Paper
rectangle border border width' height'
stroke
getColor chartBackground colors
rectangle border border width' height'
fill
{-- Axis
colorBlack
moveTo (ulx - 10) lry
lineTo (lrx + 5) lry
stroke-}
return ()
where
-- create a dialog with a message (for errors and questions)
genericDialog :: String -> Bool -> IO Dialog
genericDialog msg err = do
dlg <- dialogNew
dialogSetHasSeparator dlg False
windowSetIconName dlg $ if err
then "gtk-dialog-error"
else "gtk-dialog-question"
upper <- dialogGetUpper dlg
label <- labelNew (Just msg)
labelSetJustify label JustifyCenter
miscSetPadding label 20 20
containerAdd upper label
return dlg
-- errorMessage:
-- opens a window and displays the given string as errormessage
errorMessage :: String -> IO ()
errorMessage e = do
dlg <- genericDialog e True
dialogAddButton dlg stockOk ResponseOk
afterResponse dlg (\_ -> widgetDestroy dlg)
widgetShowAll dlg
yesNoMessage :: String -> IO Bool
yesNoMessage e = do
dlg <- genericDialog e False
dialogAddButton dlg stockYes ResponseYes
dialogAddButton dlg stockNo ResponseNo
afterResponse dlg (\_ -> widgetDestroy dlg)
widgetShowAll dlg
response <- dialogRun dlg
case response of
ResponseYes -> return True
_ -> return False
drawStartupMarker :: Double -> Double -> Double -> (Render () -> IO ()) -> Events -> DrawingArea -> ViewerState -> Colors -> IO ()
drawStartupMarker pixelsPerSecond visX visY target events pic state colorsMap
= do
win <- widgetGetDrawWindow pic
(_,(ulx,uly,lrx,lry)) <- getCorners pic
drawMarker win pixelsPerSecond ulx uly (lry - uly)
where
--events was (_, _, (maxStartupTimeInSeconds,_),_ , (minTime, maxTime, maxSTime,_ ,_ ), _)
drawMarker :: DrawWindow -> Double -> Double -> Double -> Double -> IO ()
drawMarker win pixelsPerSecond ulx uly height = target $ do
translate visX visY
thickness <- getLineWidth
setLineWidth (thickness / 2)
translate ulx uly
getColor markerStartup colorsMap
let startupPositionInPx = getPosition (maxStartup events)
arrow startupPositionInPx (0) startupPositionInPx (height)
setLineWidth thickness
where
getPosition :: Double -> Double
getPosition seconds = seconds * pixelsPerSecond
arrow :: Double -> Double -> Double -> Double -> Render ()
arrow fromX fromY toX toY = do
moveTo fromX fromY
lineTo toX toY
arc toX toY 1.5 0 (2 * pi)
stroke
-- When hiding the startup-phase, the blue box of a machine might start before
-- the y-axis. This function makes sure that only the part right of the
-- y-axis is drawn.
rectangleLimited :: Bool -> Double -> Double -> Double -> Double -> Render()
rectangleLimited checkOverflow x y width height
| checkOverflow && (x < 0) = do
let newWidth = width + x
when (newWidth > 0) $ rectangle 0 y newWidth height
| otherwise = rectangle x y width height