{-# 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