module Main where

import Control.Monad
import Control.Concurrent
import Control.Concurrent.MVar
import Control.Concurrent.STM

---------------------
-- secrets primitives

-- We assume that each secret is represent as a lower-case letter.
-- Hence, we can simply use strings to represent secrets

type Secret = String

-- four secrets
secretDB = ['a'..'d']

-- one of the two gets to know a new secret
newSecrets s1 s2 = not $ and $ [elem x s1 | x <- s2] ++ [elem x s2 | x <- s1]

shareSecrets :: Secret -> Secret -> Secret
shareSecrets s1 s2 = s1 ++ s2

allSecrets :: String -> Bool
allSecrets s = and $ [elem x s | x <- secretDB]

data PhoneComm = PhoneComm {
    left :: MVar Secret,
    right :: MVar Secret
    }

callOther name phonecomm secret = do
    b <- tryPutMVar (left phonecomm) secret
    if b then waitRight phonecomm
         else useRight phonecomm
    where waitRight pc = do
            othersSecret <- takeMVar (right pc)
            returnOrRetry othersSecret
          useRight pc = do
            putMVar (right pc) secret
            othersSecret <- takeMVar (left pc)
            returnOrRetry othersSecret
          returnOrRetry othersSecret = if newSecrets secret othersSecret
            then return $ shareSecrets secret othersSecret
            else callOther name phonecomm secret

girl name initSecret phonecomm cnt out =
    let loop curSecret = do
        newSecret <- callOther name phonecomm curSecret 
        writeChan out $ name ++ " " ++ curSecret ++ " " ++ newSecret 
        when (allSecrets newSecret) $ do 
            atomically $ do
                v <- readTVar cnt
                writeTVar cnt (v+1)
            writeChan out $ name ++ " Full"
        loop newSecret
        -- if a girl knows all secrets, other girls
        -- will still call her to obtain more secrets
        -- hence, we must attempt another call
    in loop initSecret

printOutput o = do
    b <- isEmptyChan o
    when (not b) $ do 
        w <- readChan o
        putStrLn w
        printOutput o

main :: IO ()
main = do
    cnt <- newTVarIO 0
    output <- newChan
    left <- newEmptyMVar
    right <- newEmptyMVar
    let phonecomm = PhoneComm left right

    mapM (\(n,s) -> forkIO $ girl n s phonecomm cnt output) 
        [ ("Helga", "a"),
        ("Gertrud", "b"),
        ("Emmy", "c"),
        ("Ludmila", "d"),
        ("Karin", "a") ]

    -- each girl increments the counter if all secrets are known
    atomically $ do x <- readTVar cnt
                    when (x < 5) retry
    putStr "Done"

    printOutput output 
    -- just testing