77 lines
2.1 KiB
Haskell
77 lines
2.1 KiB
Haskell
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
|