{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Game where
import Prelude hiding (round)
import Control.Monad.Random
import Control.Monad.State
import Control.Monad.Writer
import Data.Functor
import Data.Functor.Identity
import Data.Maybe
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