module Game.LambdaHack.Common.AtomicPos
( PosAtomic(..), posCmdAtomic, posSfxAtomic
, resetsFovAtomic, breakCmdAtomic, loudCmdAtomic
, seenAtomicCli, seenAtomicSer
) where
import qualified Data.EnumSet as ES
import Game.LambdaHack.Common.Action
import Game.LambdaHack.Common.Actor
import Game.LambdaHack.Common.ActorState
import Game.LambdaHack.Common.AtomicCmd
import Game.LambdaHack.Common.AtomicSem (posOfAid, posOfContainer)
import Game.LambdaHack.Common.Faction
import Game.LambdaHack.Common.Level
import Game.LambdaHack.Common.Perception
import Game.LambdaHack.Common.Point
import Control.Exception.Assert.Sugar
data PosAtomic =
PosSight !LevelId ![Point]
| PosFidAndSight !FactionId !LevelId ![Point]
| PosSmell !LevelId ![Point]
| PosFid !FactionId
| PosFidAndSer !FactionId
| PosSer
| PosAll
| PosNone
deriving (Show, Eq)
posCmdAtomic :: MonadActionRO m => CmdAtomic -> m PosAtomic
posCmdAtomic cmd = case cmd of
CreateActorA _ body _ ->
return $ PosFidAndSight (bfid body) (blid body) [bpos body]
DestroyActorA _ body _ ->
return $ PosFidAndSight (bfid body) (blid body) [bpos body]
CreateItemA _ _ _ c -> singleContainer c
DestroyItemA _ _ _ c -> singleContainer c
SpotActorA _ body _ ->
return $ PosFidAndSight (bfid body) (blid body) [bpos body]
LoseActorA _ body _ ->
return $ PosFidAndSight (bfid body) (blid body) [bpos body]
SpotItemA _ _ _ c -> singleContainer c
LoseItemA _ _ _ c -> singleContainer c
MoveActorA aid fromP toP -> do
(lid, _) <- posOfAid aid
return $ PosSight lid [fromP, toP]
WaitActorA aid _ _ -> singleAid aid
DisplaceActorA source target -> do
(slid, sp) <- posOfAid source
(tlid, tp) <- posOfAid target
return $ assert (slid == tlid) $ PosSight slid [sp, tp]
MoveItemA _ _ c1 c2 -> do
(lid1, p1) <- posOfContainer c1
(lid2, p2) <- posOfContainer c2
return $ assert (lid1 == lid2) $ PosSight lid1 [p1, p2]
AgeActorA aid _ -> singleAid aid
HealActorA aid _ -> singleAid aid
HasteActorA aid _ -> singleAid aid
PathActorA aid _ _ -> singleAid aid
ColorActorA aid _ _ -> singleAid aid
QuitFactionA{} -> return PosAll
LeadFactionA fid _ _ -> return $ PosFidAndSer fid
DiplFactionA{} -> return PosAll
AlterTileA lid p _ _ -> return $ PosSight lid [p]
SearchTileA aid p _ _ -> do
(lid, pos) <- posOfAid aid
return $ PosSight lid [pos, p]
SpotTileA lid ts -> do
let ps = map fst ts
return $ PosSight lid ps
LoseTileA lid ts -> do
let ps = map fst ts
return $ PosSight lid ps
AlterSmellA lid p _ _ -> return $ PosSmell lid [p]
SpotSmellA lid sms -> do
let ps = map fst sms
return $ PosSmell lid ps
LoseSmellA lid sms -> do
let ps = map fst sms
return $ PosSmell lid ps
AgeLevelA lid _ -> return $ PosSight lid []
AgeGameA _ -> return PosAll
DiscoverA lid p _ _ -> return $ PosSight lid [p]
CoverA lid p _ _ -> return $ PosSight lid [p]
PerceptionA{} -> return PosNone
RestartA fid _ _ _ _ _ -> return $ PosFid fid
RestartServerA _ -> return PosSer
ResumeA fid _ -> return $ PosFid fid
ResumeServerA _ -> return PosSer
KillExitA fid -> return $ PosFid fid
SaveBkpA -> return PosAll
MsgAllA{} -> return PosAll
posSfxAtomic :: MonadActionRO m => SfxAtomic -> m PosAtomic
posSfxAtomic cmd = case cmd of
StrikeD source target _ _ -> do
(slid, sp) <- posOfAid source
(tlid, tp) <- posOfAid target
return $ assert (slid == tlid) $ PosSight slid [sp, tp]
RecoilD source target _ _ -> do
(slid, sp) <- posOfAid source
(tlid, tp) <- posOfAid target
return $ assert (slid == tlid) $ PosSight slid [sp, tp]
ProjectD aid _ -> singleAid aid
CatchD aid _ -> singleAid aid
ActivateD aid _ -> singleAid aid
CheckD aid _ -> singleAid aid
TriggerD aid p _ -> do
(lid, pa) <- posOfAid aid
return $ PosSight lid [pa, p]
ShunD aid p _ -> do
(lid, pa) <- posOfAid aid
return $ PosSight lid [pa, p]
EffectD aid _ -> singleAid aid
MsgFidD fid _ -> return $ PosFid fid
MsgAllD _ -> return PosAll
DisplayPushD fid -> return $ PosFid fid
DisplayDelayD fid -> return $ PosFid fid
RecordHistoryD fid -> return $ PosFid fid
singleAid :: MonadActionRO m => ActorId -> m PosAtomic
singleAid aid = do
b <- getsState $ getActorBody aid
return $ PosFidAndSight (bfid b) (blid b) [bpos b]
singleContainer :: MonadActionRO m => Container -> m PosAtomic
singleContainer c = do
(lid, p) <- posOfContainer c
return $ PosSight lid [p]
resetsFovAtomic :: MonadActionRO m => CmdAtomic -> m (Maybe [FactionId])
resetsFovAtomic cmd = case cmd of
CreateActorA _ body _ -> return $ Just [bfid body]
DestroyActorA _ body _ -> return $ Just [bfid body]
SpotActorA _ body _ -> return $ Just [bfid body]
LoseActorA _ body _ -> return $ Just [bfid body]
CreateItemA{} -> return $ Just []
DestroyItemA{} -> return $ Just []
MoveActorA aid _ _ -> fmap Just $ fidOfAid aid
DisplaceActorA source target -> do
sfid <- fidOfAid source
tfid <- fidOfAid target
return $ Just $ if source == target
then []
else sfid ++ tfid
MoveItemA{} -> return $ Just []
AlterTileA{} -> return Nothing
_ -> return $ Just []
fidOfAid :: MonadActionRO m => ActorId -> m [FactionId]
fidOfAid aid = getsState $ (: []) . bfid . getActorBody aid
breakCmdAtomic :: MonadActionRO m => CmdAtomic -> m [CmdAtomic]
breakCmdAtomic cmd = case cmd of
MoveActorA aid _ toP -> do
b <- getsState $ getActorBody aid
ais <- getsState $ getActorItem aid
return [ LoseActorA aid b ais
, SpotActorA aid b {bpos = toP, boldpos = bpos b} ais ]
DisplaceActorA source target -> do
sb <- getsState $ getActorBody source
sais <- getsState $ getActorItem source
tb <- getsState $ getActorBody target
tais <- getsState $ getActorItem target
return [ LoseActorA source sb sais
, SpotActorA source sb {bpos = bpos tb, boldpos = bpos sb} sais
, LoseActorA target tb tais
, SpotActorA target tb {bpos = bpos sb, boldpos = bpos tb} tais
]
MoveItemA iid k c1 c2 -> do
item <- getsState $ getItemBody iid
return [LoseItemA iid item k c1, SpotItemA iid item k c2]
_ -> return [cmd]
loudCmdAtomic :: FactionId -> CmdAtomic -> Bool
loudCmdAtomic fid cmd = case cmd of
DestroyActorA _ body _ ->
not $ fid == bfid body || bproj body
_ -> False
seenAtomicCli :: Bool -> FactionId -> Perception -> PosAtomic -> Bool
seenAtomicCli knowEvents fid per posAtomic =
case posAtomic of
PosSight _ ps -> knowEvents || all (`ES.member` totalVisible per) ps
PosFidAndSight fid2 _ ps ->
knowEvents || fid == fid2 || all (`ES.member` totalVisible per) ps
PosSmell _ ps -> knowEvents || all (`ES.member` smellVisible per) ps
PosFid fid2 -> fid == fid2
PosFidAndSer fid2 -> fid == fid2
PosSer -> False
PosAll -> True
PosNone -> assert `failure` "no position possible" `twith` fid
seenAtomicSer :: PosAtomic -> Bool
seenAtomicSer posAtomic =
case posAtomic of
PosFid _ -> False
PosNone -> assert `failure` "wrong position for server" `twith` posAtomic
_ -> True