module Main where

import Singh.STMJoin
import Control.Concurrent.STM
import Control.Concurrent
import Control.Monad

type Secret = String

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

-- one of the two gets to know a new secret
newSecrets ((res1,s1), (res2,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]

rules girl girlCall o cnt = match [
    girlCall & girlCall ?? newSecrets >>> \ ((res1,s1), (res2,s2)) -> do
        let newS = shareSecrets s1 s2
        spawn res1 newS
        spawn res2 newS
    ,
    girl >>> \ (name,initSecret) -> do
        let loop curSecret = do 
            newSecret <- call girlCall curSecret
            writeChan o $ name ++ " " ++ curSecret ++ " " ++ newSecret 
            when (allSecrets newSecret) $ 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

    girl <- newTChanIO
    girlCall <- newTChanIO
    rules girl girlCall 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
                    when (x < 5) retry
    putStr "Done"

    printOutput output 
    -- just testing