{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module Lab5 where

import Control.Monad
import Control.Concurrent
import Control.Monad.Cont
import Control.Monad.Trans

data Action 
    = Atom (IO Action)
    | Fork Action Action
    | Stop

data Concurrent a = Concurrent ((a -> Action) -> Action)

instance Show Action where
    show (Atom x) = "atom"
    show (Fork x y) = "fork " ++ show x ++ " " ++ show y
    show Stop = "stop"

-- ===================================
-- Ex. 0
-- ===================================

fromConcurrent :: Concurrent a -> ((a -> Action) -> Action)
fromConcurrent (Concurrent a) = a

action :: Concurrent a -> Action
action a = fromConcurrent a (const Stop)


-- ===================================
-- Ex. 1
-- ===================================

stop :: Concurrent a
stop = Concurrent (\_ -> Stop)


-- ===================================
-- Ex. 2
-- ===================================

atom :: IO a -> Concurrent a
atom a = Concurrent (\k -> Atom (
                                    do
                                        x <- a
                                        return (k x)
                                ))


-- ===================================
-- Ex. 3
-- ===================================

fork :: Concurrent a -> Concurrent ()
fork a = Concurrent (\k -> Fork (action a) (k ()))

par :: Concurrent a -> Concurrent a -> Concurrent a
par a1 a2 = Concurrent (\k -> Fork (fromConcurrent a1 k) (fromConcurrent a2 k))


-- ===================================
-- Ex. 4
-- ===================================

--instance Monad Concurrent where
--    (Concurrent f) >>= g = Concurrent (\k -> f (\x -> fromConcurrent (g x) k))
--    return x = Concurrent (\c -> c x)

instance Monad Concurrent where
    f >>= g = Concurrent (\k -> (fromConcurrent f (\x -> (fromConcurrent (g x) k))))
    return x = Concurrent (\c -> c x)


-- ===================================
-- Ex. 5
-- ===================================

roundRobin :: [Action] -> IO ()

roundRobin [] = return ()

roundRobin (Atom m : as) = do
                                a' <- m
                                roundRobin $ as ++ [a']

roundRobin (Fork a1 a2 : as) = roundRobin $ as ++ [a1,a2]

roundRobin (Stop : as) = roundRobin as

-- ===================================
-- Tests
-- ===================================

ex0 :: Concurrent ()
ex0 = par (loop (genRandom 1337)) (loop (genRandom 2600) >> atom (putStrLn ""))

ex1 :: Concurrent ()
ex1 = do atom (putStr "Haskell")
         fork (loop $ genRandom 7331) 
         loop $ genRandom 42
         atom (putStrLn "")


-- ===================================
-- Helper Functions
-- ===================================

run :: Concurrent a -> IO ()
run x = roundRobin [action x]

genRandom :: Int -> [Int]
genRandom 1337 = [1, 96, 36, 11, 42, 47, 9, 1, 62, 73]
genRandom 7331 = [17, 73, 92, 36, 22, 72, 19, 35, 6, 74]
genRandom 2600 = [83, 98, 35, 84, 44, 61, 54, 35, 83, 9]
genRandom 42   = [71, 71, 17, 14, 16, 91, 18, 71, 58, 75]

loop :: [Int] -> Concurrent ()
loop xs = mapM_ (atom . putStr . show) xs

