
Task
Write a small program that emulates a nautical bell producing a ringing bell pattern at certain times throughout the day.

The bell timing should be in accordance with Greenwich Mean Time, unless locale dictates otherwise.

It is permissible for the program to daemonize, or to slave off a scheduler, and it is permissible to use alternative notification methods (such as producing a written notice "Two Bells Gone"), if these are more usual for the system type.



Related task

 Sleep


 
import Control.Concurrent
import Control.Monad
import Data.Time
import Text.Printf
 
type Microsecond = Int
type Scheduler = TimeOfDay -> Microsecond
 
-- Scheduling
--------------
 
getTime :: TimeZone -> IO TimeOfDay
getTime tz = do
    t  <- getCurrentTime
    return $ localTimeOfDay $ utcToLocalTime tz t
 
getGMTTime   = getTime utc
getLocalTime = getCurrentTimeZone >>= getTime
 
-- Returns the difference between 'y' and the closest higher multiple of 'x'
nextInterval x y
    | x > y = x - y
    | mod y x > 0 = x - mod y x
    | otherwise = 0
 
-- Given a interval in seconds, this function returns time delta in microseconds.
onInterval :: Int -> Scheduler
onInterval interval time = toNext dMS
  where
    toNext = nextInterval (1000000 * interval)
    tDelta = timeOfDayToTime time
    dMS    = truncate $ 1000000 * tDelta
 
doWithScheduler :: Scheduler -> (Int -> IO ()) -> IO ThreadId
doWithScheduler sched task = forkIO $ forM_ [0..] exec
  where
    exec n = do
        t <- getLocalTime
        threadDelay $ sched t
        task n
 
-- Output
---------
 
watchNames = words "Middle Morning Forenoon Afternoon Dog First"
countWords = words "One Two Three Four Five Six Seven Eight"
 
-- Executes IO action and then waits for n microseconds
postDelay n fn = fn >> threadDelay n
 
termBell        = putStr "\a"
termBells n     = replicateM_ n $ postDelay 100000 termBell
termBellSeq seq = forM_ seq $ postDelay 500000 . termBells
 
toNoteGlyph 1 = "♪"
toNoteGlyph 2 = "♫"
toNoteGlyph _ = ""
 
ringBells :: Int -> IO ()
ringBells n = do
    t <- getLocalTime
    let numBells    = 1 + (mod n 8)
        watch       = watchNames!!(mod (div n 8) 8)
        count       = countWords!!(numBells - 1)
        (twos,ones) = quotRem numBells 2
        pattern     = (replicate twos 2) ++ (replicate ones 1)
        notes       = unwords $ map toNoteGlyph pattern
        plural       = if numBells > 1 then "s" else ""
        strFMT      = show t ++ ": %s watch, %5s bell%s:  " ++ notes ++ "\n"
    printf strFMT watch count plural
    termBellSeq pattern
 
-- Usage
---------
 
bellRinger :: IO ThreadId
bellRinger = doWithScheduler (onInterval (30*60)) ringBells
 
 