{-# LANGUAGE PatternSignatures #-} import IO import Control.Concurrent import Control.Concurrent.STM import MultiSetRewrite.Base import MultiSetRewrite.RuleSyntax import MultiSetRewrite.RuleCompiler import MultiSetRewrite.StoreRepresentation import Join {- 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 :: Secret -> Secret -> Bool 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] newSecretsLifted s1 s2 = do v1 <- readVar s1 v2 <- readVar s2 return (newSecrets v1 v2) allSecretsLifted s = do v <- readVar s return (allSecrets v) girlPat x y z = method "Girl" (x,y,z) girlCall join x y = do r <- newSync call join "Girl" (x,y,r) v <- waitSync r return v -------------------------------------------------- -- Various solutions -------------------------------------------------- ---------------------------------------------------------------------------------- -- Solution I: -- 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 join activeMethod = do [n1,s1,n2,s2] <- mapM (\ _ -> newVar :: IO (VAR String)) [1..4] [r1,r2] <- mapM (\_ -> newVar :: IO (VAR (Sync String))) [1..2] let prog = compileRulePattern [ -- two girls gossiping, they exchange their secrets which then -- unblocks the synchronized method calls [girlPat n1 s1 r1, girlPat n2 s2 r2] `when` (newSecretsLifted s1 s2) .->. do [v_s1,v_s2] <- mapM (\x -> readVar x) [s1,s2] let s = shareSecrets v_s1 v_s2 r1 .=. s r2 .=. s ] res <- executeRules (store join) activeMethod prog case res of Just action -> action Nothing -> return () girl o cnt join name initSecret = let loop curSecret = do newSecret <- girlCall join name curSecret writeChan o $ name ++ " " ++ curSecret ++ " " ++ newSecret if (allSecrets newSecret) then do atomically $ do v <- readTVar cnt writeTVar cnt (v+1) writeChan o $ name ++ " Full" else return () 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 if b then return () else do w <- readChan o putStrLn w printOutput o test1 :: IO () test1 = do cnt <- atomically $ newTVar 0 jStore <- newJoinStore output <- newChan let join = Join {store = jStore, rules = gossipGirlsRules} mapM ( \ (n,s) -> forkIO $ girl output cnt join n s) [ ("Helga", "a"), ("Gertrud", "b"), ("Emmy", "c"), ("Ludmila", "d"), ("Karin", "a") ] -- each girl increments the center if all secrets are known atomically $ do x <- readTVar cnt if x >= 5 then return () else retry putStr "Done" printOutput output -- just testing ---------------------------------------------------------------------------------- -- Solution II: -- like in Solution I we use synchronized method calls -- but we only unblock the girl if she learns a new secret. -- We use propagation to model this behavior which means that -- a girl knowing all secrets can have two simulataneous calls -- with other girls who don't know all secrets yet. gossipGirlsRules2 join activeMethod = do [n1,s1,n2,s2] <- mapM (\ _ -> newVar :: IO (VAR String)) [1..4] [r1,r2] <- mapM (\_ -> newVar :: IO (VAR (Sync String))) [1..2] -- The rules are: -- (1) A girl knowing all secrets can simultaneously call one (or even more) -- girls which don't know all secrets yet. -- We use propagation to model this behaviour. -- NOTE: The call of the girl knowing all secrets won't unblock -- (2) Two girls can exchange their secrets if neither of them knows -- already all secrets and they each learn a new secret. let prog = compileRulePattern [ ([girlPat n1 s1 r1] .\. [girlPat n2 s2 r2]) `when` (do b1 <- allSecretsLifted s1 b2 <- newSecretsLifted s1 s2 return (b1 && b2)) .->. do [v_s1,v_s2] <- mapM (\x -> readVar x) [s1,s2] let s = shareSecrets v_s1 v_s2 r2 .=. s , [girlPat n1 s1 r1, girlPat n2 s2 r2] `when` (do b1 <- allSecretsLifted s1 b2 <- allSecretsLifted s2 b3 <- newSecretsLifted s1 s2 let b4 = (not $ b1 && b2) || b3 return b3) .->. do [v_s1,v_s2] <- mapM (\x -> readVar x) [s1,s2] let s = shareSecrets v_s1 v_s2 r1 .=. s r2 .=. s ] res <- executeRules (store join) activeMethod prog case res of Just action -> action Nothing -> return () -- NOTE: The counter cnt will go up to 5 max (if there are 5 girls) -- A girl knowing all secrets will block forever. girl2 o cnt join name initSecret = let loop curSecret = do newSecret <- girlCall join name curSecret writeChan o $ name ++ " " ++ curSecret ++ " " ++ newSecret if (allSecrets newSecret) then do atomically $ do v <- readTVar cnt writeTVar cnt (v+1) writeChan o $ name ++ " Full" else return () loop newSecret in loop initSecret test2 :: IO () test2 = do cnt <- atomically $ newTVar 0 jStore <- newJoinStore output <- newChan let join = Join {store = jStore, rules = gossipGirlsRules2} mapM ( \ (n,s) -> forkIO $ girl output cnt join n s) [ ("Helga", "a"), ("Gertrud", "b"), ("Emmy", "c"), ("Ludmila", "d"), ("Karin", "a") ] -- each girl increments the center if all secrets are known atomically $ do x <- readTVar cnt if x == 5 then return () -- good enough to check for 5, see NOTEs above else retry putStr "Done" printOutput output -- just testing