1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
|
module GUI.Timeline.Activity (
renderActivity
) where
import GUI.Timeline.Render.Constants
import Events.HECs
import Events.EventTree
import Events.EventDuration
import GUI.Types
import GUI.ViewerColours
import Graphics.Rendering.Cairo
import Control.Monad
import Data.List
-- ToDo:
-- - we average over the slice, but the point is drawn at the beginning
-- of the slice rather than in the middle.
-----------------------------------------------------------------------------
renderActivity :: ViewParameters -> HECs -> Timestamp -> Timestamp
-> Render ()
renderActivity ViewParameters{..} hecs start0 end0 = do
let
slice = ceiling (fromIntegral activity_detail * scaleValue)
-- round the start time down, and the end time up, to a slice boundary
start = (start0 `div` slice) * slice
end = ((end0 + slice) `div` slice) * slice
hec_profs = map (actProfile slice start end)
(map (\ (t, _, _) -> t) (hecTrees hecs))
total_prof = map sum (transpose hec_profs)
-- liftIO $ printf "%s\n" (show (map length hec_profs))
-- liftIO $ printf "%s\n" (show (map (take 20) hec_profs))
drawActivity hecs start end slice total_prof
(if not bwMode then runningColour else black)
activity_detail :: Int
activity_detail = 4 -- in pixels
-- for each timeslice, the amount of time spent in the mutator
-- during that period.
actProfile :: Timestamp -> Timestamp -> Timestamp -> DurationTree -> [Timestamp]
actProfile slice start0 end0 t
= {- trace (show flat) $ -} chopped
where
-- do an extra slice at both ends
start = if start0 < slice then start0 else start0 - slice
end = end0 + slice
flat = flatten start t []
chopped0 = chop 0 start flat
chopped | start0 < slice = 0 : chopped0
| otherwise = chopped0
flatten :: Timestamp -> DurationTree -> [DurationTree] -> [DurationTree]
flatten _start DurationTreeEmpty rest = rest
flatten start t@(DurationSplit s split e l r _run _) rest
| e <= start = rest
| end <= s = rest
| start >= split = flatten start r rest
| end <= split = flatten start l rest
| e - s > slice = flatten start l $ flatten start r rest
| otherwise = t : rest
flatten _start t@(DurationTreeLeaf _) rest
= t : rest
chop :: Timestamp -> Timestamp -> [DurationTree] -> [Timestamp]
chop sofar start _ts
| start >= end = if sofar > 0 then [sofar] else []
chop sofar start []
= sofar : chop 0 (start+slice) []
chop sofar start (t : ts)
| e <= start
= if sofar /= 0
then error "chop"
else chop sofar start ts
| s >= start + slice
= sofar : chop 0 (start + slice) (t : ts)
| e > start + slice
= (sofar + time_in_this_slice t) : chop 0 (start + slice) (t : ts)
| otherwise
= chop (sofar + time_in_this_slice t) start ts
where
(s, e)
| DurationTreeLeaf ev <- t = (startTimeOf ev, endTimeOf ev)
| DurationSplit s _ e _ _ _run _ <- t = (s, e)
mi = min (start + slice) e
ma = max start s
duration = if mi < ma then 0 else mi - ma
time_in_this_slice t = case t of
DurationTreeLeaf ThreadRun{} -> duration
DurationTreeLeaf _ -> 0
DurationSplit _ _ _ _ _ run _ ->
round (fromIntegral (run * duration) / fromIntegral (e-s))
DurationTreeEmpty -> error "time_in_this_slice"
drawActivity :: HECs -> Timestamp -> Timestamp -> Timestamp -> [Timestamp]
-> Color
-> Render ()
drawActivity hecs start end slice ts color = do
case ts of
[] -> return ()
t:ts -> do
-- liftIO $ printf "ts: %s\n" (show (t:ts))
-- liftIO $ printf "off: %s\n" (show (map off (t:ts) :: [Double]))
let dstart = fromIntegral start
dend = fromIntegral end
dslice = fromIntegral slice
dheight = fromIntegral activityGraphHeight
-- funky gradients don't seem to work:
-- withLinearPattern 0 0 0 dheight $ \pattern -> do
-- patternAddColorStopRGB pattern 0 0.8 0.8 0.8
-- patternAddColorStopRGB pattern 1.0 1.0 1.0 1.0
-- rectangle dstart 0 dend dheight
-- setSource pattern
-- fill
newPath
moveTo (dstart-dslice/2) (off t)
zipWithM_ lineTo (tail [dstart-dslice/2, dstart+dslice/2 ..]) (map off ts)
setSourceRGBAhex black 1.0
setLineWidth 1
strokePreserve
lineTo dend dheight
lineTo dstart dheight
setSourceRGBAhex color 1.0
fill
-- funky gradients don't seem to work:
-- save
-- withLinearPattern 0 0 0 dheight $ \pattern -> do
-- patternAddColorStopRGB pattern 0 0 1.0 0
-- patternAddColorStopRGB pattern 1.0 1.0 1.0 1.0
-- setSource pattern
-- -- identityMatrix
-- -- setFillRule FillRuleEvenOdd
-- fillPreserve
-- restore
save
forM_ [0 .. hecCount hecs - 1] $ \h -> do
let y = fromIntegral (floor (fromIntegral h * dheight / fromIntegral (hecCount hecs))) - 0.5
setSourceRGBAhex black 0.3
moveTo dstart y
lineTo dend y
dashedLine1
restore
where
off t = fromIntegral activityGraphHeight -
fromIntegral (t * fromIntegral activityGraphHeight) /
fromIntegral (fromIntegral (hecCount hecs) * slice)
-- | Draw a dashed line along the current path.
dashedLine1 :: Render ()
dashedLine1 = do
save
identityMatrix
let dash = fromIntegral ox
setDash [dash, dash] 0.0
setLineWidth 1
stroke
restore
|
