{-# LANGUAGE CPP                   #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}

module Game where

import           Prelude               hiding (round)

import           Control.Monad         (unless, when)
import           Control.Monad.Random  (Rand, StdGen, initStdGen, mkStdGen,
                                        runRand)
import           Control.Monad.State   (MonadIO, MonadState, StateT, evalStateT,
                                        get, gets, modify, put)
import           Control.Monad.Writer  (Writer, WriterT, mapWriterT, runWriter,
                                        runWriterT, tell)
import           Data.Functor          (($>))
import           Data.Functor.Identity (runIdentity)
import           Data.Maybe            (fromMaybe)
import           Data.Monoid           (getAny, getSum)

import qualified Data.IntMap.Strict    as IM
import qualified Data.Map.Strict       as M
import qualified Data.Set              as S

import           Creature
import           Equipment
import           Exit
import           Group
import           Item
import           Rand
import           Wall

import qualified Board                 as B
import qualified BoardConf             as BC
import qualified Command               as C
import qualified Highscore             as HS
import qualified Inventory             as I
import qualified Pos                   as P
import qualified Power                 as Pow
import qualified RollFrom              as RF
import qualified Tutorial              as T

data Game = Game
    { board        :: B.Board
    , transitions  :: [ B.Transition ]
    , inventory    :: I.Inventory
    , equipment    :: S.Set Equipment
    , selectedSlot :: Maybe I.Slot
    , score        :: Int
    , life         :: Int
    , maxLife      :: Int
    , junk         :: Int
    , level        :: Int
    , round        :: Int
    , roundItems   :: [Item]
    , levels       :: IM.IntMap BC.BoardConf
    , prev         :: Maybe Game
    , unseenBeats  :: S.Set T.Type
    , prevHS       :: Maybe HS.Highscore
    , gen          :: StdGen
    }

maxLevel, maxScore, initLife, charmBonus :: Int
maxLevel = 3
maxScore = 25
initLife = 5
charmBonus = 1

initCreatureSides, initWallSides :: Int
initCreatureSides = 36
initWallSides = 30

baseLevels :: IM.IntMap BC.BoardConf
baseLevels = IM.fromList
    [ (1, BC.BoardConf 1
        (RF.RollFrom initCreatureSides $ replicate 5 BasicMonster)
        (RF.RollFrom initWallSides $ replicate 6 Hedge))
    , (2, BC.BoardConf 2
        (RF.RollFrom initCreatureSides $ replicate 5 BasicMonster)
        (RF.RollFrom initWallSides $ replicate 6 BasicWall <> [Pillar]))
    , (3, BC.BoardConf 3
        (RF.RollFrom initCreatureSides $ replicate 5 BasicMonster)
        (RF.RollFrom initWallSides $ replicate 6 BasicWall <> [Window, Window]))
    ]

new :: MonadIO m => m Game
new = do
    g <- initStdGen
    pure $ Game { board = B.empty, transitions = [], inventory = I.empty, equipment = S.empty, selectedSlot = Nothing, score = 0, life = 0, maxLife = 0, junk = 0, level = 0, round = 0, roundItems = [], levels = baseLevels, prev = Nothing, unseenBeats = S.fromList T.allTypes, prevHS = Nothing, gen = g }

modBoard :: (B.Board -> B.Board) -> Game -> Game
modBoard f game = game { board = f $ board game }
setBoard :: B.Board -> Game -> Game
setBoard = modBoard . const

modScore, modLife, modMaxLife, modJunk, modLevel, modRound :: (Int -> Int) -> Game -> Game
modScore f game = game { score = f $ score game }
modLife f game = game { life = f $ life game }
modMaxLife f game = game { maxLife = f $ maxLife game }
modJunk f game = game { junk = f $ junk game }
modLevel f game = game { level = f $ level game }
modRound f game = game { round = f $ round game }
setScore, setLife, setMaxLife, setJunk, setLevel, setRound :: Int -> Game -> Game
setScore = modScore . const
setLife = modLife . const
setMaxLife = modMaxLife . const
setJunk = modJunk . const
setLevel = modLevel . const
setRound = modRound . const

setRoundItems :: [Item] -> Game -> Game
setRoundItems is game = game { roundItems = is }

modLevels :: (IM.IntMap BC.BoardConf -> IM.IntMap BC.BoardConf) -> Game -> Game
modLevels f game = game { levels = f $ levels game }

modPrev :: (Maybe Game -> Maybe Game) -> Game -> Game
modPrev f game = game { prev = f $ prev game }
setPrev :: Maybe Game -> Game -> Game
setPrev = modPrev . const

modLifeWithMax, modScoreWithMax :: (Int -> Int) -> Game -> Game
modLifeWithMax f game = modLife (min (maxLife game) . f) game
modScoreWithMax f = modScore $ min maxScore . f

modTransitions :: ([B.Transition] -> [B.Transition]) -> Game -> Game
modTransitions f game = game { transitions = f $ transitions game }
setTransitions :: [B.Transition] -> Game -> Game
setTransitions = modTransitions . const
pushTransition :: B.Transition -> Game -> Game
pushTransition = modTransitions . (:)

setSelectedSlot :: Maybe I.Slot -> Game -> Game
setSelectedSlot slot game = game { selectedSlot = slot }

modInventory :: (I.Inventory -> I.Inventory) -> Game -> Game
modInventory f game = game { inventory = f $ inventory game }
setInventory :: I.Inventory -> Game -> Game
setInventory = modInventory . const

modEquipment :: (S.Set Equipment -> S.Set Equipment) -> Game -> Game
modEquipment f game = game { equipment = f $ equipment game }
setEquipment :: S.Set Equipment -> Game -> Game
setEquipment = modEquipment . const

modUnseenBeats :: (S.Set T.Type -> S.Set T.Type) -> Game -> Game
modUnseenBeats f game = game { unseenBeats = f $ unseenBeats game }
setUnseenBeats :: S.Set T.Type -> Game -> Game
setUnseenBeats = modUnseenBeats . const

setPrevHS :: Maybe HS.Highscore -> Game -> Game
setPrevHS mhs game = game { prevHS = mhs }

hasEquip :: Equipment -> Game -> Bool
hasEquip e = (e `S.member`) . equipment

preserveSlots :: Game -> Int
preserveSlots game
    | hasEquip Bag game = 1
    | otherwise = 0

canGrab :: Game -> Bool
canGrab = hasEquip GrabHand

highscore :: Maybe HS.Username -> Game -> HS.Highscore
highscore name game = HS.Highscore
    { HS.score = score game
    , HS.maxRound = round game
    , HS.maxLevel = fix0 $ level game
    , HS.equipment = equipment game
    , HS.name = name
    }
    where
    fix0 0 = 3
    fix0 n = n

type T m = StateT Game m

runT :: MonadIO m => T m a -> m a
runT m = evalStateT m =<< new

nullGen :: StdGen
nullGen = mkStdGen 0

evalR :: MonadState Game m => Rand StdGen a -> m a
evalR m = do
    game <- get
    let (a,g) = runRand m $ gen game
    put $ game {gen = g}
    pure a

modifyR :: MonadState Game m => (Game -> Rand StdGen Game) -> m ()
modifyR f = do
    game <- get
    let (game',g) = runRand (f game) $ gen game
    put $ game' {gen = g}

modBoardM :: Monad m => (B.Board -> m B.Board) -> Game -> m Game
modBoardM f game =  (`setBoard` game) <$> f (board game)

initGame, nextRound :: (MonadState Game m, MonadIO m) => m ()
initGame = do
    beats <- gets unseenBeats
    hs <- gets $ highscore Nothing
    put =<< new
    let mhs = if HS.maxRound hs > 0 then Just hs else Nothing
    modify $ setPrevHS mhs . setUnseenBeats beats
nextRound = do
    modify . modInventory . I.clearAllBut =<< gets preserveSlots
    modify $ modRound (+1) . setLevel 1 . setPrev Nothing
    charmed <- gets $ hasEquip Charm
    let l = initLife + if charmed then charmBonus else 0
    modify $ setLife l . setMaxLife l
    modify . setRoundItems =<< evalR (take 3 <$> shuffle findableTreasures)
    enterNewBoard True =<< evalR (randMemberUnsafe B.boundaryWPoss)
    endTurn

enterNewBoard :: MonadState Game m => Bool -> P.WPos -> m ()
enterNewBoard doRecharge e = do
    powers <- gets $ (if doRecharge then M.map Pow.recharge else id) . B.powers . board
    bc <- gets currentLevelBC
    diffs <- evalR $ BC.genDiffs bc
    is <- gets roundItems
    modify . setBoard $ (B.enterAt e $ B.new bc) { B.powers = powers, B.diffs = diffs, B.possItems = is}
    setFov
    where
    currentLevelBC game = fromMaybe BC.emptyBoardConf . (IM.!? level game) $ levels game


setFov :: MonadState Game m => m ()
setFov = modifyR . modBoardM . B.setFov =<< gets (hasEquip Key)

addJunk :: MonadState Game m => m ()
addJunk = do
    modify (modJunk (+1))
    (gets enough >>=) . flip when $ do
        modify $ setJunk 0
        es <- gets equipment
        evalR (randMember (S.fromList allEquipment S.\\ es)) >>= \case
            Nothing -> modify $ modScoreWithMax (+1)
            Just e  -> do
                modify . modEquipment $ S.insert e
                onAdd e
    where
    enough g = junk g > S.size (equipment g) + 1
    onAdd Charm = modify $ modMaxLife (+charmBonus)
    onAdd Siphon = modify . modBoard $ B.modPowers (M.map $ Pow.setOverUsable True)
    onAdd _     = pure ()

collect :: MonadState Game m => [Item] -> m ()
collect = mapM_ collect' where
    collect' Gem                = modify . modBoard . B.addPower =<< gets (hasEquip Siphon)
    collect' ScoreTreasure           = modify $ modScoreWithMax (+1)
    collect' Potion           = modify $ modLifeWithMax (+4)
    collect' MiniPotion           = modify $ modLifeWithMax (+2)
    collect' Junk             = addJunk
    collect' (UmbrellaHandle _) = collect' (ItemInvItem Umbrella)
    collect' CameraBoxed        = modify . modInventory $ snd . I.add (Camera initCameraCharge)
    collect' (RollingOrb _ _)   = collect' (ItemInvItem Orb)
    collect' (ItemInvItem (Camera 0))      = pure ()
    collect' (ItemInvItem e)      = modify . modInventory $ snd . I.add e

clearTrans :: MonadState Game m => m ()
clearTrans = modify $ setTransitions []

modBoardTellM :: MonadState Game m => (B.Board -> WriterT a m B.Board) -> m a
modBoardTellM f = do
    (bd,a) <- runWriterT . f =<< gets board
    modify (setBoard bd) $> a
modBoardTell :: MonadState Game m => (B.Board -> Writer a B.Board) -> m a
modBoardTell = modBoardTellM . (mapWriterT (pure . runIdentity) .)

exitLevel :: MonadState Game m => P.WPos -> m ()
exitLevel exitPos = do
    endLevel $ P.exitDir exitPos
    lev <- gets level
    when (lev <= maxLevel) $
        enterNewBoard False $ B.oppositeWPos exitPos
    where
    endLevel :: MonadState Game m => P.Dir -> m ()
    endLevel dir = do
        diffs <- gets $ B.diffs . board
        lev <- gets level
        modify . modLevels $ IM.adjust (BC.apply diffs dir) lev
        modify (modLevel $ (`mod` 4) . (+1))

movePlayer :: MonadState Game m => P.Dir -> m ()
movePlayer dir = do
    bd <- gets board
    mr <- modBoardTell $ B.movePlayers dir
    when (getAny . B.someAction $ mr) $ do
        modify $ modLifeWithMax (+ (-(getSum $ B.damage mr)))
        showAlerts bd $ B.alerts mr
        envAct
        mapM_ exitLevel $ B.exitings mr
        endTurn

showAlerts :: MonadState Game m => B.Board -> [B.Alert] -> m ()
showAlerts bd alerts = unless (null alerts) $ modify . pushTransition $ B.Transition bd alerts

useInvSlotInDir :: MonadState Game m => I.Slot -> P.Dir -> m ()
useInvSlotInDir slot dir =
    gets ((M.!? slot) . I.invItems . inventory) >>= \case
        Nothing -> (gets canGrab >>=) . flip when $ do
            is <- modBoardTell (B.grabItem dir)
            unless (null is) $ collect is >> envAct >> endTurn
        Just e -> do
            bd <- gets board
            case runWriterT $ B.tryUseInvItem e dir bd of
                Nothing -> pure ()
                Just (bd', alerts) -> do
                    showAlerts bd alerts
                    modify $ setBoard bd'
                    modify . modInventory . I.modInvItems $ useUp slot
                    envAct
                    endTurn
    where
    useUp :: I.Slot -> M.Map I.Slot InvItem -> M.Map I.Slot InvItem
    useUp s inv
        | Just (Spraypaint n) <- inv M.!? s
            , n > 1 = M.insert s (Spraypaint $ n-1) inv
        | otherwise = M.delete s inv


envAct :: MonadState Game m => m ()
envAct = do
    bd <- gets board
    modBoardTellM (mapWriterT evalR . B.npcsAct) >>= showAlerts bd
    bd' <- gets board
    modBoardTell B.doPhysics >>= showAlerts bd'
    collect =<< modBoardTell B.collectItems
    setFov
    -- | collect again, in case vision spawned something on our loc
    collect =<< modBoardTell B.collectItems

undoTurns :: Int
undoTurns = 5

endTurn :: MonadState Game m => m ()
endTurn = do
    undoCharges <- gets $ maybe 0 Pow.activatableTimes . (M.!? undoPos) . B.powers . board
    modify . eraseBefore $ undoTurns * undoCharges
    modify . setPrev . Just =<< get
    gets ((<=0) . life) >>= flip when (modify $ modBoard B.setPlayerDead)
    where
    eraseBefore n | n <= 0 = setPrev Nothing
    eraseBefore n = modPrev (eraseBefore (n-1) <$>)
    undoPos = P.Pos 2 2

powerOn :: Game -> Maybe Pow.Power
powerOn game | let bd = board game, p:_ <- B.playerPoss bd = B.powers bd M.!? p
powerOn _ = Nothing

activatePower :: MonadState Game m => m ()
activatePower = do
    bd <- gets board
    case True of
        _ | p:_ <- B.playerPoss bd
          , Just pow <- B.powers bd M.!? p
          , Pow.activatable pow
          -> do
              when (Pow.tp pow == Pow.Foresight) . modifyR $ modBoardM B.beginExpect
              -- |XXX: Be careful of the subtle interaction with the undo power
              -- when changing this.
              modify $ modBoard (B.modPowers $ M.alter (Pow.deplete =<<) p) . doPower (Pow.tp pow) p
              unless (Pow.tp pow == Pow.Undo) envAct
              endTurn
        _ -> pure ()
    where
    doPower Pow.Heal _ = modLifeWithMax (+2)
    doPower Pow.Smoke _ = modBoard $ B.incStatus B.Smoke (B.maxSmoke + 1)
    doPower Pow.Haste _ = modBoard $ B.incStatus B.Haste 8
    doPower Pow.Dazzle _ = modBoard $ B.incStatus B.Dazzled 5
    doPower Pow.Ghost _ = modBoard $ B.incStatus B.Ghost 6
    doPower Pow.Foresight _ = modBoard $ B.incStatus B.Foresight 11
    doPower Pow.Teleport p = modBoard $ B.setSafe True . B.modCreatures (M.delete p . M.insert (centre +^ centre +^ neg p) Player)
    doPower Pow.Undo _ = \game -> let (game',trans) = runWriter $ prevTurn undoTurns game in game' { transitions = reverse trans } where
        prevTurn :: Int -> Game -> Writer [B.Transition] Game
        prevTurn n g | n < 0 = pure g
        prevTurn n g = maybe (pure g) ((tell [B.Transition (board g) []] >>) . prevTurn (n-1)) $ prev g
    centre = P.Pos 2 2

data PlayState = Playing | Dead | RoundEnded | Won | Tutorialising T.Beat deriving Eq
playState :: Game -> PlayState
playState game
    | level game == 0 = RoundEnded
    | life game <= 0 = Dead
    | score game >= maxScore = Won
    | Just b <- S.lookupMin $ triggeredBeats game = Tutorialising b
    | otherwise = Playing

doCommand :: (MonadState Game m, MonadIO m) => C.Command -> m ()
doCommand c = gets playState >>= \case
    Dead -> case c of
        C.Accept -> initGame
        _        -> pure ()
    Won -> case c of
        C.Accept -> initGame
        _        -> pure ()
    RoundEnded -> case c of
        C.Accept -> nextRound
        C.SkipTutorial -> modify (setUnseenBeats $ S.fromList T.allTypes) >> nextRound
        _        -> pure ()
    Tutorialising b -> case c of
        C.Accept       -> modify . modUnseenBeats . S.delete $ T.tp b
        C.SkipTutorial -> modify $ setUnseenBeats S.empty
        _              -> pure ()
    Playing -> case c of
        C.Dir dir -> do
            gets selectedSlot >>= \case
                Nothing -> movePlayer dir
                Just slot -> do
                    modify $ setSelectedSlot Nothing
                    useInvSlotInDir slot dir
        C.UseInv slot -> do
            gets selectedSlot >>= modify . \case
                Just s | s == slot -> setSelectedSlot Nothing
                Just s' -> modInventory (I.swap slot s') . setSelectedSlot Nothing
                Nothing -> setSelectedSlot $ Just slot
        C.UsePower -> activatePower
#ifdef DEBUG
        C.DebugAddPower -> modify . modBoard . B.addPower =<< gets (hasEquip Siphon)
        C.DebugAddJunk -> addJunk
        C.DebugAddItems -> collect findableTreasures
        C.DebugExit -> exitLevel =<< evalR (randElemUnsafe $ S.toList B.boundaryWPoss)
#endif
        _ -> pure ()

triggeredBeats :: Game -> S.Set T.Beat
triggeredBeats game = S.unions . S.map triggered $ unseenBeats game where
    triggered T.TMeta = S.singleton T.Meta
    triggered T.TMeta2 = S.singleton T.Meta2
    triggered T.TMovement | p:_ <- B.playerPoss bd = S.singleton $ T.Movement p
    triggered T.TTrapped | p:_ <- B.playerPoss bd
        , all (trappedDir p) P.dirs
        , any ((`M.member` B.walls bd) . P.wposInDir p) P.dirs
        = S.singleton $ T.Trapped p
    triggered T.TSeeMonster = uncurry T.SeeMonster `S.map` (S.fromList . M.assocs . M.filter isMonster $ B.creatures bd)
    triggered T.TSeeExit = T.SeeExit `S.map` M.keysSet (M.filter (== Exit) $ B.exits bd)
    triggered T.TSeeItem = uncurry T.SeeItem `S.map` (S.fromList . M.assocs . M.filter (`notElem` [Potion, MiniPotion, ScoreTreasure, Junk, Gem]) $ B.items bd)
    triggered T.TSeePotion = T.SeePotion `S.map` M.keysSet (M.filter (== Potion) $ B.items bd)
    triggered T.TSeeMiniPotion = T.SeeMiniPotion `S.map` M.keysSet (M.filter (== MiniPotion) $ B.items bd)
    triggered T.TSeeScore = T.SeeScore `S.map` M.keysSet (M.filter (== ScoreTreasure) $ B.items bd)
    triggered T.TSeeJunk = T.SeeJunk `S.map` M.keysSet (M.filter (== Junk) $ B.items bd)
    triggered T.TSeeGem = T.SeeGem `S.map` M.keysSet (M.filter (== Gem) $ B.items bd)
    triggered T.THurt | life game < maxLife game = sng $ T.Hurt (life game) (maxLife game)
    triggered T.TCollectItem | 1 `M.member` I.invItems (inventory game) = sng T.CollectItem
    triggered T.TCollectItem2 | 1 `M.member` I.invItems (inventory game) = sng T.CollectItem2
    triggered T.TCollectGem | p:_ <- B.playerPoss bd, p `M.member` B.powers bd = sng T.CollectGem
    triggered T.TCollectScore | score game == 1 = sng T.CollectScore
    triggered T.TTimer | (RF.sides . BC.creatureRoll $ B.conf bd) < initCreatureSides - 2 = sng T.Timer
    triggered T.TSecondRound | round game > 1 = sng T.SecondRound
    triggered T.TTutEnd | S.size (unseenBeats game) == 1 = sng T.TutEnd
    triggered _ = S.empty
    trappedDir p dir = or [ not $ B.inBounds p'
        , p' `M.member` B.creatures bd
        , P.wposInDir p dir `M.member` B.walls bd ]
        where p' = p +^ P.dirPos dir
    sng = S.singleton
    bd = board game