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 $ \_ -> 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