94 lines
3.2 KiB
Haskell
94 lines
3.2 KiB
Haskell
import Control.Concurrent
|
|
import Control.Concurrent.STM
|
|
import Control.Monad
|
|
import System.Random
|
|
|
|
santaThread :: TQueue String
|
|
-> TMVar [(String, TMVar ())]
|
|
-> TMVar [(String, TMVar ())]
|
|
-> IO ()
|
|
santaThread msgQueue reindeerVar elvesVar =
|
|
forever $ join $ atomically (deliver `orElse` review)
|
|
where
|
|
deliver = takeTMVar reindeerVar >>= \reindeer -> pure $ do
|
|
atomically $ writeTQueue msgQueue "Santa is delivering presents."
|
|
randomThreadDelay 2000000
|
|
atomically $ writeTQueue msgQueue "Santa is done delivering presents."
|
|
forM_ reindeer $ atomically . flip putTMVar () . snd
|
|
|
|
review = takeTMVar elvesVar >>= \elves -> pure $ do
|
|
atomically $ writeTQueue msgQueue $
|
|
"Santa is reviewing toy production with "
|
|
++ englishList (map fst elves) ++ "."
|
|
randomThreadDelay 350000
|
|
atomically $ writeTQueue msgQueue "Santa is done reviewing toy production."
|
|
forM_ elves $ atomically . flip putTMVar () . snd
|
|
|
|
reindeerThread :: TQueue String -> TQueue (String, TMVar ()) -> String -> IO ()
|
|
reindeerThread msgQueue reindeerQueue name = do
|
|
releasedVar <- newEmptyTMVarIO
|
|
forever $ do
|
|
randomThreadDelay 500000
|
|
atomically $ do
|
|
writeTQueue msgQueue (name ++ " is back from vacation.")
|
|
writeTQueue reindeerQueue (name, releasedVar)
|
|
atomically $ do
|
|
takeTMVar releasedVar
|
|
writeTQueue msgQueue (name ++ " is leaving for vacation.")
|
|
threadDelay 4500000
|
|
|
|
elfThread :: TQueue String -> TQueue (String, TMVar ()) -> String -> IO ()
|
|
elfThread msgQueue elvesQueue name = do
|
|
releasedVar <- newEmptyTMVarIO
|
|
forever $ do
|
|
randomThreadDelay 3000000
|
|
atomically $ do
|
|
writeTQueue msgQueue (name ++ " is in the waiting room.")
|
|
writeTQueue elvesQueue (name, releasedVar)
|
|
atomically $ do
|
|
takeTMVar releasedVar
|
|
writeTQueue msgQueue (name ++ " was dismissed.")
|
|
threadDelay 1000000
|
|
|
|
groupingAgent :: Int -> TQueue a -> TMVar [a] -> IO ()
|
|
groupingAgent n queue var = forever $ atomically $
|
|
replicateM n (readTQueue queue) >>= putTMVar var
|
|
|
|
englishList :: [String] -> String
|
|
englishList [] = "N/A"
|
|
englishList [x] = x
|
|
englishList [x,y] = x ++ " and " ++ y
|
|
englishList [x,y,z] = x ++ ", " ++ y ++ ", and " ++ z
|
|
englishList (x:xs) = x ++ ", " ++ englishList xs
|
|
|
|
randomThreadDelay maxDelay = threadDelay =<< randomRIO (0, maxDelay)
|
|
|
|
reindeerNames =
|
|
[ "Dasher", "Dancer", "Prancer"
|
|
, "Vixen", "Comet", "Cupid"
|
|
, "Donner", "Blitzen", "Rudolf"
|
|
]
|
|
|
|
elfNames =
|
|
[ "Llewellenar", "Taegen", "Skalanis", "Folluin", "Hubyr"
|
|
, "Velethuil", "Wyninn", "Jhaeros", "Luvon", "Cluym"
|
|
]
|
|
|
|
main = do
|
|
msgQueue <- newTQueueIO
|
|
reindeerQueue <- newTQueueIO
|
|
elvesQueue <- newTQueueIO
|
|
|
|
forM_ reindeerNames $ forkIO . reindeerThread msgQueue reindeerQueue
|
|
forM_ elfNames $ forkIO . elfThread msgQueue elvesQueue
|
|
|
|
reindeerVar <- newEmptyTMVarIO
|
|
elvesVar <- newEmptyTMVarIO
|
|
|
|
forkIO $ groupingAgent (length reindeerNames) reindeerQueue reindeerVar
|
|
forkIO $ groupingAgent 3 elvesQueue elvesVar
|
|
|
|
forkIO $ santaThread msgQueue reindeerVar elvesVar
|
|
|
|
forever $ putStrLn =<< atomically (readTQueue msgQueue)
|