{-#LANGUAGE FlexibleInstances, TypeSynonymInstances, TemplateHaskell #-}

import IO
import Control.Concurrent
import Control.Concurrent.STM
import Control.Monad 
import Control.Monad.Trans

import Join.Monads
import Debug.Trace


{-

Gossiping girls problem (found somewhere on the internet):

A number of girls initially know one distinct secret each. Each girl has access to a phone 
which can be used to call another girl to share their secrets. Each time two girls talk to each other 
they always exchange all secrets with each other (thus after the phone call they both 
know all secrets they knew together before the phone call). The girls can communicate 
only in pairs (no conference calls) but it is possible that different pairs of girls talk concurrently. 


-}



-----------------------------------
-- 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 = apply2 (\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]

-- secrets known -> new secrets known
$(syncChan "girlCall" [t| Secret -> Secret |])
$(asyncChan "girl" [t| (String,Secret) |])

-- we use synchronized method calls (which resembles an actual phone call,
-- two persons pick up the phone, after the call can go on and do their own stuff)

gossipGirlsRules o cnt = do
    n <- var
    [s1,s2] <- mapM (\_ -> var) [1..2]
    [r1,r2] <- mapM (\_ -> var) [1..2]

    -- two girls gossiping, they exchange their secrets which then
    -- unblocks the synchronized method calls
    def (girlCall s1 r1 & girlCall s2 r2 `onlyIf` newSecrets s1 s2) $ do
        s <- apply2 shareSecrets s1 s2
        reply s to r1
        reply s to r2

    def (girl (n,s1)) $ do
        initSecret <- value s1
        name <- value n
        let loop curSecret = do 
            newSecret <- call $ girlCall curSecret
            liftIO $ writeChan o $ name ++ " " ++ curSecret ++ " " ++ newSecret 
            when (allSecrets newSecret) $ liftIO $ do 
                atomically $ do
                    v <- readTVar cnt
                    writeTVar cnt (v+1)
                writeChan o $ 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
        loop initSecret

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

main = do
    cnt <- atomically $ newTVar 0
    output <- newChan

    withRules (gossipGirlsRules output cnt) $
        mapM (\(n,s) -> spawn $ girl (n,s)) 
            [ ("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
                    trace (show x) $ when (x < 5) retry
    putStr "Done"

    printOutput output 
    -- just testing