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 13 import IO 14 import Time 15 import Control.Concurrent 16 import 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