hpc-strobe-0.1: demonstration/StrobeClock.hs

-- StrobeClock.hs: Demonstrate hpc-strobe by rendering a crude analog
-- clock in the marked-up code
-- Copyright (c) 2009, Thorkil Naur
--
-- Usage: ./StrobeClock tixfile-directory
--
-- Note: The indicated tixfile-directory must exist.
--

module Main where

  import System
  import IO
  import Time
  import Control.Concurrent
  import List

  import Trace.Hpc.Strobe

  progName = "StrobeClock"
  progStamp = "2009-May-08 17.26"

  -- The clock will be rendered in the following part of the code. The
  -- number of lines and their width may be adjusted; the width of the
  -- shortest line will determine the width of the clock.

  canvas x
    = [
          [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
        , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
        , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
        , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
        , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
        , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
        , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
        , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
        , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
        , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
        , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
        , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
        , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
        , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
        , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
        , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
        , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
        , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
        , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
        , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
        , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
        , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
        , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
        , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
        , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
        , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
        , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
        , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
        , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
        , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
        , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
        , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
        , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
        , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
        , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
        , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
        , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
        , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
        , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
        , [x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x,x]
      ]

  -- Canvas dimensions:

  pixelHeight = (length $ canvas 0) - 1
  pixelWidth = minimum $ map ((subtract 1) . length) $ canvas 0

  -- Defines the shape of pixels: To calibrate, measure the height and
  -- width of a square part of the canvas as rendered and enter the
  -- ratio here:

  pixelHeightDividedByWidth = 16.2/17.4

  -- World coordinate system is such that a 2x2 square with (0,0) in its
  -- center fits exactly inside the canvas rectangle:

  worldDimensions
    = let
        rawDimensions = [1.0,pixelHeightDividedByWidth]
      in
        map ((*2.0) . (/(minimum rawDimensions))) rawDimensions

  worldLowerLeftCorner = map (negate . (/2.0)) worldDimensions

  -- Converting between coordinate systems:

  canvasToWorld [row,col]
    = zipWith (+) worldLowerLeftCorner $ zipWith (*) worldDimensions
        [fromIntegral col / fromIntegral pixelWidth,
          1.0 - fromIntegral row / fromIntegral pixelHeight]

  worldToCanvas wcs
    = let
        [c0,r0]
          = zipWith (/) (zipWith (-) wcs worldLowerLeftCorner)
              worldDimensions
      in
        [round $ (1.0 - r0) * fromIntegral pixelHeight,
          round $ c0 * fromIntegral pixelWidth]

  -- Shade outside unit circle:

  circleShade
    = filter ((>1.0) . sum . map (^2) . canvasToWorld)
        [ [row,col] | row <- [0..pixelHeight], col <- [0..pixelWidth] ]

  -- Line:

  canvasLine [r1,c1] [r2,c2]
    = if abs (r2 - r1) > abs (c2 - c1) then
        map reverse $ canvasLine [c1,r1] [c2,r2]
      else
        if abs (c2 - c1) > 0 then
          let
            [(c1',r1'),(c2',r2')] = sort [(c1,r1),(c2,r2)]
          in
            [ [r,c] | c <- [c1'..c2'],
              let r = r1' + (round $ fromIntegral (r2' - r1')
                              * fromIntegral (c - c1')
                              / fromIntegral (c2' - c1')) ]
        else
          [[r1,c1]]

  worldLine [x1,y1] [x2,y2]
    = canvasLine (worldToCanvas [x1,y1]) (worldToCanvas [x2,y2])

  -- Piece of radial line, angle measured in degrees from vertical,
  -- clockwise:

  worldRadial angle from to
    = let
        radians = (90.0 - angle) / 180.0 * pi
        [p1,p2]
          = map (\t -> map (*t) [cos radians,sin radians]) [from,to]
      in
        worldLine p1 p2

  -- Clock:

  worldClockFixed
    = concat [ worldRadial (fromIntegral a) 0.9 1.0
               | a <- [30,60..360] ]
      ++ concat [ worldRadial (fromIntegral a) 0.8 1.0
                  | a <- [90,180..360] ]
      ++ circleShade

  worldClockVariable h m s
    = concat [ worldRadial ah 0.0 0.55 ]
      ++ concat [ worldRadial (ah+4.0) 0.0 0.45 ]
      ++ concat [ worldRadial (ah-4.0) 0.0 0.45 ]
      ++ concat [ worldRadial am 0.0 0.9 ]
      ++ concat [ worldRadial (am-2.5) 0.0 0.8 ]
      ++ concat [ worldRadial (am+2.5) 0.0 0.8 ]
      ++ concat [ worldRadial as (-0.15) 1.0 ]
      where
      as = fromIntegral s * (360.0/60.0)
      m' = fromIntegral m + fromIntegral s / 60.0
      am = m'*(360/60.0)
      ah = (fromIntegral h + m'/60.0)*(360.0/12.0)

  main'
    = do
        putStrLn $
          progName ++ "(" ++ progStamp ++ "): Canvas pixel height "
            ++ show pixelHeight ++ ", pixel width " ++ show pixelWidth
        mapM_
          (\n ->
            do
              clTime <- getClockTime
              localTime@(CalendarTime{ctHour = hr,
                ctMin = mn, ctSec = sc}) <- toCalendarTime clTime
              let
                timeStamp = calendarTimeToString localTime
                in
                  do
                    putStrLn $ progName ++ "(" ++ progStamp ++ "): "
                      ++ (show $
                            sum [ ((canvas n)!!i)!!j
                                  | [i,j] <- worldClockFixed
                                     ++ worldClockVariable hr mn sc ])
              threadDelay 950000
          ) [1..]

  mainArgsInterpret [tixfileDirectory]
    = withStrobesWrittenRegularly tixfileDirectory progName 1000000
        main'

  mainArgsInterpret args
    = error $ "Usage: \"./" ++ progName ++ " tixfile-directory\""

  main
    = do
        hSetBuffering stdout NoBuffering
        args <- getArgs
        mainArgsInterpret args