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)