never executed always true always false
1 -- StrobeClock.hs: Demonstrate hpc-strobe by rendering a crude analog
2 -- clock in the marked-up code
3 -- Copyright (c) 2009, Thorkil Naur
4 --
5 -- Usage: ./StrobeClock tixfile-directory
6 --
7 -- Note: The indicated tixfile-directory must exist.
8 --
9
10 module Main where
11
12 import System.Environment
13 import System.IO
14 import System.Time
15 import Control.Concurrent
16 import Data.List
17
18 import Trace.Hpc.Strobe
19
20 progName = "StrobeClock"
21 progStamp = "2009-May-08 17.26"
22
23 -- The clock will be rendered in the following part of the code. The
24 -- number of lines and their width may be adjusted; the width of the
25 -- shortest line will determine the width of the clock.
26
27 canvas x
28 = [
29 [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
30 , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
31 , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
32 , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
33 , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
34 , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
35 , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
36 , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
37 , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
38 , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
39 , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
40 , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
41 , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
42 , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
43 , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
44 , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
45 , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
46 , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
47 , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
48 , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
49 , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
50 , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
51 , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
52 , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
53 , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
54 , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
55 , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
56 , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
57 , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
58 , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
59 , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
60 , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
61 , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
62 , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
63 , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
64 , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
65 , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
66 , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
67 , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
68 , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
69 ]
70
71 -- Canvas dimensions:
72
73 pixelHeight = (length $ canvas 0) - 1
74 pixelWidth = minimum $ map ((subtract 1) . length) $ canvas 0
75
76 -- Defines the shape of pixels: To calibrate, measure the height and
77 -- width of a square part of the canvas as rendered and enter the
78 -- ratio here:
79
80 pixelHeightDividedByWidth = 16.2/17.4
81
82 -- World coordinate system is such that a 2x2 square with (0,0) in its
83 -- center fits exactly inside the canvas rectangle:
84
85 worldDimensions
86 = let
87 rawDimensions = [1.0,pixelHeightDividedByWidth]
88 in
89 map ((*2.0) . (/(minimum rawDimensions))) rawDimensions
90
91 worldLowerLeftCorner = map (negate . (/2.0)) worldDimensions
92
93 -- Converting between coordinate systems:
94
95 canvasToWorld [row,col]
96 = zipWith (+) worldLowerLeftCorner $ zipWith (*) worldDimensions
97 [fromIntegral col / fromIntegral pixelWidth,
98 1.0 - fromIntegral row / fromIntegral pixelHeight]
99
100 worldToCanvas wcs
101 = let
102 [c0,r0]
103 = zipWith (/) (zipWith (-) wcs worldLowerLeftCorner)
104 worldDimensions
105 in
106 [round $ (1.0 - r0) * fromIntegral pixelHeight,
107 round $ c0 * fromIntegral pixelWidth]
108
109 -- Shade outside unit circle:
110
111 circleShade
112 = filter ((>1.0) . sum . map (^2) . canvasToWorld)
113 [ [row,col] | row <- [0..pixelHeight], col <- [0..pixelWidth] ]
114
115 -- Line:
116
117 canvasLine [r1,c1] [r2,c2]
118 = if abs (r2 - r1) > abs (c2 - c1) then
119 map reverse $ canvasLine [c1,r1] [c2,r2]
120 else
121 if abs (c2 - c1) > 0 then
122 let
123 [(c1',r1'),(c2',r2')] = sort [(c1,r1),(c2,r2)]
124 in
125 [ [r,c] | c <- [c1'..c2'],
126 let r = r1' + (round $ fromIntegral (r2' - r1')
127 * fromIntegral (c - c1')
128 / fromIntegral (c2' - c1')) ]
129 else
130 [[r1,c1]]
131
132 worldLine [x1,y1] [x2,y2]
133 = canvasLine (worldToCanvas [x1,y1]) (worldToCanvas [x2,y2])
134
135 -- Piece of radial line, angle measured in degrees from vertical,
136 -- clockwise:
137
138 worldRadial angle from to
139 = let
140 radians = (90.0 - angle) / 180.0 * pi
141 [p1,p2]
142 = map (\t -> map (*t) [cos radians,sin radians]) [from,to]
143 in
144 worldLine p1 p2
145
146 -- Clock:
147
148 worldClockFixed
149 = concat [ worldRadial (fromIntegral a) 0.9 1.0
150 | a <- [30,60..360] ]
151 ++ concat [ worldRadial (fromIntegral a) 0.8 1.0
152 | a <- [90,180..360] ]
153 ++ circleShade
154
155 worldClockVariable h m s
156 = concat [ worldRadial ah 0.0 0.55 ]
157 ++ concat [ worldRadial (ah+4.0) 0.0 0.45 ]
158 ++ concat [ worldRadial (ah-4.0) 0.0 0.45 ]
159 ++ concat [ worldRadial am 0.0 0.9 ]
160 ++ concat [ worldRadial (am-2.5) 0.0 0.8 ]
161 ++ concat [ worldRadial (am+2.5) 0.0 0.8 ]
162 ++ concat [ worldRadial as (-0.15) 1.0 ]
163 where
164 as = fromIntegral s * (360.0/60.0)
165 m' = fromIntegral m + fromIntegral s / 60.0
166 am = m'*(360/60.0)
167 ah = (fromIntegral h + m'/60.0)*(360.0/12.0)
168
169 main'
170 = do
171 putStrLn $
172 progName ++ "(" ++ progStamp ++ "): Canvas pixel height "
173 ++ show pixelHeight ++ ", pixel width " ++ show pixelWidth
174 mapM_
175 (\n ->
176 do
177 clTime <- getClockTime
178 localTime@(CalendarTime{ctHour = hr,
179 ctMin = mn, ctSec = sc}) <- toCalendarTime clTime
180 let
181 timeStamp = calendarTimeToString localTime
182 in
183 do
184 putStrLn $ progName ++ "(" ++ progStamp ++ "): "
185 ++ (show $
186 sum [ ((canvas n)!!i)!!j
187 | [i,j] <- worldClockFixed
188 ++ worldClockVariable hr mn sc ])
189 threadDelay 950000
190 ) [1..]
191
192 mainArgsInterpret [tixfileDirectory]
193 = withStrobesWrittenRegularly tixfileDirectory progName 1000000
194 main'
195
196 mainArgsInterpret args
197 = error $ "Usage: \"./" ++ progName ++ " tixfile-directory\""
198
199 main
200 = do
201 hSetBuffering stdout NoBuffering
202 args <- getArgs
203 mainArgsInterpret args