poor mans concurrency

module Lab5 where

import Control.Monad

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

instance Functor Concurrent where
    fmap  = liftM

instance Applicative Concurrent where
    -- NB: DO NOT USE `pure = return`
    --pure  = return
    pure x = Concurrent (\c -> c x)

    (<*>) = ap  {- defined in Control.Monad -}
    -- or alternatively:
    --  f1 <*> f2 = f1 >>= \v1 -> f2 >>= (pure . v1)

    -- NB: DO NOT USE `(*>) = (>>)`
    --(*>) = {- move the definition of `>>` from the `Monad` instance here -}

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

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

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

action :: Concurrent a -> Action
action (Concurrent f) = f (\a->Stop) 

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

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


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

atom :: IO a -> Concurrent a
atom a =   Concurrent(\f -> Atom(do b <- a
                                    return (f b)))


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

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

par :: Concurrent a -> Concurrent a -> Concurrent a
par (Concurrent a) (Concurrent b) = Concurrent $ \c -> Fork (a c) (b c)




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

--blurg :: Concurrent ((a -> Action) -> Action) -> (a -> Concurrent ((b -> Action) -> Action)) ->  Concurrent ((b -> Action) -> Action)
--t -> t1 -> t3 -> (t3 -> t2) -> t2
--((t2 -> t1) -> t) -> (t2 -> t3 -> t1) -> t3 -> t
--blurg (Concurrent ma) f = Concurrent(\c -> ma (\a -> f a c))


--aa = (b->action) -> action 

blurrg ::  ((a -> Action) -> Action) -> (a -> ((b -> Action) -> Action))->  ((b -> Action) -> Action)
blurrg ma f = \c -> ma (\a ->  f a c)

blugh :: Concurrent a -> (a-> Concurrent b) -> Concurrent b
blugh  (Concurrent ma) f = Concurrent (\c -> ma (\a -> rc (f a) c))

rc (Concurrent h)  = h 

instance Monad Concurrent where
    (Concurrent ma) >>= f   = Concurrent (\c -> ma (\a -> rc (f a) c))
    return x = Concurrent (\c -> c x)


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

roundRobin :: [Action] -> IO ()
roundRobin [] = return ()
roundRobin(Atom io :xs) = io >>= \act -> roundRobin (xs++[act])
roundRobin(Fork a1 a2 : xs) = roundRobin (xs++[a1,a2])   
roundRobin (Stop : xs) = roundRobin xs  

-- ===================================
-- 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