packages feed

anticiv 0.1.0.4 → 0.1.0.5

raw patch · 8 files changed

+1565/−3 lines, 8 files

Files

+ Network/Anticiv/Config.hs view
@@ -0,0 +1,244 @@+module Network.Anticiv.Config where++import Control.Monad+import Data.Chatty.Atoms+import Data.Chatty.TST+import Data.List+import Text.Chatty.Parser+import Text.Chatty.Parser.Carrier+import Text.Chatty.Scanner+import Text.CTPL++data ValueRef = StrVal (Atom String) | IntVal (Atom Int) | StrList (Atom [String]) | Ctpl0 (Atom String) deriving Eq+data ValueTemp = StrValT String | IntValT Int | StrListT [String] | CtplT String | Ctpl0T String deriving (Eq,Show)+data Key = RefLeaf ValueRef | TempLeaf ValueTemp | Group Config | Module Config | Vocab Config++type Config = TST Key++instance Show ValueRef++parseConf :: ChParser m => m Config+parseConf = do+  keys <- many parseKey+  return $ foldr (uncurry tstInsert) EmptyTST keys++oneOf :: ChParser m => [Char] -> m Char+oneOf ks = do+  k <- request+  if k `elem` ks then return k else pabort++ident :: ChParser m => m String+ident = some $ oneOf (['A'..'Z']++['a'..'z']++"-")++parseKey :: ChParser m => m (String, Key)+parseKey = do+  let grabl = do+        k <- request+        if k=='\n' then pabort else return k+      comment = do+        many white+        matchs "#"+        many grabl+        match '\n'+  many comment+  parseLeaf ??? parseGroup ??? parseModule ??? parseVocab++parseLeaf :: ChParser m => m (String, Key)+parseLeaf = do+  many white+  nm <- ident+  many white+  match '='+  let parseInt = do+        many white+        ds <- some digit+        return $ IntValT $ foldl1 (\l r -> l*10+r) ds+      grabq = (do+        k <- request+        case k of+          '"' -> pabort+          '\\' -> do+            k <- request+            ks <- grabq+            return (k:ks)+          _ -> do+            ks <- grabq+            return (k:ks)) ?? return []+      parseStr = do+        many white+        match '"'+        ks <- grabq+        match '"'+        return $ StrValT ks+      parseStrList = do+        many white+        match '('+        many white+        strs <- many parseStr+        many white+        match ')'+        return $ StrListT $ map (\(StrValT s) -> s) strs+      parseCtpl = do+        many white+        matchs "CTPL"+        many white+        match '"'+        cs <- grabq+        match '"'+        return $ CtplT cs+      parseCtpl0 = do+        many white+        matchs "CTPL0"+        many white+        match '"'+        cs <- grabq+        match '"'+        return $ Ctpl0T cs+  v <- parseInt ?? parseStr ?? parseStrList ??? parseCtpl ??? parseCtpl0+  many white+  match ';'+  return (nm,TempLeaf v)++parseGroup :: ChParser m => m (String, Key)+parseGroup = do+  many white+  matchs "Group"+  many white+  nm <- ident+  many white+  match '{'+  sub <- parseConf+  many white+  match '}'+  return (nm,Group sub)++parseModule :: ChParser m => m (String, Key)+parseModule = do+  many white+  matchs "Module"+  many white+  nm <- ident+  many white+  match '{'+  sub <- parseConf+  many white+  match '}'+  return (nm,Module sub)++parseVocab :: ChParser m => m (String, Key)+parseVocab = do+  many white+  matchs "Vocab"+  many white+  nm <- ident+  many white+  match '{'+  sub <- parseConf+  many white+  match '}'+  return (nm,Vocab sub)++readConf :: (ChScanner m,ChAtoms m) => m (Maybe Config)+readConf = do+  inp <- mscanL+  case runCarrierT inp parseConf of+    [] -> return Nothing+    (c:_) -> tmap atomify c >>= return . Just++instance Functor TST where+  fmap f EmptyTST = EmptyTST+  fmap f (TST c Nothing l m r) = TST c Nothing (fmap f l) (fmap f m) (fmap f r)+  fmap f (TST c (Just h) l m r) = TST c (Just $ f h) (fmap f l) (fmap f m) (fmap f r)++tmap :: Monad m => (a -> m b) -> TST a -> m (TST b)+tmap _ EmptyTST = return EmptyTST+tmap f (TST c Nothing l m r) = do+  l' <- tmap f l+  m' <- tmap f m+  r' <- tmap f r+  return $ TST c Nothing l' m' r'+tmap f (TST c (Just h) l m r) = do+  l' <- tmap f l+  m' <- tmap f m+  r' <- tmap f r+  h' <- f h+  return $ TST c (Just h') l' m' r'++atomify :: ChAtoms m => Key -> m Key+atomify (RefLeaf r) = return $ RefLeaf r+atomify (Group c) = tmap atomify c >>= return . Group+atomify (Module c) = tmap atomify c >>= return . Module+atomify (Vocab c) = return $ Vocab c+atomify (TempLeaf (IntValT i)) = do+  a <- newAtom+  putAtom a i+  return $ RefLeaf $ IntVal a+atomify (TempLeaf (StrValT s)) = do+  a <- newAtom+  putAtom a s+  return $ RefLeaf $ StrVal a+atomify (TempLeaf (StrListT l)) = do+  a <- newAtom+  putAtom a l+  return $ RefLeaf $ StrList a+atomify (TempLeaf (CtplT s)) = do+  a <- newAtom+  case compileCTPL s of+    Succ s' -> putAtom a s'+    SyntaxFault -> error "Error compiling CTPL script: Syntax fault."+    NoSuchProc s -> error ("Error compiling CTPL script: No such proc: "++s)+  return $ RefLeaf $ Ctpl0 a+atomify (TempLeaf (Ctpl0T s)) = do+  a <- newAtom+  putAtom a s+  return $ RefLeaf $ Ctpl0 a++getKey :: String -> Config -> Maybe Key+getKey s cx = case p of+  [] -> Nothing+  (c:_) -> Just c+  where p = runCarrierT s $ do+          let leaf c = do+                nm <- ident+                case tstLookup nm c of+                  Just k@RefLeaf{} -> return k+                  Just k@TempLeaf{} -> return k+                  _ -> pabort+              modu c = do+                match '%'+                nm <- ident+                match '/'+                case tstLookup nm c of+                  Just (Module k) -> kget k+                  _ -> pabort+              group c = do+                nm <- ident+                match '/'+                case tstLookup nm c of+                  Just (Group k) -> kget k+                  _ -> pabort+              vocab c = do+                nm <- ident+                match ':'+                case tstLookup nm c of+                  Just (Vocab k) -> kget k+                  _ -> pabort+              kget c = leaf c ??? modu c ??? group c ??? vocab c+          kget cx++mgetKey :: String -> String -> Config -> Maybe Key+mgetKey m s c =+  case getKey ("%"++m++"/"++s) c of+    Just k -> Just k+    Nothing -> getKey s c++getFirstKey :: [String] -> Config -> Maybe Key+getFirstKey [] _ = Nothing+getFirstKey (k:ks) c+  | Just x <- getKey k c = Just x+  | otherwise = getFirstKey ks c++mgetFirstKey :: String -> [String] -> Config -> Maybe Key+mgetFirstKey m ks c = flip getFirstKey c $ do+  k <- ks+  ["%"++m++"/"++k, k]
+ Network/Anticiv/Modules/Barkeeper.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE ConstraintKinds, RankNTypes, FlexibleContexts #-}+module Network.Anticiv.Modules.Barkeeper (initBarkeeper, listBarkeeper) where++import Control.Monad+import Data.Char+import Data.Chatty.Atoms+import Data.Chatty.Hetero+import Network.Anticiv.Convenience+import Network.Anticiv.Masks+import Network.Anticiv.Monad+import Text.Printf++initBarkeeper :: Packciv (Packciv [String])+initBarkeeper = do+  regPriorityChanmsg msg+  return listBarkeeper++listBarkeeper :: Packciv [String]+listBarkeeper = return ["beer","vodka","vplus"]+  +msg :: Atom Handler -> UserA -> String -> Anticiv Bool+msg _ u s = do+  pref <- bprefix+  s & pref :-: LocalT u "beer" :-: ChannelUser #-> (actionfl "Beer" . userNick <=< getAtom)+   .|| pref :-: LocalT u "vodka" :-: ChannelUser #-> (actionfl "Vodka" . userNick <=< getAtom)+   .|| pref :-: LocalT u "vplus" :-: ChannelUser #->> addressfl u "VPlus"
+ Network/Anticiv/Modules/Base.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE ConstraintKinds, RankNTypes, FlexibleContexts, IncoherentInstances #-}+module Network.Anticiv.Modules.Base (initBase,listBase) where++import Control.Monad+import Data.Char+import Data.Chatty.Atoms+import Data.Chatty.AVL+import Data.Chatty.Hetero+import Network.Anticiv.Convenience+import Network.Anticiv.Masks+import Network.Anticiv.Monad+import Text.Printf++initBase :: Packciv (Packciv [String])+initBase = do+  regPriorityChanmsg $ msg False addressfl+  regPriorityQuerymsg $ msg True privatefl+  return listBase++listBase :: Packciv [String]+listBase = return ["hello", "about", "echo", "translate","reauth"]++msg :: Bool -> Speaker -> HandlerA -> UserA -> String -> Anticiv Bool+msg p speak _ u s = do+  pref <- bprefix+  s & pref :-: LocalT u "hello" :-: ChannelUser #-> (\t -> speak t "Hello" . userNick =<< getAtom t)+   .|| pref :-: LocalT u "about" :-: ChannelUser #-> (getAtom >=> \t -> speak u "About" (userNick t) (show t))+   .|| pref :-: LocalT u "echo" :-: Remaining #-> (\t -> speak u "Id" $ dropWhile isSpace t)+   .|| pref :-: LocalT u "translate" :-: Remaining #-> translate p speak u+   .|| pref :-: LocalT u "reauth" :-: CatchInt :-: CatchInt :-: Remaining #-> \(ai,t,_) -> reauth speak u (Atom ai) t++translate :: Bool -> Speaker -> UserA -> String -> Anticiv ()+translate False speak u li = do+  bmodify $ \b -> b{botLingua=dropWhile isSpace li}+  globalfl "Speaks"+translate True speak u li = do+  bmodify $ \b -> b{linguaOverride=avlInsert (u,dropWhile isSpace li) $ linguaOverride b}+  speak u "Speaks"++reauth :: Speaker -> UserA -> UserA -> Int -> Anticiv ()+reauth speak u ai t = do+  cus <- bgets channelUsers+  case ai `elem` cus of+    False -> speak u "ReauthFail"+    _ -> do+      u' <- getAtom u+      i' <- getAtom ai+      if reauthId i' /= t+         then speak u "ReauthFail"+         else do+           putAtom u i'{reauthId = reauthId u'}+           putAtom ai u'{reauthId = reauthId i'}+           speak ai "Reauthed"
+ Network/Anticiv/Modules/Ironforge.hs view
@@ -0,0 +1,233 @@+{-# LANGUAGE ConstraintKinds, RankNTypes, FlexibleContexts, IncoherentInstances, TemplateHaskell, TypeSynonymInstances, MultiParamTypeClasses #-}+module Network.Anticiv.Modules.Ironforge (initIronforge,listIronforge) where++import Prelude hiding (log)+import Control.Monad+import Control.Monad.Trans.Class+import Data.Char+import Data.Dynamic+import Data.Time.Clock+import Data.Typeable+import qualified Game.Antisplice as A+import Game.Antisplice.Dungeon.Ironforge+import Game.Antisplice.Errors+import Game.Antisplice.Lang+import qualified Game.Antisplice.Monad.Dungeon as D+import qualified Game.Antisplice.Monad.Vocab as V+import Game.Antisplice.Rooms+import Game.Antisplice.Templates+import Data.Chatty.Atoms+import Data.Chatty.AVL+import Data.Chatty.Counter+import Data.Chatty.Fail+import Data.Chatty.Hetero+import Data.Chatty.None+import Data.Chatty.TST+import Network.Anticiv.Convenience+import Network.Anticiv.Masks+import Network.Anticiv.Monad+import System.Chatty.Misc+import Text.Chatty.Channel.Printer+import Text.Chatty.Expansion+import Text.Chatty.Expansion.Vars+import Text.Chatty.Extended.Printer+import Text.Chatty.Interactor+import Text.Chatty.Interactor.Templates+import Text.Chatty.Printer+import Text.Chatty.Scanner+import Text.Printf++data ModState = ModState {+    runningGames :: AVL (UserA,PartyState)+  }+type PartySession = ((((D.DungeonState,TST V.Token),AVL (Int,Container)),Int),[(String,EnvVar)])+data PartyState = PartyState {+    ticker :: Atom (Packciv ()),+    lastTickReport :: NominalDiffTime,+    partySession :: PartySession+  } | NoParty++initIronforge :: Packciv (Packciv [String])+initIronforge = Anticiv $ do+  a <- newAtom+  putAtom a $ ModState EmptyAVL+  regPriorityQuerymsg $ msg a+  return listIronforge++listIronforge :: Packciv [String]+listIronforge = Anticiv $ return ["start"]++pget :: Atom ModState -> UserA -> Anticiv PartyState+pget a u = do+  ms <- getAtom a+  case avlLookup u $ runningGames ms of+    Just p@PartyState{} -> return p+    _ -> do+           t <- regTickRecipient $ {-tick a u-} \_ -> return ()+           liftM (PartyState t 0) $ do+             p <- startSession ironforge+             liftM (snd.unjust) $ runSession p prompt+  where unjust (Just k) = k++pgets :: Atom ModState -> UserA -> (PartyState -> a) -> Anticiv a+pgets a u f = liftM f $ pget a u++pmodify :: Atom ModState -> UserA -> (PartyState -> PartyState) -> Anticiv ()+pmodify a u f = do+  ms <- getAtom a+  p <- pget a u+  putAtom a ms{runningGames=avlInsert (u,f p) $ runningGames ms}++cleanup :: UserA -> Anticiv a -> Anticiv a+cleanup u m = do+  (a,r) <- runRecorderT $ runJoinerT m+  let clean = mscannable >>= \b -> when b $ do+        ln <- mscanLn+        let ln' = if null ln then " " else ln+        u' <- getAtom u+        cprint (Target $ userNick u') (ln'++"\r\n")+        cprint Log ("Ironforge ["++userNick u'++"]: "++ln++"\r\n")+        clean+  clean .<<. replay r+  return a++msg :: Atom ModState -> HandlerA -> UserA -> String -> Anticiv Bool+msg a _ u s = cleanup u $ do+  pref <- bprefix+  s & pref :-: LocalT u "start" :-: Remaining #->> do+    pmodify a u id+    void $ regPriorityQuerymsg $ imsg u a++imsg :: UserA -> Atom ModState -> HandlerA -> UserA -> String -> Anticiv Bool+imsg du a h u s = guardUser $ cleanup u $ do+  ss <- pgets a u partySession+  ss' <- runSession ss $ do+    runScheduledTasks+    act s+    prompt+  case ss' of+    Just (_,ss') -> pmodify a u $ \p -> p{partySession=ss'}+    Nothing -> do+      unregTickRecipient =<< pgets a u ticker+      pmodify a u $ const NoParty+      unregPriorityQuerymsg h+  return True+  where guardUser m +          | du == u = m+          | otherwise = return False++tick :: Atom ModState -> UserA -> AnticivA () -> Anticiv ()+tick a u h = do+  ss <- pgets a u partySession+  ss' <- cleanup u $ runSession ss runScheduledTasks+  case ss' of+    Just (_,ss') -> do+      pmodify a u $ \p -> p{partySession=ss'}+      let ((((d,vs),as),c),es) = ss+      tm <- pgets a u lastTickReport+      tm' <- mgetstamp+      u' <- getAtom u+      when (tm' > tm + fromIntegral (2 :: Int)) $ do+        log $ printf "Ironforge AtomStore for %s: %i" (userNick u') (avlSize as)+        log $ printf "Ironforge Counter for %s: %i" (userNick u') c+        log $ printf "Ironforge Time Triggers for %s: %i" (userNick u') (avlSize $ D.timeTriggersOf d)+        pmodify a u $ \p -> p{lastTickReport=tm'}+    Nothing -> return ()++prompt :: D.ChattyDungeonM ()+prompt = mprintLn =<< expand =<< expand "[$prompt]"++newtype MonoPrinterT m a = MonoPrinter { runMonoPrinter :: m a }++instance Monad m => Monad (MonoPrinterT m) where+  return = MonoPrinter . return+  (MonoPrinter m) >>= f = MonoPrinter $ m >>= runMonoPrinter . f++instance Functor m => Functor (MonoPrinterT m) where+  fmap f (MonoPrinter m) = MonoPrinter $ fmap f m++instance MonadTrans MonoPrinterT where+  lift = MonoPrinter++instance ChPrinter m => ChPrinter (MonoPrinterT m) where+  mprint = lift . mprint++instance ChPrinter m => ChExtendedPrinter (MonoPrinterT m) where+  estart _ = return ()+  efin = return ()++instance (Functor m,ChExpand m) => ChExpand (MonoPrinterT m) where+  expand = lift . expand <=< liftM (replay.snd) . runRecorderT . runMonoPrinter . expandClr++type DPlayerId = D.PlayerId++withSession :: (ChClock m,ChRandom m,ChPrinter m) => PartySession -> D.ChattyDungeonM a -> m (Either SplErr (a,PartySession))+withSession ((((s,ts),as),c),es) m =+  runJoinerT $+  runNullExpanderT $+  liftM rot $ flip runExpanderT es $+  runMonoPrinter $+  liftM rot $ flip runCounterT c $+  liftM rot $ flip runAtomStoreT as $+  liftM rot $ flip V.runVocabT ts $+  runFailT $+  flip D.runDungeonT s m+  where unjust (Just j) = j++startSession :: (ChClock m,ChRandom m,ChPrinter m) => A.Constructor () -> m PartySession+startSession init = do+  Right (_,x) <- withSession ((((none,defVocab),none),0),none) $ do+    init+    reenterCurrentRoom+    D.roomTriggerOnAnnounceOf =<< D.getRoomState+    D.roomTriggerOnLookOf =<< D.getRoomState+  return x++rot :: (Either x (a,b),c) -> Either x (a,(b,c))+rot (Right (a,b),c) = Right (a,(b,c))+rot (Left e,_) = Left e++runScheduledTasks :: D.ChattyDungeonM ()+runScheduledTasks = do+  now <- mgetstamp+  ds <- D.getDungeonState+  let ts = takeWhile ((<now).fst) $ avlInorder $ D.timeTriggersOf ds+  D.putDungeonState ds{D.timeTriggersOf=foldr avlRemove (D.timeTriggersOf ds) $ map fst ts}+  forM_ ts (D.runHandler . snd)++runSession :: (ChClock m,ChRandom m,ChPrinter m) => PartySession -> D.ChattyDungeonM a -> m (Maybe (a,PartySession))+runSession p m = do+  x <- withSession p m+  case x of+    Right r -> return $ Just r+    Left e -> do+      mprintLn $ case e of+        VerbMustFirstError -> "Please start with a verb."+        UnintellegibleError -> "I don't understand that."+        CantWalkThereError -> "I can't walk there."+        WhichOneError -> "Which one do you mean?"+        CantSeeOneError -> "I can't see one here."+        DontCarryOneError -> "You don't carry one."+        CantEquipThatError -> "I can't equip that."+        CantEquipThatThereError -> "I can't wear that there. You might want to try some other place?"+        WhereToEquipError -> "Where?"+        CantCastThatNowError -> "Sorry, I can't cast that now. Check your health, mana and cooldowns."+        CantAcquireThatError -> "I can't take that."+        WontHitThatError -> "I won't hit that."+        ReError (Unint _ s) -> s+        ReError (Uncon s) -> s+        _ -> ""+      case e of+        QuitError -> return Nothing+        _ -> return $ Just (undefined,p)++mkInteractor ''MonoPrinterT mkScanner mkRandom mkClock mkExpanderEnv (mkChannelPrinter ''DPlayerId)+mkInteractor ''HereStringT (mkChannelPrinter ''Target)++instance MonadBot m => MonadBot (RecorderT m) where+  bget = lift bget+  bput = lift . bput++instance MonadBot m => MonadBot (JoinerT m) where+  bget = lift bget+  bput = lift . bput
+ Network/Anticiv/Modules/Mafia.hs view
@@ -0,0 +1,483 @@+{-# LANGUAGE ConstraintKinds, RankNTypes, FlexibleContexts, TupleSections #-}+module Network.Anticiv.Modules.Mafia (initMafia,listMafia) where++import Prelude hiding (log)+import Control.Monad+import Data.Char+import Data.Dynamic+import Data.List+import Data.Chatty.Atoms+import Data.Chatty.AVL+import Data.Chatty.Hetero+import Data.Chatty.None+import Network.Anticiv.Convenience+import Network.Anticiv.Masks+import Network.Anticiv.Modules.Mafia.Core+import Network.Anticiv.Modules.Mafia.Data+import Network.Anticiv.Monad+import Text.Chatty.Printer+import Text.Chatty.Channel.Printer+import Text.Printf++type Lister = Packciv [String]+type ListerA = Atom Lister++initMafia :: Packciv Lister+initMafia = do+  let ilist = return ["peng","mafia"] :: Lister+  la <- newAtom+  regPriorityChanmsg $ chanmsg la+  regPriorityChanmsg $ idlemsg la+  ilist #> la+  return $ listMafia la++listMafia :: ListerA -> Lister+listMafia a = join $ getAtom a++chanmsg :: ListerA -> HandlerA -> UserA -> String -> Anticiv Bool+chanmsg l _ u s = do+  pref <- bprefix+  s & pref :-: CIToken "peng" :-: Remaining #->> address u "Peng!"+   .|| pref :-: LocalT u "theme" :-: Remaining #-> bsetStereo . dropWhile isSpace++idlemsg :: ListerA -> HandlerA -> UserA -> String -> Anticiv Bool+idlemsg l h u s = do+  pref <- bprefix+  s & pref :-: LocalT u "mafia" :-: Remaining #->> do+    -- Tell the channel about it+    getAtom u >>= globalfl "StartCollection" . userNick :: Anticiv ()+    -- Create the party state and add the initiator to its user list+    ma <- newAtom+    MafiaState u none none none False False 0 none none none True none #> ma+    joinParty ma u+    -- Readjust chanmsg handlers+    unregPriorityChanmsg h+    regPriorityChanmsg $ collmsg ma l+    return ["peng","join","go"] #> l+    return ()++collmsg :: MafiaStateA -> ListerA -> HandlerA -> UserA -> String -> Anticiv Bool+collmsg m l h u s = do+  pref <- bprefix+  s & "ME" :-: LocalT u "join" :-: Remaining #->> do+    getAtom u >>= globalfl "JoinsAnnounce" . userNick :: Anticiv ()+    joinParty m u+    return ()+   .|| LocalT u "go" :-: Token "!" :-: Remaining #->> (withInitiator m u $ \pid -> do+    ps <- mafiaPlayers #< m+    -- Check player count+    let pc = avlSize ps+    unless (pc >= 6) $ addressfl u "NotEnoughPlayers" pc (6 :: Int)+    when (pc >= 6) $ do+      -- Tell the channel about it+      globalfl "StartingParty" $ avlSize ps :: Anticiv ()+      -- Assign roles+      assignRoles m+      -- Set modes+      ch <- bchan+      cbracket Raw $ do+        mprint ("MODE "++ch++" +m\r\n")+        forAllPlayers_ m $ \pid -> do+          u <- userNick #< fromPID pid+          mprint ("MODE "++ch++" +v "++u++"\r\n")+      forAllPlayers_ m $ \pid -> do+        -- Tell roles+        (r:_) <- playerRoles &< (m, pid)+        cs <- playerCards &< (m, pid)+        forM cs $ \(Card s v) -> privatefl (fromPID pid) "TellCard" (Lookup "Cards/Pattern") (Lookup ("Cards/"++show s)) (Lookup ("Cards/"++show v)) :: Anticiv ()+        privatefl (fromPID pid) ("Explain/"++show r) :: Anticiv ()+        u <- userNick #< fromPID pid+        log $ printf "%s: %s" u $ show r+        -- Tell Mafia partners+        case r of+          MafiaK _ ->+            forAllMafiosi_ m $ \pid' -> unless (pid == pid') $ do+              u <- userNick #< fromPID pid'+              r:_ <- playerRoles &< (m,pid')+              privatefl (fromPID pid) "CoMafioso" u $ Lookup ("RoleNames/"++show r)+          TriadK _ ->+            forAllTriadists_ m $ \pid' -> unless (pid == pid') $ do+              u <- userNick #< fromPID pid'+              r:_ <- playerRoles &< (m,pid')+              privatefl (fromPID pid) "CoMafioso" u $ Lookup ("RoleNames/"++show r)+          _ -> return ()+      unregPriorityChanmsg h+      h' <- regPriorityQuerymsg $ maffmsg m l+      h'' <- regPriorityChanmsg $ nightchanmsg m l+      m <># \m -> m{lostHandlers=h':h'':lostHandlers m}+      -- Reauth Hints+      basepref <- switchTo "Base" $ bkStr "Prefix"+      forAllPlayers m $ \pid -> do+        let Atom a = fromPID pid+        tkn <- reauthId #< fromPID pid+        privatefl (fromPID pid) "ReauthHint" basepref a tkn :: Anticiv ()+      night m l)++night :: MafiaStateA -> ListerA -> Anticiv ()+night m l = do+  globalfl "Sunset" :: Anticiv ()+  regPriorityQuerymsg $ nightmsg m l+  m <># \m -> m{voteScore=none,+                votedAlready=none,+                mafiaDone=False,+                triadDone=False,+                partyDay=partyDay m+1,+                actionsDone=none,+                safeTonight=none,+                isNight=True}+  nday <- partyDay #< m+  when (nday==1) $ forAllPred_ m (==CivicK Cupid) $ \pid -> privatefl (fromPID pid) "CupidHint" :: Anticiv ()+  forAllMafiosi_ m $ \pid -> privatefl (fromPID pid) "MafiaHint" :: Anticiv ()+  forAllTriadists_ m $ \pid -> privatefl (fromPID pid) "MafiaHint" :: Anticiv ()+  forAllPred_ m (==CivicK Inspector) $ \pid -> privatefl (fromPID pid) "InspHint" :: Anticiv ()+  forAllPred_ m (==MafiaK Spy) $ \pid -> privatefl (fromPID pid) "InspHint" :: Anticiv ()+  forAllPred_ m (==TriadK TriSpy) $ \pid -> privatefl (fromPID pid) "InspHint" :: Anticiv ()+  forAllPred_ m (==CivicK Detective) $ \pid -> privatefl (fromPID pid) "DeteHint" :: Anticiv ()+  forAllPred_ m (==CivicK SoulSaver) $ \pid -> privatefl (fromPID pid) "SoulSaverHint" :: Anticiv ()+  return ()++nightmsg :: MafiaStateA -> ListerA -> HandlerA -> UserA -> String -> Anticiv Bool+nightmsg m l h u s = do+  pref <- bprefix+  s & "ME" :-: LocalT u "vote" :-: ChannelUser #-> (\t -> do+    u' <- userNick #< u+    t' <- userNick #< t+    withAlivePID m u $ \pid -> do+      maff <- isMafioso m pid+      when maff $ do+        withAlivePID m t $ \pit -> do+          b <- playerVote m pid pit MafiaKill privatefl+          when b $+            forAllMafiosi_ m $ \pid' ->+            unless (pid == pid') $+            privatefl (fromPID pid') "VotesFor" u' t'+      tri <- isTriadist m pid+      when tri $ do+        withAlivePID m t $ \pit -> do+          b <- playerVote m pid pit TriadKill privatefl+          when b $+            forAllTriadists_ m $ \pid' ->+            unless (pid == pid') $+            privatefl (fromPID pid') "VotesFor" u' t'+      unless (maff || tri) $ privatefl u "NotPermitted"+      vs <- forAllMafiosi m $ \p -> hasVoted m p MafiaKill+      when (and vs) $ do+        m <># \m -> m{mafiaDone=True}+      vt <- forAllTriadists m $ \p -> hasVoted m p TriadKill+      when (and vt) $ do+        m <># \m -> m{triadDone=True}+      tryevalnight m l h)+   .|| "ME" :-: LocalT u "observe" :-: ChannelUser #-> (\t -> do+    t' <- userNick #< t+    withAlivePID m u $ \pid -> do+      detes <- seekUnusedRole m Detective+      unless (pid `elem` detes) $ privatefl u "NotPermitted" :: Anticiv ()+      when (pid `elem` detes) $ do+        withAlivePID m t $ \pit -> do+          o <- (m,pit) %|& observation+          privatefl u ("Is"++show o) t' :: Anticiv ()+          actionDone m pid Detective+    tryevalnight m l h)+   .|| "ME" :-: LocalT u "inspect" :-: ChannelUser #-> (\t -> do+    t' <- userNick #< t+    withAlivePID m u $ \pid -> do+      insps <- seekUnusedRole m Inspector+      spies <- seekUnusedRole m Spy+      trsps <- seekUnusedRole m TriSpy+      let ainsp = insps ++ spies ++ trsps+      unless (pid `elem` ainsp) $ privatefl u "NotPermitted" :: Anticiv ()+      when (pid `elem` ainsp) $ do+        withAlivePID m t $ \pit -> do+          o <- (m,pit) %|& show+          privatefl u "Inspection" t' $ Lookup ("RoleNames/"++o) :: Anticiv ()+          actionDone m pid $+            if pid `elem` insps+              then CivicK Inspector+              else if pid `elem` spies+                      then MafiaK Spy+                      else TriadK TriSpy     +    tryevalnight m l h)      +   .|| "ME" :-: LocalT u "save" :-: ChannelUser #-> (\t -> do+    t' <- userNick #< t+    withAlivePID m u $ \pid -> do+      savers <- seekUnusedRole m SoulSaver+      unless (pid `elem` savers) $ privatefl u "NotPermitted" :: Anticiv ()+      when (pid `elem` savers) $ do+        withAlivePID m t $ \pit -> do+          o <- playerSaved &< (m,pit)+          when o $ privatefl u "NotPermitted" :: Anticiv ()+          unless o $ do+            m <># \m -> m{safeTonight=pit:safeTonight m}+            (m,pit) <>& \t -> t{playerSaved=True}+            privatefl u "Safe" t' :: Anticiv ()+            actionDone m pid SoulSaver+    tryevalnight m l h)+   .|| "ME" :-: LocalT u "couple" :-: ChannelUser :-: LocalT u "and" :-: ChannelUser #-> (\(a,b) -> do+    a' <- userNick #< a+    b' <- userNick #< b+    withAlivePID m u $ \pid -> do+      nday <- partyDay #< m+      unless (nday == 1) $ privatefl u "NotPermitted" :: Anticiv ()+      when (nday == 1) $ withAlivePID m a $ \pa -> withAlivePID m b $ \pb -> do+        cupids <- seekUnusedRole m Cupid+        unless (pid `elem` cupids) $ privatefl u "NotPermitted" :: Anticiv ()+        when (pid `elem` cupids) $ do+          m <># \m -> m{coupledPlayers=Just (pa,pb)}+          ar <- (m,pa) %|& id+          br <- (m,pb) %|& id+          privatefl a "InLoveWith" b' :: Anticiv ()+          privatefl a "Inspection" b' $ Lookup ("RoleNames/"++show br) :: Anticiv ()+          privatefl b "InLoveWith" a' :: Anticiv ()+          privatefl b "Inspection" a' $ Lookup ("RoleNames/"++show ar) :: Anticiv ()+          actionDone m pid Cupid+          unless (ar `winsWith` br) $ do+            (m,pa) <>& \p -> p{playerRoles=CoupleK InLove : playerRoles p}+            (m,pb) <>& \p -> p{playerRoles=CoupleK InLove : playerRoles p}+            privatefl a "CoupleFaction" :: Anticiv ()+            privatefl b "CoupleFaction" :: Anticiv ()+    tryevalnight m l h)+    +tryevalnight :: MafiaStateA -> ListerA -> HandlerA -> Anticiv ()+tryevalnight m l h = do+  maffsdone <- mafiaDone #< m+  when maffsdone $ log "Mafia is done."+  triaddone <- triadDone #< m+  when triaddone $ log "Triad is done."+  detesdone <- liftM null $ seekUnusedRole m Detective+  when detesdone $ log "Detes are done."+  spiesdone <- liftM null $ seekUnusedRole m Spy+  when spiesdone $ log "Spies are done."+  trspsdone <- liftM null $ seekUnusedRole m TriSpy+  when trspsdone $ log "TriSpies are done."+  inspsdone <- liftM null $ seekUnusedRole m Inspector+  when inspsdone $ log "Inspis are done."+  saversdone <- liftM null $ seekUnusedRole m SoulSaver+  when saversdone $ log "Savers are done."+  cupiddone <- (||) `liftM` (liftM (/=1) $ partyDay #< m) `ap` (liftM null $ seekUnusedRole m Cupid)+  when cupiddone $ log "Cupid is done."+  let alldone = and [maffsdone, detesdone, spiesdone, inspsdone+                    ,saversdone, triaddone, trspsdone, cupiddone]+  when alldone $ evalnight m l h++evalnight :: MafiaStateA -> ListerA -> HandlerA -> Anticiv ()+evalnight m l h = do+  vr <- voteScore #< m+  let vs = sortBy (\(p,a) (q,b) -> b `compare` a) $ avlInorder vr+      vm = map (\((_,p),a) -> (p,a)) $ filter (\((s,_),_) -> s == MafiaKill) vs+      vt = map (\((_,p),a) -> (p,a)) $ filter (\((s,_),_) -> s == TriadKill) vs+  mv <- liftM join $ forM [vm,vt] $ \vs -> case vs of+    (p,a):(q,b):_ | a == b -> return []+    (p,_):_ -> return [(p,"Killed")]+    [] -> return []+  dimi <- liftM join $ forAllPlayers m $ \p -> do+    b <- (m,p) %| (==CivicK Dimitri)+    if b then return [p] else return []+  nday <- partyDay #< m+  safe <- liftM nub $ safeTonight #< m+  let allVictims = filter (not . flip elem safe . fst) $ nub mv+      allVictims'+        | null allVictims+          && not (null dimi)+          && (nday == 1) = [(head dimi,"DimitriKilled")]+        | otherwise = allVictims+  usersDie m allVictims'+  when (null allVictims') $ do+    globalfl "NooneKilled" :: Anticiv ()+  unregPriorityQuerymsg h+  fin <- partyFinished m+  if fin then evalparty m l h Deathmatch else day m l++day :: MafiaStateA -> ListerA -> Anticiv ()+day m l = do+  globalfl "Sunrise" :: Anticiv ()+  us <- forAllPlayers m $ \pid -> userNick #< fromPID pid+  globalfl "StillAlive" (concat $ intersperse ", " us) :: Anticiv ()+  globalfl "ExecHint" :: Anticiv ()+  regPriorityChanmsg $ daymsg m l+  m <># \m -> m{voteScore=none, votedAlready=none, isNight=False}+  return ()+      +maffmsg :: MafiaStateA -> ListerA -> HandlerA -> UserA -> String -> Anticiv Bool+maffmsg m l h u s = do+  mpid <- toPID m u+  case mpid of+    Nothing -> return False+    Just up -> do+      maff <- isMafioso m up+      tri <- isTriadist m up+      if not (maff || tri)+         then return False+         else+           s & LocalT u "mafftalk" :-: Remaining #-> \t -> do+             privatefl u "Mafftalking" :: Anticiv ()+             un <- userNick #< u+             unless (all isSpace t) $ do+               when maff $ forAllMafiosi_ m $ \pid' -> void $ do+                 privatefl (fromPID pid') "IncomingMafftalk" un t :: Anticiv ()+               when tri $ forAllTriadists_ m $ \pid' -> void $ do+                 privatefl (fromPID pid') "IncomingTritalk" un t :: Anticiv ()+             regPriorityQuerymsg $ mafftalkmsg m l u+             return ()++mafftalkmsg :: MafiaStateA -> ListerA -> UserA -> HandlerA -> UserA -> String -> Anticiv Bool+mafftalkmsg m l ur h u s+  | ur /= u = return False+  | otherwise = do+    s & LocalT u "donemafftalk" #->> do+      unregPriorityQuerymsg h+      privatefl u "DoneMafftalking" :: Anticiv ()+     .|| Remaining #-> \t -> do+      un <- userNick #< u+      withAlivePID m u $ \pid -> do+        maff <- isMafioso m pid+        tri <- isTriadist m pid+        when maff $ forAllMafiosi_ m $ \pid' ->+          privatefl (fromPID pid') "IncomingMafftalk" un t :: Anticiv ()+        when tri $ forAllTriadists_ m $ \pid' ->+          privatefl (fromPID pid') "IncomingTritalk" un t :: Anticiv ()++nightchanmsg :: MafiaStateA -> ListerA -> HandlerA -> UserA -> String -> Anticiv Bool+nightchanmsg m l h u s = do+  n <- isNight #< m+  when n $ do+    withAlivePID m u $ \pid -> usersDie m [(pid,"TalkedAtNight")] :: Anticiv ()+    tryevalnight m l h+    fin <- partyFinished m+    when fin $ evalparty m l h Deathmatch+  return True+    +daymsg :: MafiaStateA -> ListerA -> HandlerA -> UserA -> String -> Anticiv Bool+daymsg m l h u s = do+  pref <- bprefix+  s & "ME" :-: LocalT u "vote" :-: ChannelUser #-> \t -> do+    u' <- userNick #< u+    t' <- userNick #< t+    withAlivePID m u $ \pid -> do+      withAlivePID m t $ \pit -> do+        b <- playerVote m pid pit Execution privatefl+        when b $+          globalfl "VotesFor" u' t'+      tryevalday m l h++tryevalday :: MafiaStateA -> ListerA -> HandlerA -> Anticiv ()+tryevalday m l h = do+  vs <- liftM and $ forAllPlayers m $ \p -> hasVoted m p Execution+  when vs $ evalday m l h++evalday :: MafiaStateA -> ListerA -> HandlerA -> Anticiv ()+evalday m l h = do+  vr <- voteScore #< m+  let vs = map (\((_,p),a) -> (p,a)) $ sortBy (\(p,a) (q,b) -> b `compare` a) $ avlInorder vr+  mv <- case vs of+    (p,a):(q,b):_ | a == b -> return []+    (p,_):_ -> return [p]+  ps <- forAllPred m (`elem` [CivicK CitJudge, MafiaK MaffJudge, TriadK TriJudge]) return+  when (null mv && length ps == 1) $ do+    let j = head ps+    globalfl "WaitingForJudge" :: Anticiv ()+    regPriorityQuerymsg $ judgemsg m l h j+    privatefl (fromPID j) "JudgeHint"+  when (null mv && length ps /= 1) $ do+    globalfl "NooneExecuted" :: Anticiv ()+  unless (null mv && length ps == 1) $ do+    if (any ((==1000).snd) vs)+      then globalfl "JudgeHasSpoken" :: Anticiv ()+      else forM_ vs $ \(v,c) -> do+             vn <- userNick #< fromPID v+             globalfl "VotesGivenFor" vn c :: Anticiv ()+    js <- liftM or $ forM mv $ \v -> (m,v) %| shareFaction (bogus JustinK)+    usersDie m $ map (,"Executed") mv+    unregPriorityChanmsg h+    fin <- partyFinished m+    nday <- partyDay #< m+    if fin +      then evalparty m l h Deathmatch+      else if js && nday == 1+              then evalparty m l h JustinWon+              else night m l++-- There are no implications yet+deathImplications :: MafiaStateA -> PlayerId -> Anticiv [(PlayerId,String)]+deathImplications m pid = do+  mcou <- coupledPlayers #< m+  case mcou of+    Nothing -> return []+    Just (a,b)+      | a == pid -> return [(b,"Suicide")]+      | b == pid -> return [(a,"Suicide")]+      | otherwise -> return []++inferDeaths :: MafiaStateA -> [(PlayerId,String)] -> Anticiv [(PlayerId,String)]+inferDeaths m inc = do+  log ("inferDeath in: "++concatMap (\(UnsafePlayerId (Atom a),re) -> show a++":"++re++"; ") inc)+  outg' <- forM (map fst inc) $ deathImplications m+  let outg = inc `dunion` nubBy deq (concat outg')+      dunion = unionBy deq+      deq a b = fst a == fst b+      sort = sortBy cmp+      cmp a b | a == b = EQ+      cmp (a,"Suicide") (b,"Suicide") = a `compare` b+      cmp (_,"Suicide") _ = GT+      cmp _ (_,"Suicide") = LT+      cmp a b = fst a `compare` fst b+  log ("inferDeath out: "++concatMap (\(UnsafePlayerId (Atom a),re) -> show a++":"++re++"; ") outg)+  if sort inc /= sort outg+     then inferDeaths m outg+     else return outg++usersDie :: MafiaStateA -> [(PlayerId,String)] -> Anticiv ()+usersDie m ps = do+  ps' <- inferDeaths m ps+  forM_ ps' $ \(pid,reason) -> do+    pn <- userNick #< fromPID pid+    (m,pid) <>& \p -> p{playerAlive=False}+    globalfl reason pn :: Anticiv ()+    obduct m pid+    ch <- bchan+    cprint Raw ("MODE "++ch++" -v "++pn++"\r\n")++obduct :: MafiaStateA -> PlayerId -> Anticiv ()+obduct m pid = do+  rs <- liftM (sortBy (\b a -> rolePriority a `compare` rolePriority b)) $ playerRoles &< (m,pid)+  -- TODO: Mind lingua overrides!+  li <- bgets botLingua+  rns <- mapM (bvStr li . ("RoleNames/"++) . show) rs+  u <- userNick #< fromPID pid+  globalfl "Obduction" u $ concat $ intersperse ", " rns++evalparty :: MafiaStateA -> ListerA -> HandlerA -> FinishReason -> Anticiv ()+evalparty m l h f = do+  unregPriorityChanmsg h+  unregPriorityQuerymsg h+  case f of+    Deathmatch -> globalfl "PartyOver" :: Anticiv ()+    JustinWon -> globalfl "JustinWon" :: Anticiv ()+  forAllPlayers_ m $ obduct m+  ch <- bchan+  cbracket Raw $ do+    forAllPlayers_ m $ \pid -> do+      u <- userNick #< fromPID pid+      mprint ("MODE "++ch++" -v "++u++"\r\n")+    mprint ("MODE "++ch++" -m\r\n")+  lh <- lostHandlers #< m+  forM_ lh $ \h' -> do+    unregPriorityChanmsg h'+    unregPriorityQuerymsg h'+  dispAtom m+  regPriorityChanmsg $ idlemsg l+  return ()++judgemsg :: MafiaStateA -> ListerA -> HandlerA -> PlayerId -> HandlerA -> UserA -> String -> Anticiv Bool+judgemsg m l hd j hj u+  | fromPID j /= u = const $ return False+  | otherwise =+    "ME" :-: LocalT u "sentence" :-: ChannelUser #-> \t -> do+      vr <- voteScore #< m+      let vs = avlInorder vr+          vm = snd $ maximumBy (\(p,a) (q,b) -> a `compare` b) vs+          vms = map (snd.fst) $ filter ((==vm) . snd) vs+      unless (t `elem` map fromPID vms) $ privatefl u "NotPermitted" :: Anticiv ()+      when (t `elem` map fromPID vms) $ withPID m t $ \pid -> do+        unregPriorityQuerymsg hj+        m <># \m -> m{voteScore=avlInsert ((Execution,pid),1000) $ voteScore m}+        evalday m l hd
+ Network/Anticiv/Modules/Mafia/Core.hs view
@@ -0,0 +1,315 @@+{-# LANGUAGE RankNTypes, ConstraintKinds, FlexibleContexts, MultiParamTypeClasses, TypeFamilies #-}+module Network.Anticiv.Modules.Mafia.Core where++import Prelude hiding (log)+import Control.Monad+import Data.List+import Data.Typeable+import Data.Chatty.Atoms+import Data.Chatty.AVL+import Data.Chatty.BST+import Network.Anticiv.Convenience+import Network.Anticiv.Modules.Mafia.Data+import Network.Anticiv.Monad+import System.Chatty.Misc+import Text.Printf++data MafiaState = MafiaState {+    mafiaInitiator :: UserA,+    mafiaPlayers :: AVL (UserA,PlayerState),+    voteScore :: AVL ((Subject,PlayerId),Int),+    votedAlready :: [(Subject,PlayerId)],+    mafiaDone :: Bool,+    triadDone :: Bool,+    partyDay :: Int,+    actionsDone :: AVL Card,+    safeTonight :: [PlayerId],+    lostHandlers :: [HandlerA],+    isNight :: Bool,+    coupledPlayers :: Maybe (PlayerId, PlayerId)+  }+type MafiaStateA = Atom MafiaState++data PlayerState = PlayerState {+    playerAlive :: Bool,+    playerCards :: [Card],+    playerRoles :: [Role],+    playerSaved :: Bool+  } | NopeNotYet deriving Eq++data FinishReason = Deathmatch | JustinWon deriving (Eq,Ord,Show)++data Subject = Execution | MafiaKill | TriadKill deriving (Eq,Ord,Show)++-- | Phantom type. Just to make sure. If a function gets a 'PlayerId' passed,+-- we're already sure it is contained in 'mafiaPlayers' and don't need to+-- handle the 'Nothing' case any more, as it is already handled in 'toPID'.+newtype PlayerId = UnsafePlayerId { fromPID :: UserA } deriving (Eq,Ord)++toPID :: MafiaStateA -> UserA -> Anticiv (Maybe PlayerId)+toPID msa ua = do+  ms <- mafiaPlayers #< msa+  return $ case avlLookup ua ms of+    -- It's safe here :)+    Just _ -> Just $ UnsafePlayerId ua+    Nothing -> Nothing++withPID :: MafiaStateA -> UserA -> (PlayerId -> Anticiv ()) -> Anticiv ()+withPID msa ua f = do+  mpid <- toPID msa ua+  case mpid of+    Just pid -> f pid+    Nothing -> do+      u <- userNick #< ua+      globalfl "DoesntParticipate" u++withAlivePID :: MafiaStateA -> UserA -> (PlayerId -> Anticiv ()) -> Anticiv ()+withAlivePID msa ua f = withPID msa ua $ \pid -> do+  al <- playerAlive &< (msa,pid)+  when al $ f pid+  unless al $ do+    u <- userNick #< ua+    globalfl "IsDead" u++withInitiator :: MafiaStateA -> UserA -> (PlayerId -> Anticiv ()) -> Anticiv ()+withInitiator msa ua f = withPID msa ua $ \pid -> do+  mi <- mafiaInitiator #< msa+  if mi == ua+     then f pid+     else addressfl ua "NotPermitted"++forAllPlayers_ :: MafiaStateA -> (PlayerId -> Anticiv ()) -> Anticiv ()+forAllPlayers_ msa f = void $ forAllPlayers msa f++forAllPlayers :: MafiaStateA -> (PlayerId -> Anticiv a) -> Anticiv [a]+forAllPlayers msa f = do+  pv <- mafiaPlayers #< msa+  forM (filter (playerAlive.snd) $ avlInorder pv) $ \(u,_) -> f $ UnsafePlayerId u++forAllMafiosi :: MafiaStateA -> (PlayerId -> Anticiv a) -> Anticiv [a]+forAllMafiosi msa f = forAllPred msa (shareFaction Rom) f++forAllMafiosi_ :: MafiaStateA -> (PlayerId -> Anticiv ()) -> Anticiv ()+forAllMafiosi_ msa f = void $ forAllMafiosi msa f++forAllTriadists :: MafiaStateA -> (PlayerId -> Anticiv a) -> Anticiv [a]+forAllTriadists msa f = forAllPred msa (shareFaction Rot) f++forAllTriadists_ :: MafiaStateA -> (PlayerId -> Anticiv ()) -> Anticiv ()+forAllTriadists_ msa f = void $ forAllTriadists msa f++forAllPred :: MafiaStateA -> (Role -> Bool) -> (PlayerId -> Anticiv a) -> Anticiv [a]+forAllPred msa pred f = liftM concat $ forAllPlayers msa $ \pid -> do+  b <- (msa, pid) %| pred+  if b then liftM return $ f pid else return []++forAllPred_ :: MafiaStateA -> (Role -> Bool) -> (PlayerId -> Anticiv ()) -> Anticiv ()+forAllPred_ msa pred f = void $ forAllPred msa pred f++-- | Tries to match a predicate on any of the player's roles+(%|) :: (MafiaStateA, PlayerId) -> (Role -> Bool) -> Anticiv Bool+(msa,pid) %| f = do+  rs <- playerRoles &< (msa, pid)+  return $ any f rs++-- | Runs a function on the most important of the player's roles+(%&) :: (MafiaStateA, PlayerId) -> (Role -> a) -> Anticiv a+(msa,pid) %& f = do+  rs <- playerRoles &< (msa, pid)+  -- actually it's the maximum, but the sort order is reversed+  return $ f $ minimumBy (\a b -> rolePriority a `compare` rolePriority b) rs++-- | Like %&, but makes sure the observation reveals an oblique result+(%|&) :: (MafiaStateA, PlayerId) -> (Role -> a) -> Anticiv a+(msa,pid) %|& f = do+  rs <- playerRoles &< (msa, pid)+  return $ f $+    minimumBy (\a b -> rolePriority a `compare` rolePriority b) $+    filter ((/=Transparent) . observation) rs++-- | Like %&, but takes another player+(%&&) :: (MafiaStateA, PlayerId) -> (Role -> Role -> a) -> PlayerId -> Anticiv a+(msa,a) %&& f = \b -> do+  rs <- playerRoles &< (msa, b)+  (msa,a) %& f `ap` return (minimumBy (\a b -> rolePriority a `compare` rolePriority b) rs)++seekRole :: Faction f => MafiaStateA -> f -> Anticiv [PlayerId]+seekRole m r = liftM join $ forAllPlayers m $ \p -> do+  b <- seekCard m p r+  if null b then return [] else return [p]++seekUnusedRole :: Faction f => MafiaStateA -> f -> Anticiv [PlayerId]+seekUnusedRole m r = liftM join $ forAllPlayers m $ \p -> do+  b <- seekUnusedCard m p r+  if null b then return [] else return [p]++seekCard :: Faction f => MafiaStateA -> PlayerId -> f -> Anticiv [Card]+seekCard m pid r = do+  cs <- playerCards &< (m,pid)+  return $ intersect (getRoleCards r) cs++seekUnusedCard :: Faction f => MafiaStateA -> PlayerId -> f -> Anticiv [Card]+seekUnusedCard m pid r = do+  cs <- seekCard m pid r+  ad <- actionsDone #< m+  liftM join $+    forM cs $+    \c -> return $+    case avlLookup c ad of+      Just _ -> []+      Nothing -> [c]+  +isMafioso :: MafiaStateA -> PlayerId -> Anticiv Bool+isMafioso msa pid = (msa, pid) %| shareFaction Rom++isTriadist :: MafiaStateA -> PlayerId -> Anticiv Bool+isTriadist msa pid = (msa, pid) %| shareFaction Rot++pget :: MafiaStateA -> PlayerId -> Anticiv PlayerState+pget msa pid = do+  ms <- mafiaPlayers #< msa+  case avlLookup (fromPID pid) ms of+    -- There can only be Just, thanks to phantom magic+    Just ps -> return ps++pgets :: MafiaStateA -> PlayerId -> (PlayerState -> a) -> Anticiv a+pgets msa pid f = liftM f $ pget msa pid++pput :: MafiaStateA -> PlayerId -> PlayerState -> Anticiv ()+pput msa pid ps = do+  ms <- id #< msa+  ms{mafiaPlayers=avlInsert (fromPID pid, ps) $ mafiaPlayers ms} #> msa++pmodify :: MafiaStateA -> PlayerId -> (PlayerState -> PlayerState) -> Anticiv ()+pmodify msa pid f = pgets msa pid f >>= pput msa pid++joinParty :: MafiaStateA -> UserA -> Anticiv PlayerId+joinParty msa ua = do+  -- It's safe here :)+  NopeNotYet &> (msa, UnsafePlayerId ua)+  return $ UnsafePlayerId ua++(#>) :: a -> Atom a -> Anticiv ()+v #> a = putAtom a v++(#<) :: (a -> b) -> Atom a -> Anticiv b+f #< a = liftM f $ getAtom a++(<>#) :: Atom a -> (a -> a) -> Anticiv ()+a <># f = getAtom a >>= putAtom a . f++(<>&) :: (MafiaStateA,PlayerId) -> (PlayerState -> PlayerState) -> Anticiv ()+(msa,pid) <>& f = pmodify msa pid f++(&>) :: PlayerState -> (MafiaStateA,PlayerId) -> Anticiv ()+ps &> (msa,pid) = pput msa pid ps++(&<) :: (PlayerState -> a) -> (MafiaStateA,PlayerId) -> Anticiv a+f &< (msa,pid) = pgets msa pid f++selectRoles :: Int -> Anticiv [RoleCard]+selectRoles ntotal = do+  drjustin <- liftM (==1) $ mrandomR (1,5 :: Int)+  drterrorist <- liftM (==1) $ mrandomR (1,5 :: Int)+  drchurch <- liftM (==1) $ mrandomR (1,5 :: Int)+  drvampire <- liftM (==1) $ mrandomR (1,5 :: Int)+  drtriad <- liftM (==1) $ mrandomR (1,8 :: Int)+  let nmaffs = round (fromIntegral ntotal / 3.5)+      ntriad = if drtriad then min (round (fromIntegral ntotal / 3.5)) 3 else 0+      ncivics = ntotal+                - nmaffs+                - ntriad+                - length (filter id [drjustin{-,drterrorist,drchurch,drvampire-}])+  maffs <- chooseN nmaffs $ proposeCards (bogus MafiaK) nmaffs+  triad <- chooseN ntriad $ proposeCards (bogus TriadK) ntriad+  civics <- chooseN ncivics $ proposeCards (bogus CivicK) ncivics+  justin <- if drjustin then chooseN 1 $ proposeCards (bogus JustinK) 1 else return []+  --terrorist <- if drterrorist then chooseN 1 $ proposeCards (bogus TerroristK) 1 else return []+  --church <- if drchurch then chooseN 1 $ proposeCards (bogus ChurchK) 1 else return []+  --vampire <- if drvampire then chooseN 1 $ proposeCards (bogus VampireK) 1 else return []+  let total = maffs ++ civics ++ justin ++ triad+      tjudges = filter (\(c :-> r) -> r `elem` [CivicK CitJudge,MafiaK MaffJudge,TriadK TriJudge]) total+  if length tjudges <= 1+    then return (maffs ++ civics ++ justin ++ triad)+    else selectRoles ntotal -- new try++chooseN :: Int -> [RoleProposal] -> Anticiv [RoleCard]+chooseN 0 _ = return []+chooseN _ [] = return []+chooseN n cs = do+  let m = sum $ map (\(Propose i _) -> i) cs+      retr i (Propose p r:ps)+        | i < p = Propose p r+        | otherwise = retr (i-p) ps+  r <- mrandomR (0,m-1)+  let pr@(Propose _ cr) = retr r cs+  crs <- chooseN (n-1) (delete pr cs)+  return (cr : crs)++-- | That's Fisher-Yates, if I remember correctly+shuffle :: [a] -> Anticiv [a]+shuffle [] = return []+shuffle as = do+  r <- mrandomR (0, length as - 1)+  let i = as !! r+      ax = take r as ++ drop (r+1) as+  is <- shuffle ax+  return (i:is)++assignRoles :: MafiaStateA -> Anticiv ()+assignRoles msa = do+  pv <- mafiaPlayers #< msa+  let psc = avlSize pv+      ps = avlInorder pv+  rs <- shuffle =<< selectRoles psc+  log $ printf "Just to make sure: We have %i players and %i roles." psc (length rs)+  forM_ (zip ps rs) $ \((u,_), c :-> r) ->+    PlayerState True [c] [r] False &> (msa, UnsafePlayerId u)++hasVoted :: MafiaStateA -> PlayerId -> Subject -> Anticiv Bool+hasVoted msa pid sub = do+  var <- votedAlready #< msa+  case filter (==(sub,pid)) var of+    [] -> return False+    _ -> return True++playerVote :: MafiaStateA -> PlayerId -> PlayerId -> Subject -> Speaker -> Anticiv Bool+playerVote msa el vi sub speak = do+  var <- hasVoted msa el sub+  case var of+    True -> do+      speak (fromPID el) "AlreadyVoted" :: Anticiv ()+      return False+    False -> do+      msa <># \m -> m{votedAlready=(sub,el) : votedAlready m}+      vsc <- voteScore #< msa+      case avlLookup (sub,vi) vsc of+        Nothing -> msa <># \m -> m{voteScore=avlInsert ((sub,vi),1) vsc}+        Just i -> msa <># \m -> m{voteScore=avlInsert ((sub,vi),i+1) vsc}+      return True++partyFinished :: MafiaStateA -> Anticiv Bool+partyFinished msa =+  liftM (all and) $+  forAllPlayers msa $+  \a -> forAllPlayers msa $+  \b -> (msa, a) %&& winsWith $ b++actionDone :: Faction f => MafiaStateA -> PlayerId -> f -> Anticiv ()+actionDone msa pid r = do+  cs <- seekUnusedCard msa pid r+  case cs of+    [] -> log "Wait, what?"+    c:_ -> msa <># \m -> m{actionsDone=avlInsert c $ actionsDone m}++instance Indexable (Atom a) (Atom a) (Atom a) where+  valueOf = id+  indexOf = id++instance Indexable PlayerId PlayerId PlayerId where+  valueOf = id+  indexOf = id++instance Indexable Card Card Card where+  valueOf = id+  indexOf = id
+ Network/Anticiv/Modules/Mafia/Data.hs view
@@ -0,0 +1,208 @@+{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}+module Network.Anticiv.Modules.Mafia.Data where++data CardSuit = Club | Spade | Heart | Diamond deriving (Eq,Show,Ord)+data CardValue = Two | Three | Four | Five | Six | Seven | Eight | Nine | Ten | Jack | Queen | King | Ace deriving (Eq,Show,Ord)+data Card = Card CardSuit CardValue deriving (Eq,Show,Ord)++data RoleCard = Card :-> Role deriving (Eq,Show)+data RoleProposal = Propose Int RoleCard deriving Eq++data Role = CivicK CivicF+          | MafiaK MafiaF+          | CoupleK CoupleF+          | ChurchK ChurchF+          | VampireK VampireF+          | JustinK JustinF+          | TerroristK TerroristF+          | TriadK TriadF  +          deriving (Eq,Ord)++data Priority = Highest | High | Medium | Low | Lowest deriving (Eq,Ord)++data Observation = Friend | Enemy | Transparent deriving (Eq,Ord,Show)++class (Eq f, Ord f, Show f) => Faction f where+  factionKey :: f -> Role+  winsWith :: f -> Role -> Bool+  shareFaction :: f -> Role -> Bool+  getFactionCards :: f -> [Card]+  getRoleCards :: f -> [Card]+  proposeCards :: f -> Int -> [RoleProposal]+  rolePriority :: f -> Priority+  observation :: f -> Observation++proxy :: (forall f. Faction f => f -> a) -> Role -> a+proxy f (CivicK r) = f r+proxy f (MafiaK r) = f r+proxy f (CoupleK r) = f r+proxy f (ChurchK r) = f r+proxy f (VampireK r) = f r+proxy f (JustinK r) = f r+proxy f (TerroristK r) = f r+proxy f (TriadK r) = f r++instance Show Role where+  show = proxy show++instance Faction Role where+  factionKey f = f+  winsWith = proxy winsWith+  getFactionCards = proxy getFactionCards+  shareFaction = proxy shareFaction+  getRoleCards = proxy getRoleCards+  proposeCards = proxy proposeCards+  rolePriority = proxy rolePriority+  observation = proxy observation++data CivicF = Rop | Dimitri | Detective | Inspector | ZeroDivisor | Gardener | BusDriver | SoulSaver | Hunter | Cupid | Stoiber | Doctor | CitJudge | Tree | NPSOwner | OilTanker deriving (Eq,Ord,Show)++data MafiaF = Rom | Spy | MaffJudge deriving (Eq,Ord,Show)++data CoupleF = InLove deriving (Eq,Ord,Show)++data ChurchF = Pope | Monk deriving (Eq,Ord,Show)++data VampireF = Dracula | Vampire deriving (Eq,Ord,Show)++data JustinF = Justin deriving (Eq,Ord,Show)++data TerroristF = Terrorist | Pyromanian deriving (Eq,Ord,Show)++data TriadF = Rot | TriSpy | TriJudge deriving (Eq,Ord,Show)++propose :: Faction f => f -> [Int] -> [RoleProposal]+propose f ps =+  map (\(p,c) -> Propose p $ c :-> factionKey f) $+  zip ps $+  getRoleCards f++bogus :: Faction f => (f -> Role) -> Role+bogus f = f undefined++instance Faction CivicF where+  factionKey = CivicK+  winsWith _ (CivicK _) = True+  winsWith _ (JustinK _) = True+  winsWith _ (ChurchK _) = True+  winsWith _ _ = False+  shareFaction _ (CivicK _) = True+  shareFaction _ _ = False+  getFactionCards _ =+    [Rop,Dimitri,Detective,Inspector+    ,ZeroDivisor,Gardener,BusDriver,SoulSaver+    ,Hunter,Cupid,Stoiber,Doctor+    ,CitJudge,Tree,NPSOwner,OilTanker]+    >>= getRoleCards+  getRoleCards Rop = do+    v <- [Seven,Eight,Nine]+    s <- [Club,Spade,Heart,Diamond]+    return $ Card s v+  getRoleCards Dimitri = [Card Club Ten]+  getRoleCards Detective = [Card Spade Ace, Card Club Ace]+  getRoleCards Inspector = [Card Diamond Ace]+  getRoleCards ZeroDivisor = [Card Spade Ten]+  getRoleCards Gardener = [Card Diamond Ten]+  getRoleCards BusDriver = [Card Diamond Queen]+  getRoleCards SoulSaver = [Card Spade Queen]+  getRoleCards Hunter = [Card Spade King]+  getRoleCards Cupid = [Card Heart Queen]+  getRoleCards Stoiber = [Card Diamond King]+  getRoleCards Doctor = [Card Club Queen]+  getRoleCards CitJudge = [Card Diamond Three]+  getRoleCards Tree = [Card Club Three]+  getRoleCards NPSOwner = [Card Spade Three]+  getRoleCards OilTanker = [Card Heart Three]+  proposeCards _ _ =+    propose Rop [100,90,50,20,10,8,6,4,2,2,2,2] +++    propose Detective [100,25] +++    propose Inspector [25] +++    propose Dimitri [25] +++    propose Gardener [20] +++    propose SoulSaver [80] +++    propose Cupid [40]+  rolePriority _ = Low+  observation Gardener = Enemy+  observation _ = Friend++instance Faction MafiaF where+  factionKey = MafiaK+  winsWith _ (MafiaK _) = True+  winsWith _ (TerroristK _) = True+  winsWith _ _ = False+  shareFaction _ (MafiaK _) = True+  shareFaction _ _ = False+  getFactionCards _ = [Rom,Spy,MaffJudge] >>= getRoleCards+  getRoleCards Rom = Card Club Two : do+    s <- [Club,Spade,Heart,Diamond]+    return $ Card s Jack+  getRoleCards Spy = [Card Spade Two]+  getRoleCards MaffJudge = [Card Diamond Two]+  proposeCards _ _ =+    propose Rom [100, 50, 20, 10, 10] +++    propose Spy [70] +++    propose MaffJudge [50]+  rolePriority _ = Low+  observation _ = Enemy++instance Faction CoupleF where+  factionKey = CoupleK+  winsWith _ (CoupleK _) = True+  winsWith _ _ = False+  shareFaction _ (CoupleK _) = True+  shareFaction _ _ = False+  getFactionCards _ = []+  getRoleCards _ = []+  proposeCards _ _ = []+  rolePriority _ = Highest+  observation _ = Transparent+  +instance Faction ChurchF+instance Faction VampireF++instance Faction JustinF where+  factionKey = JustinK+  winsWith _ (JustinK _) = True+  winsWith _ (CivicK _) = True+  winsWith _ _ = False+  shareFaction _ (JustinK _) = True+  shareFaction _ _ = False+  getFactionCards _ = getRoleCards Justin+  getRoleCards Justin = [Card Heart Ten]+  proposeCards _ _ =+    propose Justin [20]+  rolePriority _ = Medium+  observation _ = Friend++instance Faction TerroristF where+  factionKey = TerroristK+  winsWith _ (TerroristK _) = True+  winsWith _ (MafiaK _) = True+  winsWith _ (TriadK _) = True+  winsWith _ _ = False+  shareFaction _ (TerroristK _) = True+  shareFaction _ _ = False+  getFactionCards _ = [Terrorist, Pyromanian] >>= getRoleCards+  getRoleCards Terrorist = [Card Club King]+  getRoleCards Pyromanian = [Card Heart Two]+  proposeCards _ _ = []+  rolePriority _ = Low+  observation _ = Enemy++instance Faction TriadF where+  factionKey = TriadK+  winsWith _ (TriadK _) = True+  winsWith _ (TerroristK _) = True+  winsWith _ _ = False+  shareFaction _ (TriadK _) = True+  shareFaction _ _ = False+  getFactionCards _ = [Rot,TriSpy,TriJudge] >>= getRoleCards+  getRoleCards Rot = [Card Club Four]+  getRoleCards TriSpy = [Card Spade Four]+  getRoleCards TriJudge = [Card Diamond Four]+  proposeCards _ _ =+    propose Rot [100] +++    propose TriSpy [70] +++    propose TriJudge [50]+  rolePriority _ = Low+  observation _ = Enemy
anticiv.cabal view
@@ -10,7 +10,7 @@ -- PVP summary:      +-+------- breaking API changes --                   | | +----- non-breaking API additions --                   | | | +--- code changes with no API change-version:             0.1.0.4+version:             0.1.0.5  -- A short (one-line) description of the package. synopsis:            This is an IRC bot for Mafia and Resistance.@@ -51,7 +51,7 @@   main-is:             Main.hs      -- Modules included in this executable, other than Main.-  other-modules:       Network.Anticiv.Monad, Network.Anticiv.Masks, Network.Anticiv.Convenience+  other-modules:       Network.Anticiv.Monad, Network.Anticiv.Masks, Network.Anticiv.Convenience, Network.Anticiv.Config, Network.Anticiv.Modules.Mafia, Network.Anticiv.Modules.Mafia.Core, Network.Anticiv.Modules.Mafia.Data, Network.Anticiv.Modules.Ironforge, Network.Anticiv.Modules.Base, Network.Anticiv.Modules.Barkeeper      -- LANGUAGE extensions used by modules in this package.   -- other-extensions:    @@ -69,7 +69,7 @@ library   build-depends:       base >=4.6 && <4.8, chatty >= 0.6 && <0.7, chatty-utils >= 0.6 && <0.8, chatty-text >=0.6 && <0.7, transformers >= 0.3 && <0.5, antisplice >=0.17 && <0.18, network >=2.3 && <2.4, mtl >= 2.1 && <2.3, ironforge >= 0.1 && < 0.2, time >=1.4 && <1.5, plugins >=1.5 && <1.6, ctpl >=0.1 && <0.2 -  exposed-modules:	Network.Anticiv.Monad, Network.Anticiv.Masks, Network.Anticiv.Convenience+  exposed-modules:	Network.Anticiv.Monad, Network.Anticiv.Masks, Network.Anticiv.Convenience, Network.Anticiv.Config, Network.Anticiv.Modules.Mafia, Network.Anticiv.Modules.Mafia.Core, Network.Anticiv.Modules.Mafia.Data, Network.Anticiv.Modules.Ironforge, Network.Anticiv.Modules.Base, Network.Anticiv.Modules.Barkeeper    -- Base language which the package is written in.   default-language:    Haskell2010