module Game.LambdaHack.Atomic.PosAtomicRead
( PosAtomic(..), posUpdAtomic, posSfxAtomic
, breakUpdAtomic, seenAtomicCli, seenAtomicSer
#ifdef EXPOSE_INTERNAL
, posProjBody, singleAid, doubleAid, singleContainer
#endif
) where
import Prelude ()
import Game.LambdaHack.Common.Prelude
import qualified Data.EnumSet as ES
import Game.LambdaHack.Atomic.CmdAtomic
import Game.LambdaHack.Common.Actor
import Game.LambdaHack.Common.ActorState
import Game.LambdaHack.Common.Faction
import Game.LambdaHack.Common.Level
import Game.LambdaHack.Common.Misc
import Game.LambdaHack.Common.MonadStateRead
import Game.LambdaHack.Common.Perception
import Game.LambdaHack.Common.Point
data PosAtomic =
PosSight LevelId [Point]
| PosFidAndSight [FactionId] LevelId [Point]
| PosSmell LevelId [Point]
| PosFid FactionId
| PosFidAndSer (Maybe LevelId) FactionId
| PosSer
| PosAll
| PosNone
deriving (Show, Eq)
posUpdAtomic :: MonadStateRead m => UpdAtomic -> m PosAtomic
posUpdAtomic cmd = case cmd of
UpdCreateActor _ body _ -> return $! posProjBody body
UpdDestroyActor _ body _ -> return $! posProjBody body
UpdCreateItem _ _ _ c -> singleContainer c
UpdDestroyItem _ _ _ c -> singleContainer c
UpdSpotActor _ body _ -> return $! posProjBody body
UpdLoseActor _ body _ -> return $! posProjBody body
UpdSpotItem _ _ _ _ c -> singleContainer c
UpdLoseItem _ _ _ _ c -> singleContainer c
UpdSpotItemBag c _ _ -> singleContainer c
UpdLoseItemBag c _ _ -> singleContainer c
UpdMoveActor aid fromP toP -> do
b <- getsState $ getActorBody aid
return $! if bproj b
then PosSight (blid b) [fromP, toP]
else PosFidAndSight [bfid b] (blid b) [fromP, toP]
UpdWaitActor aid _ -> singleAid aid
UpdDisplaceActor source target -> doubleAid source target
UpdMoveItem _ _ _ _ CSha ->
error $ "" `showFailure` cmd
UpdMoveItem _ _ _ CSha _ -> error $ "" `showFailure` cmd
UpdMoveItem _ _ aid _ _ -> singleAid aid
UpdRefillHP aid _ -> singleAid aid
UpdRefillCalm aid _ -> singleAid aid
UpdTrajectory aid _ _ -> singleAid aid
UpdQuitFaction{} -> return PosAll
UpdLeadFaction fid _ _ -> return $ PosFidAndSer Nothing fid
UpdDiplFaction{} -> return PosAll
UpdTacticFaction fid _ _ -> return $! PosFidAndSer Nothing fid
UpdAutoFaction{} -> return PosAll
UpdRecordKill aid _ _ -> singleAid aid
UpdAlterTile lid p _ _ -> return $! PosSight lid [p]
UpdAlterExplorable{} -> return PosAll
UpdSearchTile aid p _ -> do
b <- getsState $ getActorBody aid
return $! PosFidAndSight [bfid b] (blid b) [bpos b, p]
UpdHideTile aid p _ -> do
b <- getsState $ getActorBody aid
return $! PosFidAndSight [bfid b] (blid b) [bpos b, p]
UpdSpotTile lid ts -> do
let ps = map fst ts
return $! PosSight lid ps
UpdLoseTile lid ts -> do
let ps = map fst ts
return $! PosSight lid ps
UpdAlterSmell lid p _ _ -> return $! PosSmell lid [p]
UpdSpotSmell lid sms -> do
let ps = map fst sms
return $! PosSmell lid ps
UpdLoseSmell lid sms -> do
let ps = map fst sms
return $! PosSmell lid ps
UpdTimeItem _ c _ _ -> singleContainer c
UpdAgeGame _ -> return PosAll
UpdUnAgeGame _ -> return PosAll
UpdDiscover c _ _ _ -> singleContainer c
UpdCover c _ _ _ -> singleContainer c
UpdDiscoverKind c _ _ -> singleContainer c
UpdCoverKind c _ _ -> singleContainer c
UpdDiscoverSeed c _ _ -> singleContainer c
UpdCoverSeed c _ _ -> singleContainer c
UpdDiscoverServer{} -> return PosSer
UpdCoverServer{} -> return PosSer
UpdPerception{} -> return PosNone
UpdRestart fid _ _ _ _ -> return $! PosFid fid
UpdRestartServer _ -> return PosSer
UpdResume _ _ -> return PosNone
UpdResumeServer _ -> return PosSer
UpdKillExit fid -> return $! PosFid fid
UpdWriteSave -> return PosAll
posSfxAtomic :: MonadStateRead m => SfxAtomic -> m PosAtomic
posSfxAtomic cmd = case cmd of
SfxStrike _ _ _ CSha -> return PosNone
SfxStrike _ target _ _ -> singleAid target
SfxRecoil _ _ _ CSha -> return PosNone
SfxRecoil _ target _ _ -> singleAid target
SfxSteal _ _ _ CSha -> return PosNone
SfxSteal _ target _ _ -> singleAid target
SfxRelease _ _ _ CSha -> return PosNone
SfxRelease _ target _ _ -> singleAid target
SfxProject aid _ cstore -> singleContainer $ CActor aid cstore
SfxReceive aid _ cstore -> singleContainer $ CActor aid cstore
SfxApply aid _ cstore -> singleContainer $ CActor aid cstore
SfxCheck aid _ cstore -> singleContainer $ CActor aid cstore
SfxTrigger aid p -> do
body <- getsState $ getActorBody aid
if bproj body
then return $! PosSight (blid body) [bpos body, p]
else return $! PosFidAndSight [bfid body] (blid body) [bpos body, p]
SfxShun aid p -> do
body <- getsState $ getActorBody aid
if bproj body
then return $! PosSight (blid body) [bpos body, p]
else return $! PosFidAndSight [bfid body] (blid body) [bpos body, p]
SfxEffect _ aid _ _ -> singleAid aid
SfxMsgFid fid _ -> return $! PosFid fid
SfxSortSlots -> return PosAll
posProjBody :: Actor -> PosAtomic
posProjBody body =
if bproj body
then PosSight (blid body) [bpos body]
else PosFidAndSight [bfid body] (blid body) [bpos body]
singleAid :: MonadStateRead m => ActorId -> m PosAtomic
singleAid aid = do
body <- getsState $ getActorBody aid
return $! posProjBody body
doubleAid :: MonadStateRead m => ActorId -> ActorId -> m PosAtomic
doubleAid source target = do
sb <- getsState $ getActorBody source
tb <- getsState $ getActorBody target
return $! assert (blid sb == blid tb) $ PosSight (blid sb) [bpos sb, bpos tb]
singleContainer :: MonadStateRead m => Container -> m PosAtomic
singleContainer (CFloor lid p) = return $! PosSight lid [p]
singleContainer (CEmbed lid p) = return $! PosSight lid [p]
singleContainer (CActor aid CSha) = do
b <- getsState $ getActorBody aid
return $! PosFidAndSer (Just $ blid b) (bfid b)
singleContainer (CActor aid _) = singleAid aid
singleContainer (CTrunk fid lid p) =
return $! PosFidAndSight [fid] lid [p]
breakUpdAtomic :: MonadStateRead m => UpdAtomic -> m [UpdAtomic]
breakUpdAtomic cmd = case cmd of
UpdMoveActor aid fromP toP -> do
b <- getsState $ getActorBody aid
ais <- getsState $ getCarriedAssocs b
return [ UpdLoseActor aid b ais
, UpdSpotActor aid b {bpos = toP, boldpos = Just fromP} ais ]
UpdDisplaceActor source target -> do
sb <- getsState $ getActorBody source
sais <- getsState $ getCarriedAssocs sb
tb <- getsState $ getActorBody target
tais <- getsState $ getCarriedAssocs tb
return [ UpdLoseActor source sb sais
, UpdSpotActor source sb { bpos = bpos tb
, boldpos = Just $ bpos sb } sais
, UpdLoseActor target tb tais
, UpdSpotActor target tb { bpos = bpos sb
, boldpos = Just $ bpos tb } tais
]
_ -> return []
seenAtomicCli :: Bool -> FactionId -> Perception -> PosAtomic -> Bool
seenAtomicCli knowEvents fid per posAtomic =
case posAtomic of
PosSight _ ps -> all (`ES.member` totalVisible per) ps || knowEvents
PosFidAndSight fids _ ps ->
fid `elem` fids || all (`ES.member` totalVisible per) ps || knowEvents
PosSmell _ ps -> all (`ES.member` totalSmelled per) ps || knowEvents
PosFid fid2 -> fid == fid2
PosFidAndSer _ fid2 -> fid == fid2
PosSer -> False
PosAll -> True
PosNone -> error $ "no position possible" `showFailure` fid
seenAtomicSer :: PosAtomic -> Bool
seenAtomicSer posAtomic =
case posAtomic of
PosFid _ -> False
PosNone -> error $ "no position possible" `showFailure` posAtomic
_ -> True