{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TupleSections         #-}

module Waterdeep.Types
   ( AccumulationType(..)
   , BonusType(..)
   , Building(..)
   , BuildingState(..)
   , Faction(..)
   , FactionColor(..)
   , GameAction
   , IntrigueCard(..)
   , IntrigueType(..)
   , Lord(..)
   , PlayerID
   , PlayerState(..)
   , PlotState(..)
   , PlotCondition(..)
   , PlotQualifier(..)
   , Quest(..)
   , QuestType(..)
   , Resource(..)
   , Waterdeep
   , WaterdeepPrompt(..)
   , WaterdeepState(..)
   , ResourceSet
   , lordName
   , lordQuote
   , lordBonus
   , factionName
   , factionColor
   , buildingCost
   , buildingTitle
   , buildingAction
   , buildingOwnerAction
   , buildingAccumType
   , questType
   , questTitle
   , questQuote
   , questCost
   , questReward
   , questPlotActions
   , intrigueTitle
   , intrigueType
   , intrigueAction
   , intrigueQuote
   , playerNumber
   , playerName
   , playerFaction
   , playerLord
   , playerScore
   , playerTavern
   , playerIncompleteQuests
   , playerCompletedQuests
   , playerPlotQuests
   , playerIntrigueCards
   , playerAgentsInPool
   , playerHasLieutenant
   , playerHasAmbassador
   , playerCanUseOpSpace
   , building
   , buildingAgents
   , buildingOwner
   , buildingAccumulation
   , gameNumberOfPlayers
   , gamePlayerStates
   , gameFirstPlayer
   , gameCurrentRound
   , gameCurrentPlayer
   , gameActivePlayer
   , gameConsecutivePasses
   , gameQuestDeck
   , gameQuestDiscard
   , gameCliffwatchInn
   , gameIntrigueDeck
   , gameIntrigueDiscard
   , gameBuildingDeck
   , gameBuildingDiscard
   , gameBuildersHall
   , gameBuildings
   , gameWaterdeepHarbor
   , gameStdGen
   , plotActionState
   , plotCondition
   , plotAction
   , gamePlayerState
   , gamePlayerName
   , activePlayerState
   , activePlayerName
   , withActivePlayer
   , nextPlayerID
   , noPlayerID
   , newPlayerState
   , newBuildingState
   , notifyState
   , broadcast
   , solicitChoice
   , actionProvidedSet
   , actionProvided
   , delimitAction
   , runWaterdeepC
   , runWaterdeep
   , runWaterdeepM
   , canPerformAction
   , filterChoices
   ) where

import Control.Applicative
import Control.Monad
import Control.Monad.Prompt
import Control.Monad.Random
import Control.Monad.State
import Control.Monad.State.Class
import Control.Monad.Writer.Class
import Control.Monad.Trans
import Control.Monad.Trans.Maybe (MaybeT, runMaybeT)
import Control.Monad.Trans.State (StateT, runStateT)
import Control.Monad.Trans.Writer (WriterT(..), runWriterT)
import Data.Maybe
import Data.Monoid
import Lens.Family2
import Lens.Family2.State
import Lens.Family2.Stock
import Lens.Family2.TH
import Lens.Family2.Unchecked (lens)
import System.Random (StdGen)

import qualified Data.IntMap   as IM
import qualified Data.MultiSet as MS
import qualified Data.Set      as Set
import qualified System.Random as R

type PlayerID = Int

type GameAction = Waterdeep ()

data Lord =
   Lord
      { _lordName               :: String
      , _lordQuote              :: String
      , _lordBonus              :: BonusType
      }

data Faction =
   Faction
      { _factionName            :: String
      , _factionColor           :: FactionColor
      }

data Building =
   Building
      { _buildingCost           :: Int
      , _buildingTitle          :: String
      , _buildingAction         :: GameAction
      , _buildingOwnerAction    :: GameAction
      , _buildingAccumType      :: AccumulationType
      }

data Quest =
   Quest
      { _questType              :: QuestType
      , _questTitle             :: String
      , _questQuote             :: String
      , _questCost              :: ResourceBag
      , _questReward            :: GameAction
      , _questPlotActions       :: [(PlotState, PlotCondition, GameAction)]
      }

data IntrigueCard =
   IntrigueCard
      { _intrigueTitle          :: String
      , _intrigueType           :: IntrigueType
      , _intrigueAction         :: GameAction
      , _intrigueQuote          :: String
      }

data PlayerState =
   PlayerState
      { _playerNumber           :: PlayerID
      , _playerName             :: String
      , _playerFaction          :: Faction
      , _playerLord             :: Lord
      , _playerScore            :: Int
      , _playerTavern           :: ResourceBag
      , _playerIncompleteQuests :: [Quest]
      , _playerCompletedQuests  :: [Quest]
      , _playerPlotQuests       :: IM.IntMap Quest
      , _playerIntrigueCards    :: [IntrigueCard]
      , _playerAgentsInPool     :: Int
      , _playerHasLieutenant    :: Bool
      , _playerHasAmbassador    :: Bool
      , _playerCanUseOpSpace    :: Bool
      }

data BuildingState =
   BuildingState
      { _building               :: Building
      , _buildingAgents         :: [PlayerID]
      , _buildingOwner          :: PlayerID
      , _buildingAccumulation   :: Int
      }

data WaterdeepState =
   WaterdeepState
      { _gamePlayerStates       :: IM.IntMap PlayerState
      , _gameNumberOfPlayers    :: Int
      , _gameFirstPlayer        :: PlayerID
      , _gameCurrentRound       :: Int
      , _gameCurrentPlayer      :: PlayerID
      , _gameActivePlayer       :: PlayerID
      , _gameConsecutivePasses  :: Int
      , _gameQuestDeck          :: [Quest]
      , _gameQuestDiscard       :: [Quest]
      , _gameCliffwatchInn      :: [Quest]
      , _gameIntrigueDeck       :: [IntrigueCard]
      , _gameIntrigueDiscard    :: [IntrigueCard]
      , _gameBuildingDeck       :: [Building]
      , _gameBuildingDiscard    :: [Building]
      , _gameBuildersHall       :: IM.IntMap BuildingState
      , _gameBuildings          :: IM.IntMap BuildingState
      , _gameWaterdeepHarbor    :: IM.IntMap BuildingState
      , _gameReassigningAgents  :: Bool
      , _gameStdGen             :: StdGen
      }

data Resource     = Cleric | Fighter | Rogue | Wizard | Gold
                    deriving (Eq,Ord,Enum,Bounded,Show)

type ResourceSet  = Set.Set Resource
type ResourceBag  = MS.MultiSet Resource

data QuestType    = Piety | Warfare | Skullduggery | Arcana | Commerce | Mandatory
                    deriving (Eq,Ord,Enum,Bounded,Show)

data IntrigueType = Utility | Attack | MandatoryQuest
                    deriving (Eq,Ord,Enum,Bounded,Show)

data FactionColor = Yellow | Black | Blue | Green | Red
                    deriving (Eq,Ord,Enum,Bounded,Show)

data BonusType = QuestBonus [QuestType] Int
               | BuildingBonus Int
               deriving (Eq,Show)

data AccumulationType = NoAccumulation
                      | AccumulatePoints Int
                      | AccumulateResource Resource Int
                      deriving (Eq,Show)

data PlotState = Active | Used deriving (Eq,Show)

data PlotQualifier = ActionProvides Resource
                   | CompletesQuest QuestType
                   | PlaysIntrigue
                   | BuysBuilding
                   deriving (Eq,Show)

data PlotCondition = Immediately
                   | StartOfRound
                   | OncePerRoundWhen PlotQualifier
                   | Whenever PlotQualifier
                   deriving (Eq,Show)

data WaterdeepPrompt a where
   NotifyState   :: WaterdeepState -> WaterdeepPrompt ()
   Broadcast     :: String -> WaterdeepPrompt ()
   SolicitChoice :: PlayerID -> String -> [(String, a)] -> WaterdeepPrompt a

data Waterdeep a =
   Waterdeep { unWaterdeep :: WriterT ResourceSet
                                 (StateT WaterdeepState
                                    (MaybeT (Prompt WaterdeepPrompt))) a }

makeLenses ''Lord
makeLenses ''Faction
makeLenses ''Building
makeLenses ''Quest
makeLenses ''IntrigueCard
makeLenses ''PlayerState
makeLenses ''BuildingState
makeLenses ''WaterdeepState

instance Eq Faction where
   a == b = a^.factionColor == b^.factionColor

instance Ord Faction where
   a `compare` b = (a^.factionColor) `compare` (b^.factionColor)

instance Eq Quest where
   a == b = a^.questTitle == b^.questTitle

instance Eq Building where
   a == b = a^.buildingTitle == b^.buildingTitle

instance Eq IntrigueCard where
   a == b = a^.intrigueTitle == b^.intrigueTitle

instance Functor Waterdeep where
   fmap f (Waterdeep m) = Waterdeep $ fmap f m

instance Applicative Waterdeep where
   pure = Waterdeep . pure
   (Waterdeep f) <*> (Waterdeep a) = Waterdeep (f <*> a)

instance Monad Waterdeep where
   return = Waterdeep . return
   (Waterdeep m) >>= f = Waterdeep (m >>= unWaterdeep . f)
   fail = Waterdeep . fail

instance Alternative Waterdeep where
   empty = Waterdeep empty
   Waterdeep m <|> Waterdeep n = Waterdeep (m <|> n)

instance MonadPlus Waterdeep where
   mzero = empty
   mplus = (<|>)

instance MonadState WaterdeepState Waterdeep where
   state = Waterdeep . lift . state

instance MonadRandom Waterdeep where
   getRandom     = gameStdGen %%= random
   getRandomR  r = gameStdGen %%= randomR r
   getRandoms    = randoms    <$> (gameStdGen %%= R.split)
   getRandomRs r = randomRs r <$> (gameStdGen %%= R.split)

instance MonadSplit StdGen Waterdeep where
   getSplit = gameStdGen %%= R.split

plotActionState :: Lens' (PlotState, PlotCondition, GameAction) PlotState
plotActionState f (s,c,a) = fmap (,c,a) $ f s

plotCondition :: Lens' (PlotState, PlotCondition, GameAction) PlotCondition
plotCondition f (s,c,a) = fmap (s,,a) $ f c

plotAction :: Lens' (PlotState, PlotCondition, GameAction) GameAction
plotAction f (s,c,a) = fmap (s,c,) $ f a

gamePlayerState :: PlayerID -> Lens' WaterdeepState PlayerState
gamePlayerState n = lens
   (\w     -> w ^. gamePlayerStates . intAt n .  to fromJust)
   (\w ps' -> w &  gamePlayerStates . intAt n .~ Just ps')

gamePlayerName :: PlayerID -> Lens' WaterdeepState String
gamePlayerName n = gamePlayerState n . playerName

activePlayerState :: Lens' WaterdeepState PlayerState
activePlayerState = lens
   (\w   -> w ^. gamePlayerState (w ^. gameActivePlayer))
   (\w v -> w &  gamePlayerState (w ^. gameActivePlayer) .~ v)

activePlayerName :: Lens' WaterdeepState String
activePlayerName = activePlayerState . playerName

withActivePlayer :: PlayerID -> Waterdeep a -> Waterdeep a
withActivePlayer p m = do
   p0 <- use gameActivePlayer
   gameActivePlayer .= p
   r <- m
   gameActivePlayer .= p0
   return r

nextPlayerID :: PlayerID -> WaterdeepState -> PlayerID
nextPlayerID p w = (p `mod` (w ^. gameNumberOfPlayers)) + 1

noPlayerID :: PlayerID
noPlayerID = 0

newPlayerState :: PlayerID -> (String, Faction, Lord) -> PlayerState
newPlayerState i (name, faction, lord) =
   PlayerState
      { _playerNumber           = i
      , _playerName             = name
      , _playerFaction          = faction
      , _playerLord             = lord
      , _playerScore            = 0
      , _playerTavern           = mempty
      , _playerIncompleteQuests = mempty
      , _playerCompletedQuests  = mempty
      , _playerPlotQuests       = mempty
      , _playerIntrigueCards    = mempty
      , _playerAgentsInPool     = 0
      , _playerHasLieutenant    = False
      , _playerHasAmbassador    = False
      , _playerCanUseOpSpace    = False
      }

newBuildingState :: PlayerID -> Building -> BuildingState
newBuildingState p b =
   BuildingState
      { _building             = b
      , _buildingOwner        = p
      , _buildingAgents       = []
      , _buildingAccumulation = 0
      }

waterdeepPrompt :: WaterdeepPrompt a -> Waterdeep a
waterdeepPrompt = Waterdeep . lift . lift . lift . prompt

notifyState :: Waterdeep ()
notifyState = get >>= waterdeepPrompt . NotifyState

broadcast :: String -> Waterdeep ()
broadcast s = notifyState >> waterdeepPrompt (Broadcast s)

solicitChoice :: String -> [(String, a)] -> Waterdeep a
solicitChoice _ []  = fail "there must be at least one option to choose"
solicitChoice _ [c] = return (snd c)  -- only one option, don't bother asking
solicitChoice t cs  = do
   notifyState
   p <- use gameActivePlayer
   waterdeepPrompt (SolicitChoice p t cs)

actionProvidedSet :: ResourceSet -> Waterdeep ()
actionProvidedSet s = Waterdeep $ tell s

actionProvided :: Resource -> Waterdeep ()
actionProvided r = actionProvidedSet $ Set.singleton r

delimitAction :: Waterdeep a -> Waterdeep (a, ResourceSet)
delimitAction (Waterdeep m) = Waterdeep . lift $ runWriterT m

evalWriterT :: Monad m => WriterT w m a -> m a
evalWriterT m = return . fst =<< runWriterT m

runWaterdeepC :: (Maybe (r, WaterdeepState) -> b) -> (forall a. WaterdeepPrompt a -> (a -> b) -> b) -> Waterdeep r -> WaterdeepState -> b
runWaterdeepC r p (Waterdeep m) s = runPromptC r p $ runMaybeT $ runStateT (evalWriterT m) s

runWaterdeep :: (forall a. WaterdeepPrompt a -> a) -> Waterdeep r -> WaterdeepState -> Maybe (r, WaterdeepState)
runWaterdeep p (Waterdeep m) s = runPrompt p $ runMaybeT $ runStateT (evalWriterT m) s

runWaterdeepM :: (Monad m) => (forall a. WaterdeepPrompt a -> m a) -> Waterdeep r -> WaterdeepState -> m (Maybe (r, WaterdeepState))
runWaterdeepM p (Waterdeep m) s = runPromptM p $ runMaybeT $ runStateT (evalWriterT m) s

data ContWD a where
   Done :: Maybe (a, WaterdeepState) -> ContWD a
   Cont :: WaterdeepPrompt b -> (b -> ContWD a) -> ContWD a

-- |Returns true if there exists some sequence of choices leading to a successful result.
tryChoice :: ContWD a -> Bool
tryChoice (Done (Just _)) = True
tryChoice (Done Nothing)  = False
tryChoice (Cont (NotifyState w) cont) = tryChoice $ cont ()
tryChoice (Cont (Broadcast s)   cont) = tryChoice $ cont ()
tryChoice (Cont (SolicitChoice p t cs) cont) = or $ map (tryChoice . cont . snd) cs

-- |Returns True if there exists some sequence of choices
-- which would make the action succeed, or False otherwise.
canPerformAction :: Waterdeep a -> Waterdeep Bool
canPerformAction m = tryChoice . runWaterdeepC Done Cont m <$> get

-- |Permit only choices which lead to a successful result.
-- Returns Nothing if and only if no such choice exists.
filterChoices :: Waterdeep a -> Waterdeep (Maybe a)
filterChoices m = filteredChoice [] . runWaterdeepC Done Cont m =<< get
   where
      filteredChoice :: [WaterdeepPrompt ()] -> ContWD a -> Waterdeep (Maybe a)
      filteredChoice ps (Done Nothing) = return Nothing
      filteredChoice ps (Done (Just (a,w))) = forwardPrompts ps >> put w >> return (Just a)
      filteredChoice ps (Cont p@(NotifyState w) cont) = filteredChoice (ps++[p]) $ cont ()
      filteredChoice ps (Cont p@(Broadcast   s) cont) = filteredChoice (ps++[p]) $ cont ()
      filteredChoice ps (Cont (SolicitChoice p t cs) cont) =
         case filter (tryChoice . cont . snd) cs of
            []  -> return Nothing
            [c] -> filteredChoice ps $ cont (snd c)
            cs' -> do
               forwardPrompts ps
               r <- waterdeepPrompt (SolicitChoice p t cs')
               filteredChoice [] $ cont r
      forwardPrompts :: [WaterdeepPrompt ()] -> Waterdeep ()
      forwardPrompts = mapM_ waterdeepPrompt