-- | Semantics of requests
-- .
-- A couple of them do not take time, the rest does.
-- Note that since the results are atomic commands, which are executed
-- only later (on the server and some of the clients), all condition
-- are checkd by the semantic functions in the context of the state
-- before the server command. Even if one or more atomic actions
-- are already issued by the point an expression is evaluated, they do not
-- influence the outcome of the evaluation.
module Game.LambdaHack.Server.HandleRequestM
  ( handleRequestAI, handleRequestUI, handleRequestTimed, switchLeader
  , reqMoveGeneric, reqDisplaceGeneric, reqAlterFail
  , reqGameDropAndExit, reqGameSaveAndExit
#ifdef EXPOSE_INTERNAL
    -- * Internal operations
  , execFailure, checkWaiting, processWatchfulness, affectStash
  , managePerRequest, handleRequestTimedCases, affectSmell
  , reqMove, reqMelee, reqMeleeChecked, reqDisplace, reqAlter
  , reqWait, reqWait10, reqYell, reqMoveItems, reqMoveItem, reqProject, reqApply
  , reqGameRestart, reqGameSave, reqDoctrine, reqAutomate
#endif
  ) where

import Prelude ()

import Game.LambdaHack.Core.Prelude

import qualified Data.EnumMap.Strict as EM
import qualified Data.Text as T
import qualified Text.Show.Pretty as Show.Pretty

import           Game.LambdaHack.Atomic
import           Game.LambdaHack.Client
  (ReqAI (..), ReqUI (..), RequestTimed (..))
import           Game.LambdaHack.Common.Actor
import           Game.LambdaHack.Common.ActorState
import           Game.LambdaHack.Common.Analytics
import           Game.LambdaHack.Common.Faction
import           Game.LambdaHack.Common.Item
import qualified Game.LambdaHack.Common.ItemAspect as IA
import           Game.LambdaHack.Common.Kind
import           Game.LambdaHack.Common.Level
import           Game.LambdaHack.Common.Misc
import           Game.LambdaHack.Common.MonadStateRead
import           Game.LambdaHack.Common.Point
import           Game.LambdaHack.Common.ReqFailure
import           Game.LambdaHack.Common.State
import qualified Game.LambdaHack.Common.Tile as Tile
import           Game.LambdaHack.Common.Time
import           Game.LambdaHack.Common.Types
import           Game.LambdaHack.Common.Vector
import           Game.LambdaHack.Content.FactionKind
import qualified Game.LambdaHack.Content.ItemKind as IK
import           Game.LambdaHack.Content.ModeKind
import qualified Game.LambdaHack.Content.TileKind as TK
import qualified Game.LambdaHack.Definition.Ability as Ability
import           Game.LambdaHack.Definition.Defs
import           Game.LambdaHack.Server.CommonM
import           Game.LambdaHack.Server.HandleEffectM
import           Game.LambdaHack.Server.ItemM
import           Game.LambdaHack.Server.MonadServer
import           Game.LambdaHack.Server.PeriodicM
import           Game.LambdaHack.Server.ServerOptions
import           Game.LambdaHack.Server.State

execFailure :: MonadServerAtomic m
            => ActorId -> RequestTimed -> ReqFailure -> m ()
execFailure :: ActorId -> RequestTimed -> ReqFailure -> m ()
execFailure ActorId
aid RequestTimed
req ReqFailure
failureSer = do
  -- Clients should rarely do that (only in case of invisible actors)
  -- so we report it to the client, but do not crash
  -- (server should work OK with stupid clients, too).
  Actor
body <- (State -> Actor) -> m Actor
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
aid
  let fid :: FactionId
fid = Actor -> FactionId
bfid Actor
body
      msg :: Text
msg = ReqFailure -> Text
showReqFailure ReqFailure
failureSer
      impossible :: Bool
impossible = ReqFailure -> Bool
impossibleReqFailure ReqFailure
failureSer
      debugShow :: Show a => a -> Text
      debugShow :: a -> Text
debugShow = String -> Text
T.pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
Show.Pretty.ppShow
      possiblyAlarm :: Text -> m ()
possiblyAlarm = if Bool
impossible
                      then Text -> m ()
forall (m :: * -> *). MonadServer m => Text -> m ()
debugPossiblyPrintAndExit
                      else Text -> m ()
forall (m :: * -> *). MonadServer m => Text -> m ()
debugPossiblyPrint
  Text -> m ()
possiblyAlarm (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
    Text
"Server: execFailure:" Text -> Text -> Text
<+> Text
msg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Actor -> Text
forall a. Show a => a -> Text
debugShow Actor
body Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> RequestTimed -> Text
forall a. Show a => a -> Text
debugShow RequestTimed
req Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ReqFailure -> Text
forall a. Show a => a -> Text
debugShow ReqFailure
failureSer
  SfxAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => SfxAtomic -> m ()
execSfxAtomic (SfxAtomic -> m ()) -> SfxAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ FactionId -> SfxMsg -> SfxAtomic
SfxMsgFid FactionId
fid (SfxMsg -> SfxAtomic) -> SfxMsg -> SfxAtomic
forall a b. (a -> b) -> a -> b
$ ReqFailure -> SfxMsg
SfxUnexpected ReqFailure
failureSer

-- | The semantics of server commands.
-- AI always takes time and so doesn't loop.
handleRequestAI :: MonadServerAtomic m
                => ReqAI
                -> m (Maybe RequestTimed)
handleRequestAI :: ReqAI -> m (Maybe RequestTimed)
handleRequestAI ReqAI
cmd = case ReqAI
cmd of
  ReqAITimed RequestTimed
cmdT -> Maybe RequestTimed -> m (Maybe RequestTimed)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe RequestTimed -> m (Maybe RequestTimed))
-> Maybe RequestTimed -> m (Maybe RequestTimed)
forall a b. (a -> b) -> a -> b
$ RequestTimed -> Maybe RequestTimed
forall a. a -> Maybe a
Just RequestTimed
cmdT
  ReqAI
ReqAINop -> Maybe RequestTimed -> m (Maybe RequestTimed)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe RequestTimed
forall a. Maybe a
Nothing

-- | The semantics of server commands. Only the first two cases affect time.
handleRequestUI :: MonadServerAtomic m
                => FactionId -> ActorId -> ReqUI
                -> m (Maybe RequestTimed)
handleRequestUI :: FactionId -> ActorId -> ReqUI -> m (Maybe RequestTimed)
handleRequestUI FactionId
fid ActorId
aid ReqUI
cmd = case ReqUI
cmd of
  ReqUITimed RequestTimed
cmdT -> Maybe RequestTimed -> m (Maybe RequestTimed)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe RequestTimed -> m (Maybe RequestTimed))
-> Maybe RequestTimed -> m (Maybe RequestTimed)
forall a b. (a -> b) -> a -> b
$ RequestTimed -> Maybe RequestTimed
forall a. a -> Maybe a
Just RequestTimed
cmdT
  ReqUIGameRestart GroupName ModeKind
t Challenge
d -> ActorId -> GroupName ModeKind -> Challenge -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId -> GroupName ModeKind -> Challenge -> m ()
reqGameRestart ActorId
aid GroupName ModeKind
t Challenge
d m () -> m (Maybe RequestTimed) -> m (Maybe RequestTimed)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe RequestTimed -> m (Maybe RequestTimed)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe RequestTimed
forall a. Maybe a
Nothing
  ReqUI
ReqUIGameDropAndExit -> ActorId -> m ()
forall (m :: * -> *). MonadServerAtomic m => ActorId -> m ()
reqGameDropAndExit ActorId
aid m () -> m (Maybe RequestTimed) -> m (Maybe RequestTimed)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe RequestTimed -> m (Maybe RequestTimed)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe RequestTimed
forall a. Maybe a
Nothing
  ReqUI
ReqUIGameSaveAndExit -> ActorId -> m ()
forall (m :: * -> *). MonadServerAtomic m => ActorId -> m ()
reqGameSaveAndExit ActorId
aid m () -> m (Maybe RequestTimed) -> m (Maybe RequestTimed)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe RequestTimed -> m (Maybe RequestTimed)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe RequestTimed
forall a. Maybe a
Nothing
  ReqUI
ReqUIGameSave -> m ()
forall (m :: * -> *). MonadServer m => m ()
reqGameSave m () -> m (Maybe RequestTimed) -> m (Maybe RequestTimed)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe RequestTimed -> m (Maybe RequestTimed)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe RequestTimed
forall a. Maybe a
Nothing
  ReqUIDoctrine Doctrine
toT -> FactionId -> Doctrine -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
FactionId -> Doctrine -> m ()
reqDoctrine FactionId
fid Doctrine
toT m () -> m (Maybe RequestTimed) -> m (Maybe RequestTimed)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe RequestTimed -> m (Maybe RequestTimed)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe RequestTimed
forall a. Maybe a
Nothing
  ReqUI
ReqUIAutomate -> FactionId -> m ()
forall (m :: * -> *). MonadServerAtomic m => FactionId -> m ()
reqAutomate FactionId
fid m () -> m (Maybe RequestTimed) -> m (Maybe RequestTimed)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe RequestTimed -> m (Maybe RequestTimed)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe RequestTimed
forall a. Maybe a
Nothing
  ReqUI
ReqUINop -> Maybe RequestTimed -> m (Maybe RequestTimed)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe RequestTimed
forall a. Maybe a
Nothing

checkWaiting :: RequestTimed -> Maybe Bool
checkWaiting :: RequestTimed -> Maybe Bool
checkWaiting RequestTimed
cmd = case RequestTimed
cmd of
  RequestTimed
ReqWait -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True  -- true wait, with bracing, no overhead, etc.
  RequestTimed
ReqWait10 -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False  -- false wait, only one clip at a time
  RequestTimed
_ -> Maybe Bool
forall a. Maybe a
Nothing

-- | This is a shorthand. Instead of setting @bwatch@ in @ReqWait@
-- and unsetting in all other requests, we call this once after
-- executing a request.
-- In game state, we collect the number of server requests pertaining
-- to the actor (the number of actor's "moves"), through which
-- the actor was waiting.
processWatchfulness :: MonadServerAtomic m => Maybe Bool -> ActorId -> m ()
processWatchfulness :: Maybe Bool -> ActorId -> m ()
processWatchfulness Maybe Bool
mwait ActorId
aid = do
  Actor
b <- (State -> Actor) -> m Actor
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
aid
  Skills
actorMaxSk <- (State -> Skills) -> m Skills
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Skills) -> m Skills) -> (State -> Skills) -> m Skills
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Skills
getActorMaxSkills ActorId
aid
  let uneasy :: Bool
uneasy = ResDelta -> Bool
deltasSerious (Actor -> ResDelta
bcalmDelta Actor
b) Bool -> Bool -> Bool
|| Bool -> Bool
not (Actor -> Skills -> Bool
calmEnough Actor
b Skills
actorMaxSk)
  case Actor -> Watchfulness
bwatch Actor
b of
    Watchfulness
WWatch ->
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Bool
mwait Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$  -- only long wait switches to wait state
        if Skill -> Skills -> Int
Ability.getSk Skill
Ability.SkWait Skills
actorMaxSk Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2 then do
          Bool -> GroupName ItemKind -> ActorId -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
Bool -> GroupName ItemKind -> ActorId -> m ()
addCondition Bool
False GroupName ItemKind
IK.S_BRACED ActorId
aid
          UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ ActorId -> Watchfulness -> Watchfulness -> UpdAtomic
UpdWaitActor ActorId
aid Watchfulness
WWatch (Int -> Watchfulness
WWait Int
1)
        else
          UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ ActorId -> Watchfulness -> Watchfulness -> UpdAtomic
UpdWaitActor ActorId
aid Watchfulness
WWatch (Int -> Watchfulness
WWait Int
0)
    WWait Int
0 -> case Maybe Bool
mwait of  -- actor couldn't brace last time
      Just Bool
True -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()  -- if he still waits, keep him stuck unbraced
      Maybe Bool
_ -> UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ ActorId -> Watchfulness -> Watchfulness -> UpdAtomic
UpdWaitActor ActorId
aid (Int -> Watchfulness
WWait Int
0) Watchfulness
WWatch
    WWait Int
n -> case Maybe Bool
mwait of
      Just Bool
True ->  -- only proper wait prevents switching to watchfulness
        if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
500 then  -- enough dozing to fall asleep
          if Bool -> Bool
not Bool
uneasy  -- won't wake up at once
             Bool -> Bool -> Bool
&& Skills -> Bool
canSleep Skills
actorMaxSk  -- enough skills
          then do
            Int
nAll <- GroupName ItemKind -> ActorId -> m Int
forall (m :: * -> *).
MonadServerAtomic m =>
GroupName ItemKind -> ActorId -> m Int
removeConditionSingle GroupName ItemKind
IK.S_BRACED ActorId
aid
            let !_A :: ()
_A = Bool -> () -> ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Int
nAll Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) ()
            ActorId -> m ()
forall (m :: * -> *). MonadServerAtomic m => ActorId -> m ()
addSleep ActorId
aid
          else
            -- Start dozing from scratch to prevent hopeless skill checks.
            UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ ActorId -> Watchfulness -> Watchfulness -> UpdAtomic
UpdWaitActor ActorId
aid (Int -> Watchfulness
WWait Int
n) (Int -> Watchfulness
WWait Int
1)
        else
          -- Doze some more before checking sleep eligibility.
          UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ ActorId -> Watchfulness -> Watchfulness -> UpdAtomic
UpdWaitActor ActorId
aid (Int -> Watchfulness
WWait Int
n) (Int -> Watchfulness
WWait (Int -> Watchfulness) -> Int -> Watchfulness
forall a b. (a -> b) -> a -> b
$ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
      Maybe Bool
_ -> do
        Int
nAll <- GroupName ItemKind -> ActorId -> m Int
forall (m :: * -> *).
MonadServerAtomic m =>
GroupName ItemKind -> ActorId -> m Int
removeConditionSingle GroupName ItemKind
IK.S_BRACED ActorId
aid
        let !_A :: ()
_A = Bool -> () -> ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Int
nAll Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Int -> Bool
forall a. Show a => Bool -> a -> Bool
`blame` Int
nAll) ()
        UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ ActorId -> Watchfulness -> Watchfulness -> UpdAtomic
UpdWaitActor ActorId
aid (Int -> Watchfulness
WWait Int
n) Watchfulness
WWatch
    Watchfulness
WSleep ->
      if Maybe Bool
mwait Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False  -- lurk can't wake up regardless; too short
         Bool -> Bool -> Bool
&& (Maybe Bool -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Bool
mwait  -- not a wait
             Bool -> Bool -> Bool
|| Bool
uneasy  -- spooked
             Bool -> Bool -> Bool
|| Bool -> Bool
not (ResDelta -> Bool
deltaBenign (ResDelta -> Bool) -> ResDelta -> Bool
forall a b. (a -> b) -> a -> b
$ Actor -> ResDelta
bhpDelta Actor
b))  -- any HP lost
      then UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ ActorId -> Watchfulness -> Watchfulness -> UpdAtomic
UpdWaitActor ActorId
aid Watchfulness
WSleep Watchfulness
WWake
      else UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ ActorId -> Int64 -> UpdAtomic
UpdRefillHP ActorId
aid Int64
10000
             -- no @xM@, so slow, but each turn HP gauge green;
             -- this is 1HP per 100 turns, so it's 10 times slower
             -- than a necklace that gives 1HP per 10 turns;
             -- so if an actor sleeps for the duration of a 1000 turns,
             -- which may be the time it takes to fully explore a level,
             -- 10HP would be gained, so weak actors would wake up twice over,
             -- which is fine: sleeping long enough to sidestep them at will,
             -- but attacking, e.g., a group with explosives, is good choice
             -- as well; so both stealth and mayhem fun correct tactically
    Watchfulness
WWake -> Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe Bool
mwait Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$  -- lurk can't wake up; too fast
      ActorId -> m ()
forall (m :: * -> *). MonadServerAtomic m => ActorId -> m ()
removeSleepSingle ActorId
aid

-- Even very primitive actors that can't pick up items can take over stash,
-- to prevent them inadvertedly protecting enemy stash from skilled ones
-- by standing over it (which AI tends to do).
affectStash :: MonadServerAtomic m => Actor -> m ()
affectStash :: Actor -> m ()
affectStash Actor
b = do
  let locateStash :: (FactionId, Faction) -> m ()
locateStash (FactionId
fid, Faction
fact) = case Faction -> Maybe (LevelId, Point)
gstash Faction
fact of
        Just (LevelId
lidS, Point
posS)
          | LevelId
lidS LevelId -> LevelId -> Bool
forall a. Eq a => a -> a -> Bool
== Actor -> LevelId
blid Actor
b Bool -> Bool -> Bool
&& Point
posS Point -> Point -> Bool
forall a. Eq a => a -> a -> Bool
== Actor -> Point
bpos Actor
b Bool -> Bool -> Bool
&& FactionId
fid FactionId -> FactionId -> Bool
forall a. Eq a => a -> a -> Bool
/= Actor -> FactionId
bfid Actor
b ->
            UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ Bool -> FactionId -> LevelId -> Point -> UpdAtomic
UpdLoseStashFaction Bool
True FactionId
fid LevelId
lidS Point
posS
        Maybe (LevelId, Point)
_ -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  FactionDict
factionD <- (State -> FactionDict) -> m FactionDict
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> FactionDict
sfactionD
  ((FactionId, Faction) -> m ()) -> [(FactionId, Faction)] -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m ()) -> t a -> m ()
mapM_ (FactionId, Faction) -> m ()
locateStash ([(FactionId, Faction)] -> m ()) -> [(FactionId, Faction)] -> m ()
forall a b. (a -> b) -> a -> b
$ FactionDict -> [(FactionId, Faction)]
forall k a. Enum k => EnumMap k a -> [(k, a)]
EM.assocs FactionDict
factionD

handleRequestTimed :: MonadServerAtomic m
                   => FactionId -> ActorId -> RequestTimed -> m Bool
handleRequestTimed :: FactionId -> ActorId -> RequestTimed -> m Bool
handleRequestTimed FactionId
fid ActorId
aid RequestTimed
cmd = do
  let mwait :: Maybe Bool
mwait = RequestTimed -> Maybe Bool
checkWaiting RequestTimed
cmd
  Actor
b <- (State -> Actor) -> m Actor
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
aid
  -- Note that only the ordinary 1-turn wait eliminates overhead.
  -- The more fine-graned waits don't make actors braced and induce
  -- overhead, so that they have some drawbacks in addition to the
  -- benefit of seeing approaching danger up to almost a turn faster.
  -- It may be too late to block then, but not too late to sidestep or attack.
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe Bool
mwait Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ FactionId -> LevelId -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
FactionId -> LevelId -> m ()
overheadActorTime FactionId
fid (Actor -> LevelId
blid Actor
b)
  ActorId -> Int -> Bool -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId -> Int -> Bool -> m ()
advanceTime ActorId
aid (if Maybe Bool
mwait Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False then Int
10 else Int
100) Bool
True
  ActorId -> RequestTimed -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId -> RequestTimed -> m ()
handleRequestTimedCases ActorId
aid RequestTimed
cmd
  ActorId -> m ()
forall (m :: * -> *). MonadServerAtomic m => ActorId -> m ()
managePerRequest ActorId
aid
  -- Note that due to the order, actor was still braced or sleeping
  -- throughout request processing, etc. So, if he hits himself kinetically,
  -- his armor from bracing previous turn is still in effect.
  Maybe Bool -> ActorId -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
Maybe Bool -> ActorId -> m ()
processWatchfulness Maybe Bool
mwait ActorId
aid
  Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$! Maybe Bool -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Bool
mwait  -- for speed, we report if @cmd@ harmless

-- | Clear deltas for Calm and HP for proper UI display and AI hints.
managePerRequest :: MonadServerAtomic m => ActorId -> m ()
managePerRequest :: ActorId -> m ()
managePerRequest ActorId
aid = do
  Actor
b <- (State -> Actor) -> m Actor
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
aid
  Actor -> m ()
forall (m :: * -> *). MonadServerAtomic m => Actor -> m ()
affectStash Actor
b
  let clearMark :: Int64
clearMark = Int64
0
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Actor -> ResDelta
bcalmDelta Actor
b ResDelta -> ResDelta -> Bool
forall a. Eq a => a -> a -> Bool
== (Int64, Int64) -> (Int64, Int64) -> ResDelta
ResDelta (Int64
0, Int64
0) (Int64
0, Int64
0)) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    -- Clear delta for the next actor move.
    UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ ActorId -> Int64 -> UpdAtomic
UpdRefillCalm ActorId
aid Int64
clearMark
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Actor -> ResDelta
bhpDelta Actor
b ResDelta -> ResDelta -> Bool
forall a. Eq a => a -> a -> Bool
== (Int64, Int64) -> (Int64, Int64) -> ResDelta
ResDelta (Int64
0, Int64
0) (Int64
0, Int64
0)) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    -- Clear delta for the next actor move.
    UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ ActorId -> Int64 -> UpdAtomic
UpdRefillHP ActorId
aid Int64
clearMark

handleRequestTimedCases :: MonadServerAtomic m
                        => ActorId -> RequestTimed -> m ()
handleRequestTimedCases :: ActorId -> RequestTimed -> m ()
handleRequestTimedCases ActorId
aid RequestTimed
cmd = case RequestTimed
cmd of
  ReqMove Vector
target -> ActorId -> Vector -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId -> Vector -> m ()
reqMove ActorId
aid Vector
target
  ReqMelee ActorId
target ItemId
iid CStore
cstore -> ActorId -> ActorId -> ItemId -> CStore -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId -> ActorId -> ItemId -> CStore -> m ()
reqMelee ActorId
aid ActorId
target ItemId
iid CStore
cstore
  ReqDisplace ActorId
target -> ActorId -> ActorId -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId -> ActorId -> m ()
reqDisplace ActorId
aid ActorId
target
  ReqAlter Point
tpos -> ActorId -> Point -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId -> Point -> m ()
reqAlter ActorId
aid Point
tpos
  RequestTimed
ReqWait -> ActorId -> m ()
forall (m :: * -> *). MonadServerAtomic m => ActorId -> m ()
reqWait ActorId
aid
  RequestTimed
ReqWait10 -> ActorId -> m ()
forall (m :: * -> *). MonadServerAtomic m => ActorId -> m ()
reqWait10 ActorId
aid
  RequestTimed
ReqYell -> ActorId -> m ()
forall (m :: * -> *). MonadServerAtomic m => ActorId -> m ()
reqYell ActorId
aid
  ReqMoveItems [(ItemId, Int, CStore, CStore)]
l -> ActorId -> [(ItemId, Int, CStore, CStore)] -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId -> [(ItemId, Int, CStore, CStore)] -> m ()
reqMoveItems ActorId
aid [(ItemId, Int, CStore, CStore)]
l
  ReqProject Point
p Int
eps ItemId
iid CStore
cstore -> ActorId -> Point -> Int -> ItemId -> CStore -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId -> Point -> Int -> ItemId -> CStore -> m ()
reqProject ActorId
aid Point
p Int
eps ItemId
iid CStore
cstore
  ReqApply ItemId
iid CStore
cstore -> ActorId -> ItemId -> CStore -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId -> ItemId -> CStore -> m ()
reqApply ActorId
aid ItemId
iid CStore
cstore

switchLeader :: MonadServerAtomic m => FactionId -> ActorId -> m ()
{-# INLINE switchLeader #-}
switchLeader :: FactionId -> ActorId -> m ()
switchLeader FactionId
fid ActorId
aidNew = do
  Faction
fact <- (State -> Faction) -> m Faction
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Faction) -> m Faction)
-> (State -> Faction) -> m Faction
forall a b. (a -> b) -> a -> b
$ (FactionDict -> FactionId -> Faction
forall k a. Enum k => EnumMap k a -> k -> a
EM.! FactionId
fid) (FactionDict -> Faction)
-> (State -> FactionDict) -> State -> Faction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> FactionDict
sfactionD
  Actor
bPre <- (State -> Actor) -> m Actor
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
aidNew
  let mleader :: Maybe ActorId
mleader = Faction -> Maybe ActorId
gleader Faction
fact
      !_A1 :: ()
_A1 = Bool -> () -> ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (ActorId -> Maybe ActorId
forall a. a -> Maybe a
Just ActorId
aidNew Maybe ActorId -> Maybe ActorId -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe ActorId
mleader
                     Bool -> Bool -> Bool
&& Bool -> Bool
not (Actor -> Bool
bproj Actor
bPre)
                     Bool -> (ActorId, Actor, FactionId, Faction) -> Bool
forall a. Show a => Bool -> a -> Bool
`blame` (ActorId
aidNew, Actor
bPre, FactionId
fid, Faction
fact)) ()
      !_A2 :: ()
_A2 = Bool -> () -> ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Actor -> FactionId
bfid Actor
bPre FactionId -> FactionId -> Bool
forall a. Eq a => a -> a -> Bool
== FactionId
fid
                     Bool -> (String, (ActorId, Actor, FactionId, Faction)) -> Bool
forall a. Show a => Bool -> a -> Bool
`blame` String
"client tries to move other faction actors"
                     String
-> (ActorId, Actor, FactionId, Faction)
-> (String, (ActorId, Actor, FactionId, Faction))
forall v. String -> v -> (String, v)
`swith` (ActorId
aidNew, Actor
bPre, FactionId
fid, Faction
fact)) ()
  let banned :: Bool
banned = Faction -> Bool
bannedPointmanSwitchBetweenLevels Faction
fact
  LevelId
arena <- case Maybe ActorId
mleader of
    Maybe ActorId
Nothing -> LevelId -> m LevelId
forall (m :: * -> *) a. Monad m => a -> m a
return (LevelId -> m LevelId) -> LevelId -> m LevelId
forall a b. (a -> b) -> a -> b
$! Actor -> LevelId
blid Actor
bPre
    Just ActorId
leader -> do
      Actor
b <- (State -> Actor) -> m Actor
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
leader
      LevelId -> m LevelId
forall (m :: * -> *) a. Monad m => a -> m a
return (LevelId -> m LevelId) -> LevelId -> m LevelId
forall a b. (a -> b) -> a -> b
$! Actor -> LevelId
blid Actor
b
  if Actor -> LevelId
blid Actor
bPre LevelId -> LevelId -> Bool
forall a. Eq a => a -> a -> Bool
/= LevelId
arena Bool -> Bool -> Bool
&& Bool
banned  -- catch the cheating clients
  then ActorId -> RequestTimed -> ReqFailure -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId -> RequestTimed -> ReqFailure -> m ()
execFailure ActorId
aidNew RequestTimed
ReqWait{-hack-} ReqFailure
NoChangeDunLeader
  else do
    UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ FactionId -> Maybe ActorId -> Maybe ActorId -> UpdAtomic
UpdLeadFaction FactionId
fid Maybe ActorId
mleader (ActorId -> Maybe ActorId
forall a. a -> Maybe a
Just ActorId
aidNew)
    -- We exchange times of the old and new leader.
    -- This permits an abuse, because a slow tank can be moved fast
    -- by alternating between it and many fast actors (until all of them
    -- get slowed down by this and none remain). But at least the sum
    -- of all times of a faction is conserved. And we avoid double moves
    -- against the UI player caused by his leader changes. There may still
    -- happen double moves caused by AI leader changes, but that's rare.
    -- The flip side is the possibility of multi-moves of the UI player
    -- as in the case of the tank.
    -- Warning: when the action is performed on the server,
    -- the time of the actor is different than when client prepared that
    -- action, so any client checks involving time should discount this.
    case Maybe ActorId
mleader of
      Just ActorId
aidOld | ActorId
aidOld ActorId -> ActorId -> Bool
forall a. Eq a => a -> a -> Bool
/= ActorId
aidNew -> ActorId -> ActorId -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId -> ActorId -> m ()
swapTime ActorId
aidOld ActorId
aidNew
      Maybe ActorId
_ -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- * ReqMove

-- | Add a smell trace for the actor to the level. If smell already there
-- and the actor can smell, remove smell. Projectiles are ignored.
-- As long as an actor can smell, he doesn't leave any smell ever.
-- Smell trace is never left in water tiles.
affectSmell :: MonadServerAtomic m => ActorId -> m ()
affectSmell :: ActorId -> m ()
affectSmell ActorId
aid = do
  COps{TileSpeedup
coTileSpeedup :: COps -> TileSpeedup
coTileSpeedup :: TileSpeedup
coTileSpeedup} <- (State -> COps) -> m COps
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  Actor
b <- (State -> Actor) -> m Actor
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
aid
  Level
lvl <- LevelId -> m Level
forall (m :: * -> *). MonadStateRead m => LevelId -> m Level
getLevel (LevelId -> m Level) -> LevelId -> m Level
forall a b. (a -> b) -> a -> b
$ Actor -> LevelId
blid Actor
b
  let aquatic :: Bool
aquatic = TileSpeedup -> ContentId TileKind -> Bool
Tile.isAquatic TileSpeedup
coTileSpeedup (ContentId TileKind -> Bool) -> ContentId TileKind -> Bool
forall a b. (a -> b) -> a -> b
$ Level
lvl Level -> Point -> ContentId TileKind
`at` Actor -> Point
bpos Actor
b
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Actor -> Bool
bproj Actor
b Bool -> Bool -> Bool
|| Bool
aquatic) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    Skills
actorMaxSk <- (State -> Skills) -> m Skills
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Skills) -> m Skills) -> (State -> Skills) -> m Skills
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Skills
getActorMaxSkills ActorId
aid
    let smellRadius :: Int
smellRadius = Skill -> Skills -> Int
Ability.getSk Skill
Ability.SkSmell Skills
actorMaxSk
        hasOdor :: Bool
hasOdor = Skill -> Skills -> Int
Ability.getSk Skill
Ability.SkOdor Skills
actorMaxSk Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
hasOdor Bool -> Bool -> Bool
|| Int
smellRadius Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      Time
localTime <- (State -> Time) -> m Time
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Time) -> m Time) -> (State -> Time) -> m Time
forall a b. (a -> b) -> a -> b
$ LevelId -> State -> Time
getLocalTime (LevelId -> State -> Time) -> LevelId -> State -> Time
forall a b. (a -> b) -> a -> b
$ Actor -> LevelId
blid Actor
b
      let oldS :: Time
oldS = Time -> Maybe Time -> Time
forall a. a -> Maybe a -> a
fromMaybe Time
timeZero (Maybe Time -> Time) -> Maybe Time -> Time
forall a b. (a -> b) -> a -> b
$ Point -> EnumMap Point Time -> Maybe Time
forall k a. Enum k => k -> EnumMap k a -> Maybe a
EM.lookup (Actor -> Point
bpos Actor
b) (EnumMap Point Time -> Maybe Time)
-> (Level -> EnumMap Point Time) -> Level -> Maybe Time
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Level -> EnumMap Point Time
lsmell (Level -> Maybe Time) -> Level -> Maybe Time
forall a b. (a -> b) -> a -> b
$ Level
lvl
          newTime :: Time
newTime = Time -> Delta Time -> Time
timeShift Time
localTime Delta Time
smellTimeout
          newS :: Time
newS = if Int
smellRadius Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
                 then Time
timeZero
                 else Time
newTime
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Time
oldS Time -> Time -> Bool
forall a. Eq a => a -> a -> Bool
/= Time
newS) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ LevelId -> Point -> Time -> Time -> UpdAtomic
UpdAlterSmell (Actor -> LevelId
blid Actor
b) (Actor -> Point
bpos Actor
b) Time
oldS Time
newS

-- | Actor moves or attacks or alters by bumping.
-- Note that client may not be able to see an invisible monster
-- so it's the server that determines if melee took place, etc.
-- Also, only the server is authorized to check if a move is legal
-- and it needs full context for that, e.g., the initial actor position
-- to check if melee attack does not try to reach to a distant tile.
reqMove :: MonadServerAtomic m => ActorId -> Vector -> m ()
reqMove :: ActorId -> Vector -> m ()
reqMove = Bool -> Bool -> ActorId -> Vector -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
Bool -> Bool -> ActorId -> Vector -> m ()
reqMoveGeneric Bool
True Bool
True

reqMoveGeneric :: MonadServerAtomic m
               => Bool -> Bool -> ActorId -> Vector -> m ()
reqMoveGeneric :: Bool -> Bool -> ActorId -> Vector -> m ()
reqMoveGeneric Bool
voluntary Bool
mayAttack ActorId
source Vector
dir = do
  COps{TileSpeedup
coTileSpeedup :: TileSpeedup
coTileSpeedup :: COps -> TileSpeedup
coTileSpeedup} <- (State -> COps) -> m COps
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  Skills
actorSk <- ActorId -> m Skills
forall (m :: * -> *). MonadServer m => ActorId -> m Skills
currentSkillsServer ActorId
source
  Actor
sb <- (State -> Actor) -> m Actor
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
source
  let abInSkill :: Skill -> Bool
abInSkill Skill
sk = Maybe ([Vector], Speed) -> Bool
forall a. Maybe a -> Bool
isJust (Actor -> Maybe ([Vector], Speed)
btrajectory Actor
sb)
                     Bool -> Bool -> Bool
|| Skill -> Skills -> Int
Ability.getSk Skill
sk Skills
actorSk Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
      lid :: LevelId
lid = Actor -> LevelId
blid Actor
sb
  Level
lvl <- LevelId -> m Level
forall (m :: * -> *). MonadStateRead m => LevelId -> m Level
getLevel LevelId
lid
  let spos :: Point
spos = Actor -> Point
bpos Actor
sb
      tpos :: Point
tpos = Point
spos Point -> Vector -> Point
`shift` Vector
dir
  -- This predicate is symmetric wrt source and target, though the effect
  -- of collision may not be (the source projectiles applies its effect
  -- on the target particles, but loses 1 HP due to the collision).
  -- The condition implies that it's impossible to shoot down a bullet
  -- with a bullet, but a bullet can shoot down a burstable target,
  -- as well as be swept away by it, and two burstable projectiles
  -- burst when meeting mid-air. Projectiles that are not bursting
  -- nor damaging never collide with any projectile.
  Actor -> Bool
collides <- (State -> Actor -> Bool) -> m (Actor -> Bool)
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor -> Bool) -> m (Actor -> Bool))
-> (State -> Actor -> Bool) -> m (Actor -> Bool)
forall a b. (a -> b) -> a -> b
$ \State
s Actor
tb ->
    let sitemKind :: ItemKind
sitemKind = ItemId -> State -> ItemKind
getIidKindServer (Actor -> ItemId
btrunk Actor
sb) State
s
        titemKind :: ItemKind
titemKind = ItemId -> State -> ItemKind
getIidKindServer (Actor -> ItemId
btrunk Actor
tb) State
s
        sar :: AspectRecord
sar = State -> DiscoveryAspect
sdiscoAspect State
s DiscoveryAspect -> ItemId -> AspectRecord
forall k a. Enum k => EnumMap k a -> k -> a
EM.! Actor -> ItemId
btrunk Actor
sb
        tar :: AspectRecord
tar = State -> DiscoveryAspect
sdiscoAspect State
s DiscoveryAspect -> ItemId -> AspectRecord
forall k a. Enum k => EnumMap k a -> k -> a
EM.! Actor -> ItemId
btrunk Actor
tb
        -- Such projectiles are prone to bursting or are themselves
        -- particles of an explosion shockwave.
        bursting :: AspectRecord -> Bool
bursting AspectRecord
arItem =
          Flag -> AspectRecord -> Bool
IA.checkFlag Flag
Ability.Fragile AspectRecord
arItem
          Bool -> Bool -> Bool
&& Flag -> AspectRecord -> Bool
IA.checkFlag Flag
Ability.Lobable AspectRecord
arItem
        sbursting :: Bool
sbursting = AspectRecord -> Bool
bursting AspectRecord
sar
        tbursting :: Bool
tbursting = AspectRecord -> Bool
bursting AspectRecord
tar
        -- Such projectiles, even if not bursting themselves, can cause
        -- another projectile to burst.
        sdamaging :: Bool
sdamaging = ItemKind -> Bool
IK.isDamagingKind ItemKind
sitemKind
        tdamaging :: Bool
tdamaging = ItemKind -> Bool
IK.isDamagingKind ItemKind
titemKind
        -- Avoid explosion extinguishing itself via its own particles colliding.
        sameBlast :: Bool
sameBlast = Flag -> AspectRecord -> Bool
IA.checkFlag Flag
Ability.Blast AspectRecord
sar
                    Bool -> Bool -> Bool
&& ItemId -> State -> ContentId ItemKind
getIidKindIdServer (Actor -> ItemId
btrunk Actor
sb) State
s
                       ContentId ItemKind -> ContentId ItemKind -> Bool
forall a. Eq a => a -> a -> Bool
== ItemId -> State -> ContentId ItemKind
getIidKindIdServer (Actor -> ItemId
btrunk Actor
tb) State
s
    in Bool -> Bool
not Bool
sameBlast
       Bool -> Bool -> Bool
&& (Bool
sbursting Bool -> Bool -> Bool
&& (Bool
tdamaging Bool -> Bool -> Bool
|| Bool
tbursting)
           Bool -> Bool -> Bool
|| (Bool
tbursting Bool -> Bool -> Bool
&& (Bool
sdamaging Bool -> Bool -> Bool
|| Bool
sbursting)))
  -- We start by checking actors at the target position.
  [(ActorId, Actor)]
tgt <- (State -> [(ActorId, Actor)]) -> m [(ActorId, Actor)]
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> [(ActorId, Actor)]) -> m [(ActorId, Actor)])
-> (State -> [(ActorId, Actor)]) -> m [(ActorId, Actor)]
forall a b. (a -> b) -> a -> b
$ Point -> LevelId -> State -> [(ActorId, Actor)]
posToAidAssocs Point
tpos LevelId
lid
  case [(ActorId, Actor)]
tgt of
    (ActorId
target, Actor
tb) : [(ActorId, Actor)]
_ | Bool
mayAttack Bool -> Bool -> Bool
&& (Bool -> Bool
not (Actor -> Bool
bproj Actor
sb)
                                     Bool -> Bool -> Bool
|| Bool -> Bool
not (Actor -> Bool
bproj Actor
tb)
                                     Bool -> Bool -> Bool
|| Actor -> Bool
collides Actor
tb) -> do
      -- A projectile is too small and insubstantial to hit another projectile,
      -- unless it's large enough or tends to explode (fragile and lobable).
      -- The actor in the way is visible or not; server sees him always.
      -- Below the only weapon (the only item) of projectiles is picked.
      Maybe (ItemId, CStore)
mweapon <- ActorId -> ActorId -> m (Maybe (ItemId, CStore))
forall (m :: * -> *).
MonadServer m =>
ActorId -> ActorId -> m (Maybe (ItemId, CStore))
pickWeaponServer ActorId
source ActorId
target
      case Maybe (ItemId, CStore)
mweapon of
        Just (ItemId
wp, CStore
cstore) | Skill -> Bool
abInSkill Skill
Ability.SkMelee ->
          Bool -> ActorId -> ActorId -> ItemId -> CStore -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
Bool -> ActorId -> ActorId -> ItemId -> CStore -> m ()
reqMeleeChecked Bool
voluntary ActorId
source ActorId
target ItemId
wp CStore
cstore
        Maybe (ItemId, CStore)
_ -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()  -- waiting, even if no @SkWait@ skill
      -- Movement of projectiles only happens after melee and a check
      -- if they survive, so that if they don't, they explode in front
      -- of enemy, not under him, so that already first explosion blasts
      -- reach him, not only potential secondary explosions.
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Actor -> Bool
bproj Actor
sb) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        Actor
b2 <- (State -> Actor) -> m Actor
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
source
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Actor -> Bool
actorDying Actor
b2) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> ActorId -> Vector -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
Bool -> Bool -> ActorId -> Vector -> m ()
reqMoveGeneric Bool
voluntary Bool
False ActorId
source Vector
dir
    [(ActorId, Actor)]
_ ->
      -- Either the position is empty, or all involved actors are proj.
      -- Movement requires full access and skill.
      if TileSpeedup -> ContentId TileKind -> Bool
Tile.isWalkable TileSpeedup
coTileSpeedup (ContentId TileKind -> Bool) -> ContentId TileKind -> Bool
forall a b. (a -> b) -> a -> b
$ Level
lvl Level -> Point -> ContentId TileKind
`at` Point
tpos then
        if Skill -> Bool
abInSkill Skill
Ability.SkMove then do
          UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ ActorId -> Point -> Point -> UpdAtomic
UpdMoveActor ActorId
source Point
spos Point
tpos
          ActorId -> m ()
forall (m :: * -> *). MonadServerAtomic m => ActorId -> m ()
affectSmell ActorId
source
          -- No remote ransacking nor underfoot effects by projectiles,
          -- through which a projectile could cook its only item,
          -- but retain the old raw name and which would spam water
          -- slowness every time a projectile flies over water.
          Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Actor -> Bool
bproj Actor
sb) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
            -- Counts as bumping, because terrain transformation probably
            -- not intended, because the goal was probably just to move
            -- and then modifying the terrain is an unwelcome side effect.
            -- Barged into a tile, so normal effects need to activate,
            -- while crafting requires explicit altering.
            m (Maybe ReqFailure) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Maybe ReqFailure) -> m ()) -> m (Maybe ReqFailure) -> m ()
forall a b. (a -> b) -> a -> b
$ Bool
-> EffToUse -> Bool -> ActorId -> Point -> m (Maybe ReqFailure)
forall (m :: * -> *).
MonadServerAtomic m =>
Bool
-> EffToUse -> Bool -> ActorId -> Point -> m (Maybe ReqFailure)
reqAlterFail Bool
True EffToUse
EffBare Bool
voluntary ActorId
source Point
tpos
       else ActorId -> RequestTimed -> ReqFailure -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId -> RequestTimed -> ReqFailure -> m ()
execFailure ActorId
source (Vector -> RequestTimed
ReqMove Vector
dir) ReqFailure
MoveUnskilled
      else do
        -- If not walkable, this must be altering by bumping.
        -- If voluntary then probably intentional so report any errors.
        Maybe ReqFailure
mfail <- Bool
-> EffToUse -> Bool -> ActorId -> Point -> m (Maybe ReqFailure)
forall (m :: * -> *).
MonadServerAtomic m =>
Bool
-> EffToUse -> Bool -> ActorId -> Point -> m (Maybe ReqFailure)
reqAlterFail Bool
True EffToUse
EffBare Bool
voluntary ActorId
source Point
tpos
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
voluntary (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
          let req :: RequestTimed
req = Vector -> RequestTimed
ReqMove Vector
dir
          m () -> (ReqFailure -> m ()) -> Maybe ReqFailure -> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (ActorId -> RequestTimed -> ReqFailure -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId -> RequestTimed -> ReqFailure -> m ()
execFailure ActorId
source RequestTimed
req) Maybe ReqFailure
mfail

-- * ReqMelee

-- | Resolves the result of an actor moving into another.
-- Actors on unwalkable positions can be attacked without any restrictions.
-- For instance, an actor embedded in a wall can be attacked from
-- an adjacent position. This function is analogous to projectGroupItem,
-- but for melee and not using up the weapon.
-- No problem if there are many projectiles at the spot. We just
-- attack the one specified.
reqMelee :: MonadServerAtomic m
         => ActorId -> ActorId -> ItemId -> CStore -> m ()
reqMelee :: ActorId -> ActorId -> ItemId -> CStore -> m ()
reqMelee ActorId
source ActorId
target ItemId
iid CStore
cstore = do
  Skills
actorSk <- ActorId -> m Skills
forall (m :: * -> *). MonadServer m => ActorId -> m Skills
currentSkillsServer ActorId
source
  if Skill -> Skills -> Int
Ability.getSk Skill
Ability.SkMelee Skills
actorSk Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then
    Bool -> ActorId -> ActorId -> ItemId -> CStore -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
Bool -> ActorId -> ActorId -> ItemId -> CStore -> m ()
reqMeleeChecked Bool
True ActorId
source ActorId
target ItemId
iid CStore
cstore
  else ActorId -> RequestTimed -> ReqFailure -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId -> RequestTimed -> ReqFailure -> m ()
execFailure ActorId
source (ActorId -> ItemId -> CStore -> RequestTimed
ReqMelee ActorId
target ItemId
iid CStore
cstore) ReqFailure
MeleeUnskilled

reqMeleeChecked :: forall m. MonadServerAtomic m
                => Bool -> ActorId -> ActorId -> ItemId -> CStore -> m ()
reqMeleeChecked :: Bool -> ActorId -> ActorId -> ItemId -> CStore -> m ()
reqMeleeChecked Bool
voluntary ActorId
source ActorId
target ItemId
iid CStore
cstore = do
  Actor
sb <- (State -> Actor) -> m Actor
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
source
  Actor
tb <- (State -> Actor) -> m Actor
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
target
  DiscoveryAspect
discoAspect <- (State -> DiscoveryAspect) -> m DiscoveryAspect
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> DiscoveryAspect
sdiscoAspect
  let req :: RequestTimed
req = ActorId -> ItemId -> CStore -> RequestTimed
ReqMelee ActorId
target ItemId
iid CStore
cstore
      arWeapon :: AspectRecord
arWeapon = DiscoveryAspect
discoAspect DiscoveryAspect -> ItemId -> AspectRecord
forall k a. Enum k => EnumMap k a -> k -> a
EM.! ItemId
iid
      meleeableEnough :: Bool
meleeableEnough = Actor -> Bool
bproj Actor
sb Bool -> Bool -> Bool
|| Flag -> AspectRecord -> Bool
IA.checkFlag Flag
Ability.Meleeable AspectRecord
arWeapon
  if ActorId
source ActorId -> ActorId -> Bool
forall a. Eq a => a -> a -> Bool
== ActorId
target then ActorId -> RequestTimed -> ReqFailure -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId -> RequestTimed -> ReqFailure -> m ()
execFailure ActorId
source RequestTimed
req ReqFailure
MeleeSelf
  else if Bool -> Bool
not (Actor -> Actor -> Bool
checkAdjacent Actor
sb Actor
tb) then ActorId -> RequestTimed -> ReqFailure -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId -> RequestTimed -> ReqFailure -> m ()
execFailure ActorId
source RequestTimed
req ReqFailure
MeleeDistant
  else if Bool -> Bool
not Bool
meleeableEnough then ActorId -> RequestTimed -> ReqFailure -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId -> RequestTimed -> ReqFailure -> m ()
execFailure ActorId
source RequestTimed
req ReqFailure
MeleeNotWeapon
  else do
    -- If @voluntary@ is set, blame is exact, otherwise, an approximation.
    ActorId
killer <- if | Bool
voluntary -> Bool -> m ActorId -> m ActorId
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Bool -> Bool
not (Actor -> Bool
bproj Actor
sb)) (m ActorId -> m ActorId) -> m ActorId -> m ActorId
forall a b. (a -> b) -> a -> b
$ ActorId -> m ActorId
forall (m :: * -> *) a. Monad m => a -> m a
return ActorId
source
                 | Actor -> Bool
bproj Actor
sb -> (StateServer -> ActorId) -> m ActorId
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer ((StateServer -> ActorId) -> m ActorId)
-> (StateServer -> ActorId) -> m ActorId
forall a b. (a -> b) -> a -> b
$ ActorId -> ActorId -> EnumMap ActorId ActorId -> ActorId
forall k a. Enum k => a -> k -> EnumMap k a -> a
EM.findWithDefault ActorId
source ActorId
source
                               (EnumMap ActorId ActorId -> ActorId)
-> (StateServer -> EnumMap ActorId ActorId)
-> StateServer
-> ActorId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateServer -> EnumMap ActorId ActorId
strajPushedBy
                 | Bool
otherwise -> ActorId -> m ActorId
forall (m :: * -> *) a. Monad m => a -> m a
return ActorId
source
    Skills
actorSk <- ActorId -> m Skills
forall (m :: * -> *). MonadServer m => ActorId -> m Skills
currentSkillsServer ActorId
source
    let arTrunk :: AspectRecord
arTrunk = DiscoveryAspect
discoAspect DiscoveryAspect -> ItemId -> AspectRecord
forall k a. Enum k => EnumMap k a -> k -> a
EM.! Actor -> ItemId
btrunk Actor
tb
        sfid :: FactionId
sfid = Actor -> FactionId
bfid Actor
sb
        tfid :: FactionId
tfid = Actor -> FactionId
bfid Actor
tb
        -- Let the missile drop down, but don't remove its trajectory
        -- so that it doesn't pretend to have hit a wall.
        haltTrajectory :: KillHow -> ActorId -> Actor -> m ()
        haltTrajectory :: KillHow -> ActorId -> Actor -> m ()
haltTrajectory KillHow
killHow ActorId
aid Actor
b = case Actor -> Maybe ([Vector], Speed)
btrajectory Actor
b of
          btra :: Maybe ([Vector], Speed)
btra@(Just ([Vector]
l, Speed
speed)) | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Vector] -> Bool
forall a. [a] -> Bool
null [Vector]
l -> do
            UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ ActorId
-> Maybe ([Vector], Speed) -> Maybe ([Vector], Speed) -> UpdAtomic
UpdTrajectory ActorId
aid Maybe ([Vector], Speed)
btra (Maybe ([Vector], Speed) -> UpdAtomic)
-> Maybe ([Vector], Speed) -> UpdAtomic
forall a b. (a -> b) -> a -> b
$ ([Vector], Speed) -> Maybe ([Vector], Speed)
forall a. a -> Maybe a
Just ([], Speed
speed)
            let arTrunkAid :: AspectRecord
arTrunkAid = DiscoveryAspect
discoAspect DiscoveryAspect -> ItemId -> AspectRecord
forall k a. Enum k => EnumMap k a -> k -> a
EM.! Actor -> ItemId
btrunk Actor
b
            Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Actor -> Bool
bproj Actor
b Bool -> Bool -> Bool
&& Bool -> Bool
not (Flag -> AspectRecord -> Bool
IA.checkFlag Flag
Ability.Blast AspectRecord
arTrunkAid)) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
              ActorId -> KillHow -> FactionId -> ItemId -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId -> KillHow -> FactionId -> ItemId -> m ()
addKillToAnalytics ActorId
killer KillHow
killHow (Actor -> FactionId
bfid Actor
b) (Actor -> ItemId
btrunk Actor
b)
          Maybe ([Vector], Speed)
_ -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    -- Only catch if braced. Never steal trunk from an already caught
    -- projectile or one with many items inside.
    if Actor -> Bool
bproj Actor
tb
       Bool -> Bool -> Bool
&& EnumMap ItemId ItemQuant -> Int
forall k a. EnumMap k a -> Int
EM.size (Actor -> EnumMap ItemId ItemQuant
beqp Actor
tb) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
       Bool -> Bool -> Bool
&& Bool -> Bool
not (Flag -> AspectRecord -> Bool
IA.checkFlag Flag
Ability.Blast AspectRecord
arTrunk)
       Bool -> Bool -> Bool
&& Actor -> Bool
actorWaits Actor
sb  -- still valid while request being processed
       Bool -> Bool -> Bool
&& Skill -> Skills -> Int
Ability.getSk Skill
Ability.SkMoveItem Skills
actorSk Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0  -- animals can't
    then do
      -- Catching the projectile, that is, stealing the item from its eqp.
      -- No effect from our weapon (organ) is applied to the projectile
      -- and the weapon (organ) is never destroyed, even if not durable.
      -- Pushed actor doesn't stop flight by catching the projectile
      -- nor does he lose 1HP.
      -- This is not overpowered, because usually at least one partial wait
      -- is needed to sync (if not, attacker should switch missiles)
      -- and so only every other missile can be caught. Normal sidestepping
      -- or sync and displace, if in a corridor, is as effective
      -- and blocking can be even more so, depending on powers of the missile.
      -- Missiles are really easy to defend against, but sight (and so, Calm)
      -- is the key, as well as light, ambush around a corner, etc.
      SfxAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => SfxAtomic -> m ()
execSfxAtomic (SfxAtomic -> m ()) -> SfxAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ ActorId -> ActorId -> ItemId -> SfxAtomic
SfxSteal ActorId
source ActorId
target ItemId
iid
      case EnumMap ItemId ItemQuant -> [(ItemId, ItemQuant)]
forall k a. Enum k => EnumMap k a -> [(k, a)]
EM.assocs (EnumMap ItemId ItemQuant -> [(ItemId, ItemQuant)])
-> EnumMap ItemId ItemQuant -> [(ItemId, ItemQuant)]
forall a b. (a -> b) -> a -> b
$ Actor -> EnumMap ItemId ItemQuant
beqp Actor
tb of
        [(ItemId
iid2, (Int
k, ItemTimers
_))] -> do
          [UpdAtomic]
upds <- Bool -> ItemId -> Int -> Container -> Container -> m [UpdAtomic]
forall (m :: * -> *).
MonadStateRead m =>
Bool -> ItemId -> Int -> Container -> Container -> m [UpdAtomic]
generalMoveItem Bool
True ItemId
iid2 Int
k (ActorId -> CStore -> Container
CActor ActorId
target CStore
CEqp)
                                              (ActorId -> CStore -> Container
CActor ActorId
source CStore
CStash)
          (UpdAtomic -> m ()) -> [UpdAtomic] -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m ()) -> t a -> m ()
mapM_ UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic [UpdAtomic]
upds
          ItemFull
itemFull <- (State -> ItemFull) -> m ItemFull
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> ItemFull) -> m ItemFull)
-> (State -> ItemFull) -> m ItemFull
forall a b. (a -> b) -> a -> b
$ ItemId -> State -> ItemFull
itemToFull ItemId
iid2
          Container -> ItemId -> ContentId ItemKind -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
Container -> ItemId -> ContentId ItemKind -> m ()
discoverIfMinorEffects (ActorId -> CStore -> Container
CActor ActorId
source CStore
CStash)
                                 ItemId
iid2 (ItemFull -> ContentId ItemKind
itemKindId ItemFull
itemFull)
        [(ItemId, ItemQuant)]
err -> String -> m ()
forall a. (?callStack::CallStack) => String -> a
error (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"" String -> [(ItemId, ItemQuant)] -> String
forall v. Show v => String -> v -> String
`showFailure` [(ItemId, ItemQuant)]
err
      KillHow -> ActorId -> Actor -> m ()
haltTrajectory KillHow
KillCatch ActorId
target Actor
tb
    else do
      if Actor -> Bool
bproj Actor
sb Bool -> Bool -> Bool
&& Actor -> Bool
bproj Actor
tb then do
        -- Special case for collision of projectiles, because they just
        -- symmetrically ram into each other, so picking one to hit another,
        -- based on random timing, would be wrong.
        -- Instead of suffering melee attack, let the target projectile
        -- get smashed and burst (if fragile and if not piercing).
        -- The source projectile terminates flight (unless pierces) later on.
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Actor -> Int64
bhp Actor
tb Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int64
oneM) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
          UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ ActorId -> Int64 -> UpdAtomic
UpdRefillHP ActorId
target Int64
minusM
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Actor -> Int64
bhp Actor
tb Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Int64
oneM) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
          -- If projectile has too low HP to pierce, terminate its flight.
          let killHow :: KillHow
killHow | Flag -> AspectRecord -> Bool
IA.checkFlag Flag
Ability.Blast AspectRecord
arWeapon = KillHow
KillKineticBlast
                      | Bool
otherwise = KillHow
KillKineticRanged
          KillHow -> ActorId -> Actor -> m ()
haltTrajectory KillHow
killHow ActorId
target Actor
tb
        -- Avoid spam when two explosions collide.
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Flag -> AspectRecord -> Bool
IA.checkFlag Flag
Ability.Blast AspectRecord
arWeapon
                Bool -> Bool -> Bool
&& Flag -> AspectRecord -> Bool
IA.checkFlag Flag
Ability.Blast AspectRecord
arTrunk) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
          SfxAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => SfxAtomic -> m ()
execSfxAtomic (SfxAtomic -> m ()) -> SfxAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ ActorId -> ActorId -> ItemId -> SfxAtomic
SfxStrike ActorId
source ActorId
target ItemId
iid
      else do
        -- Normal hit, with effects, but first auto-apply defences.
        let mayDestroyTarget :: Bool
mayDestroyTarget = Bool -> Bool
not (Actor -> Bool
bproj Actor
tb) Bool -> Bool -> Bool
|| Actor -> Int64
bhp Actor
tb Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Int64
oneM
            effApplyFlagsTarget :: EffApplyFlags
effApplyFlagsTarget = EffApplyFlags :: EffToUse
-> Bool -> Bool -> Bool -> ActivationFlag -> Bool -> EffApplyFlags
EffApplyFlags
              { effToUse :: EffToUse
effToUse            = EffToUse
EffBare
              , effVoluntary :: Bool
effVoluntary        = Bool
voluntary
              , effUseAllCopies :: Bool
effUseAllCopies     = Bool
False
              , effKineticPerformed :: Bool
effKineticPerformed = Bool
False
              , effActivation :: ActivationFlag
effActivation       = if Actor -> Bool
bproj Actor
sb
                                      then ActivationFlag
Ability.ActivationUnderRanged
                                      else ActivationFlag
Ability.ActivationUnderMelee
              , effMayDestroy :: Bool
effMayDestroy       = Bool
mayDestroyTarget
              }
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Actor -> Bool
bproj Actor
tb) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
          EffApplyFlags -> ActorId -> ActorId -> Actor -> Flag -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
EffApplyFlags -> ActorId -> ActorId -> Actor -> Flag -> m ()
autoApply EffApplyFlags
effApplyFlagsTarget ActorId
killer ActorId
target Actor
tb
          (Flag -> m ()) -> Flag -> m ()
forall a b. (a -> b) -> a -> b
$ if Actor -> Bool
bproj Actor
sb then Flag
Ability.UnderRanged else Flag
Ability.UnderMelee
        -- This might have changed the actors.
        Actor
sb2 <- (State -> Actor) -> m Actor
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
source
        Skills
targetMaxSk <- (State -> Skills) -> m Skills
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Skills) -> m Skills) -> (State -> Skills) -> m Skills
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Skills
getActorMaxSkills ActorId
target
        if | Actor -> Bool
bproj Actor
sb2
             Bool -> Bool -> Bool
&& Skill -> Skills -> Int
Ability.getSk Skill
Ability.SkDeflectRanged Skills
targetMaxSk Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 -> do
               ActorId -> m ()
forall (m :: * -> *). MonadServerAtomic m => ActorId -> m ()
cutCalm ActorId
target
               SfxAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => SfxAtomic -> m ()
execSfxAtomic (SfxAtomic -> m ()) -> SfxAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ ActorId -> ActorId -> ItemId -> SfxAtomic
SfxRecoil ActorId
source ActorId
target ItemId
iid
           | Skill -> Skills -> Int
Ability.getSk Skill
Ability.SkDeflectMelee Skills
targetMaxSk Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 -> do
               ActorId -> m ()
forall (m :: * -> *). MonadServerAtomic m => ActorId -> m ()
cutCalm ActorId
target
               SfxAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => SfxAtomic -> m ()
execSfxAtomic (SfxAtomic -> m ()) -> SfxAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ ActorId -> ActorId -> ItemId -> SfxAtomic
SfxRecoil ActorId
source ActorId
target ItemId
iid
           | Bool
otherwise -> do
               -- Msgs inside @SfxStrike@ describe the source part
               -- of the strike.
               SfxAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => SfxAtomic -> m ()
execSfxAtomic (SfxAtomic -> m ()) -> SfxAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ ActorId -> ActorId -> ItemId -> SfxAtomic
SfxStrike ActorId
source ActorId
target ItemId
iid
               let c :: Container
c = ActorId -> CStore -> Container
CActor ActorId
source CStore
cstore
                   mayDestroySource :: Bool
mayDestroySource = Bool -> Bool
not (Actor -> Bool
bproj Actor
sb2) Bool -> Bool -> Bool
|| Actor -> Int64
bhp Actor
sb2 Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Int64
oneM
                     -- piercing projectiles may not have their weapon destroyed
               -- Msgs inside @itemEffect@ describe the target part
               -- of the strike.
               -- If any effects and aspects, this is also where they are
               -- identified.
               -- Here also the kinetic damage is applied,
               -- before any effects are.
               --
               -- Note: that "hornet swarm detect items" via a scrolls
               -- is intentional,
               -- even though unrealistic and funny. Otherwise actors
               -- could protect
               -- themselves from some projectiles by lowering their apply stat.
               -- Also, the animal faction won't have too much benefit
               -- from that info,
               -- so the problem is not balance, but the goofy message.
               let effApplyFlagsSource :: EffApplyFlags
effApplyFlagsSource = EffApplyFlags :: EffToUse
-> Bool -> Bool -> Bool -> ActivationFlag -> Bool -> EffApplyFlags
EffApplyFlags
                     { effToUse :: EffToUse
effToUse            = EffToUse
EffBare
                     , effVoluntary :: Bool
effVoluntary        = Bool
voluntary
                     , effUseAllCopies :: Bool
effUseAllCopies     = Bool
False
                     , effKineticPerformed :: Bool
effKineticPerformed = Bool
False
                     , effActivation :: ActivationFlag
effActivation       = ActivationFlag
Ability.ActivationMeleeable
                     , effMayDestroy :: Bool
effMayDestroy       = Bool
mayDestroySource
                     }
               m UseResult -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m UseResult -> m ()) -> m UseResult -> m ()
forall a b. (a -> b) -> a -> b
$ EffApplyFlags
-> ActorId
-> ActorId
-> ActorId
-> ItemId
-> Container
-> m UseResult
forall (m :: * -> *).
MonadServerAtomic m =>
EffApplyFlags
-> ActorId
-> ActorId
-> ActorId
-> ItemId
-> Container
-> m UseResult
kineticEffectAndDestroy EffApplyFlags
effApplyFlagsSource ActorId
killer
                                              ActorId
source ActorId
target ItemId
iid Container
c
      Actor
sb2 <- (State -> Actor) -> m Actor
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
source
      case Actor -> Maybe ([Vector], Speed)
btrajectory Actor
sb2 of
        Just{} | Bool -> Bool
not Bool
voluntary -> do
          -- Deduct a hitpoint for a pierce of a projectile
          -- or due to a hurled actor colliding with another (seen from
          -- @voluntary@, as opposed to hurled actor actively meleeing another).
          -- Don't deduct if no pierce, to prevent spam.
          -- Never kill in this way.
          Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Actor -> Int64
bhp Actor
sb2 Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int64
oneM) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
            UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ ActorId -> Int64 -> UpdAtomic
UpdRefillHP ActorId
source Int64
minusM
            Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Actor -> Bool
bproj Actor
sb2) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
              SfxAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => SfxAtomic -> m ()
execSfxAtomic (SfxAtomic -> m ()) -> SfxAtomic -> m ()
forall a b. (a -> b) -> a -> b
$
                FactionId -> SfxMsg -> SfxAtomic
SfxMsgFid (Actor -> FactionId
bfid Actor
sb2) (SfxMsg -> SfxAtomic) -> SfxMsg -> SfxAtomic
forall a b. (a -> b) -> a -> b
$ ActorId -> ActorId -> SfxMsg
SfxCollideActor ActorId
source ActorId
target
              Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Actor -> Bool
bproj Actor
tb) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
                SfxAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => SfxAtomic -> m ()
execSfxAtomic (SfxAtomic -> m ()) -> SfxAtomic -> m ()
forall a b. (a -> b) -> a -> b
$
                  FactionId -> SfxMsg -> SfxAtomic
SfxMsgFid (Actor -> FactionId
bfid Actor
tb) (SfxMsg -> SfxAtomic) -> SfxMsg -> SfxAtomic
forall a b. (a -> b) -> a -> b
$ ActorId -> ActorId -> SfxMsg
SfxCollideActor ActorId
source ActorId
target
          Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Actor -> Bool
bproj Actor
sb2) Bool -> Bool -> Bool
|| Actor -> Int64
bhp Actor
sb2 Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Int64
oneM) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
            -- Non-projectiles can't pierce, so terminate their flight.
            -- If projectile has too low HP to pierce, ditto.
            KillHow -> ActorId -> Actor -> m ()
haltTrajectory KillHow
KillActorLaunch ActorId
source Actor
sb2
        Maybe ([Vector], Speed)
_ -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      -- The only way to start a war is to slap an enemy voluntarily..
      -- Being hit by and hitting projectiles, as well as via pushing,
      -- count as unintentional friendly fire.
      Faction
sfact <- (State -> Faction) -> m Faction
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Faction) -> m Faction)
-> (State -> Faction) -> m Faction
forall a b. (a -> b) -> a -> b
$ (FactionDict -> FactionId -> Faction
forall k a. Enum k => EnumMap k a -> k -> a
EM.! FactionId
sfid) (FactionDict -> Faction)
-> (State -> FactionDict) -> State -> Faction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> FactionDict
sfactionD
      let friendlyFire :: Bool
friendlyFire = Actor -> Bool
bproj Actor
sb2 Bool -> Bool -> Bool
|| Actor -> Bool
bproj Actor
tb Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
voluntary
          fromDipl :: Diplomacy
fromDipl = Diplomacy -> FactionId -> EnumMap FactionId Diplomacy -> Diplomacy
forall k a. Enum k => a -> k -> EnumMap k a -> a
EM.findWithDefault Diplomacy
Unknown FactionId
tfid (Faction -> EnumMap FactionId Diplomacy
gdipl Faction
sfact)
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
friendlyFire
              Bool -> Bool -> Bool
|| FactionId -> Faction -> FactionId -> Bool
isFoe FactionId
sfid Faction
sfact FactionId
tfid  -- already at war
              Bool -> Bool -> Bool
|| FactionId -> Faction -> FactionId -> Bool
isFriend FactionId
sfid Faction
sfact FactionId
tfid) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$  -- allies never at war
        UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ FactionId -> FactionId -> Diplomacy -> Diplomacy -> UpdAtomic
UpdDiplFaction FactionId
sfid FactionId
tfid Diplomacy
fromDipl Diplomacy
War

autoApply :: MonadServerAtomic m
          => EffApplyFlags -> ActorId -> ActorId -> Actor -> Ability.Flag
          -> m ()
autoApply :: EffApplyFlags -> ActorId -> ActorId -> Actor -> Flag -> m ()
autoApply EffApplyFlags
effApplyFlags ActorId
killer ActorId
target Actor
tb Flag
flag = do
  let autoApplyIid :: Container -> ItemId -> m ()
autoApplyIid Container
c ItemId
iid = do
        ItemFull
itemFull <- (State -> ItemFull) -> m ItemFull
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> ItemFull) -> m ItemFull)
-> (State -> ItemFull) -> m ItemFull
forall a b. (a -> b) -> a -> b
$ ItemId -> State -> ItemFull
itemToFull ItemId
iid
        let arItem :: AspectRecord
arItem = ItemFull -> AspectRecord
aspectRecordFull ItemFull
itemFull
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Flag -> AspectRecord -> Bool
IA.checkFlag Flag
flag AspectRecord
arItem) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
          m UseResult -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m UseResult -> m ()) -> m UseResult -> m ()
forall a b. (a -> b) -> a -> b
$ EffApplyFlags
-> ActorId
-> ActorId
-> ActorId
-> ItemId
-> Container
-> ItemFull
-> m UseResult
forall (m :: * -> *).
MonadServerAtomic m =>
EffApplyFlags
-> ActorId
-> ActorId
-> ActorId
-> ItemId
-> Container
-> ItemFull
-> m UseResult
effectAndDestroyAndAddKill EffApplyFlags
effApplyFlags ActorId
killer ActorId
target ActorId
target
                                            ItemId
iid Container
c ItemFull
itemFull
  (ItemId -> m ()) -> [ItemId] -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m ()) -> t a -> m ()
mapM_ (Container -> ItemId -> m ()
autoApplyIid (Container -> ItemId -> m ()) -> Container -> ItemId -> m ()
forall a b. (a -> b) -> a -> b
$ ActorId -> CStore -> Container
CActor ActorId
target CStore
CEqp) ([ItemId] -> m ()) -> [ItemId] -> m ()
forall a b. (a -> b) -> a -> b
$ EnumMap ItemId ItemQuant -> [ItemId]
forall k a. Enum k => EnumMap k a -> [k]
EM.keys (EnumMap ItemId ItemQuant -> [ItemId])
-> EnumMap ItemId ItemQuant -> [ItemId]
forall a b. (a -> b) -> a -> b
$ Actor -> EnumMap ItemId ItemQuant
beqp Actor
tb
  (ItemId -> m ()) -> [ItemId] -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m ()) -> t a -> m ()
mapM_ (Container -> ItemId -> m ()
autoApplyIid (Container -> ItemId -> m ()) -> Container -> ItemId -> m ()
forall a b. (a -> b) -> a -> b
$ ActorId -> CStore -> Container
CActor ActorId
target CStore
COrgan) ([ItemId] -> m ()) -> [ItemId] -> m ()
forall a b. (a -> b) -> a -> b
$ EnumMap ItemId ItemQuant -> [ItemId]
forall k a. Enum k => EnumMap k a -> [k]
EM.keys (EnumMap ItemId ItemQuant -> [ItemId])
-> EnumMap ItemId ItemQuant -> [ItemId]
forall a b. (a -> b) -> a -> b
$ Actor -> EnumMap ItemId ItemQuant
borgan Actor
tb

-- * ReqDisplace

-- | Actor tries to swap positions with another.
reqDisplace :: MonadServerAtomic m => ActorId -> ActorId -> m ()
reqDisplace :: ActorId -> ActorId -> m ()
reqDisplace = Bool -> ActorId -> ActorId -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
Bool -> ActorId -> ActorId -> m ()
reqDisplaceGeneric Bool
True

reqDisplaceGeneric :: MonadServerAtomic m => Bool -> ActorId -> ActorId -> m ()
reqDisplaceGeneric :: Bool -> ActorId -> ActorId -> m ()
reqDisplaceGeneric Bool
voluntary ActorId
source ActorId
target = do
  COps{TileSpeedup
coTileSpeedup :: TileSpeedup
coTileSpeedup :: COps -> TileSpeedup
coTileSpeedup} <- (State -> COps) -> m COps
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  Skills
actorSk <- ActorId -> m Skills
forall (m :: * -> *). MonadServer m => ActorId -> m Skills
currentSkillsServer ActorId
source
  Actor
sb <- (State -> Actor) -> m Actor
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
source
  let abInSkill :: Skill -> Bool
abInSkill Skill
sk = Maybe ([Vector], Speed) -> Bool
forall a. Maybe a -> Bool
isJust (Actor -> Maybe ([Vector], Speed)
btrajectory Actor
sb)
                     Bool -> Bool -> Bool
|| Skill -> Skills -> Int
Ability.getSk Skill
sk Skills
actorSk Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
  Actor
tb <- (State -> Actor) -> m Actor
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
target
  Faction
tfact <- (State -> Faction) -> m Faction
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Faction) -> m Faction)
-> (State -> Faction) -> m Faction
forall a b. (a -> b) -> a -> b
$ (FactionDict -> FactionId -> Faction
forall k a. Enum k => EnumMap k a -> k -> a
EM.! Actor -> FactionId
bfid Actor
tb) (FactionDict -> Faction)
-> (State -> FactionDict) -> State -> Faction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> FactionDict
sfactionD
  let spos :: Point
spos = Actor -> Point
bpos Actor
sb
      tpos :: Point
tpos = Actor -> Point
bpos Actor
tb
      atWar :: Bool
atWar = FactionId -> Faction -> FactionId -> Bool
isFoe (Actor -> FactionId
bfid Actor
tb) Faction
tfact (Actor -> FactionId
bfid Actor
sb)
      req :: RequestTimed
req = ActorId -> RequestTimed
ReqDisplace ActorId
target
  Skills
actorMaxSk <- (State -> Skills) -> m Skills
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Skills) -> m Skills) -> (State -> Skills) -> m Skills
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Skills
getActorMaxSkills ActorId
target
  Bool
dEnemy <- (State -> Bool) -> m Bool
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Bool) -> m Bool) -> (State -> Bool) -> m Bool
forall a b. (a -> b) -> a -> b
$ ActorId -> ActorId -> Skills -> State -> Bool
dispEnemy ActorId
source ActorId
target Skills
actorMaxSk
  if | Bool -> Bool
not (Skill -> Bool
abInSkill Skill
Ability.SkDisplace) ->
         ActorId -> RequestTimed -> ReqFailure -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId -> RequestTimed -> ReqFailure -> m ()
execFailure ActorId
source RequestTimed
req ReqFailure
DisplaceUnskilled
     | Bool -> Bool
not (Actor -> Actor -> Bool
checkAdjacent Actor
sb Actor
tb) -> ActorId -> RequestTimed -> ReqFailure -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId -> RequestTimed -> ReqFailure -> m ()
execFailure ActorId
source RequestTimed
req ReqFailure
DisplaceDistant
     | Bool
atWar Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
dEnemy -> do  -- if not at war, can displace always
       -- We don't fail with DisplaceImmobile and DisplaceSupported.
       -- because it's quite common they can't be determined by the attacker,
       -- and so the failure would be too alarming to the player.
       -- If the character melees instead, the player can tell displace failed.
       -- As for the other failures, they are impossible and we don't
       -- verify here that they don't occur, for simplicity.
       Maybe (ItemId, CStore)
mweapon <- ActorId -> ActorId -> m (Maybe (ItemId, CStore))
forall (m :: * -> *).
MonadServer m =>
ActorId -> ActorId -> m (Maybe (ItemId, CStore))
pickWeaponServer ActorId
source ActorId
target
       case Maybe (ItemId, CStore)
mweapon of
         Just (ItemId
wp, CStore
cstore) | Skill -> Bool
abInSkill Skill
Ability.SkMelee ->
           Bool -> ActorId -> ActorId -> ItemId -> CStore -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
Bool -> ActorId -> ActorId -> ItemId -> CStore -> m ()
reqMeleeChecked Bool
voluntary ActorId
source ActorId
target ItemId
wp CStore
cstore
         Maybe (ItemId, CStore)
_ -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()  -- waiting, even if no @SkWait@ skill
     | Bool
otherwise -> do
       let lid :: LevelId
lid = Actor -> LevelId
blid Actor
sb
       Level
lvl <- LevelId -> m Level
forall (m :: * -> *). MonadStateRead m => LevelId -> m Level
getLevel LevelId
lid
       -- Displacing requires full access.
       if TileSpeedup -> ContentId TileKind -> Bool
Tile.isWalkable TileSpeedup
coTileSpeedup (ContentId TileKind -> Bool) -> ContentId TileKind -> Bool
forall a b. (a -> b) -> a -> b
$ Level
lvl Level -> Point -> ContentId TileKind
`at` Point
tpos then
         case Point -> Level -> [ActorId]
posToAidsLvl Point
tpos Level
lvl of
           [] -> String -> m ()
forall a. (?callStack::CallStack) => String -> a
error (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"" String -> (ActorId, Actor, ActorId, Actor) -> String
forall v. Show v => String -> v -> String
`showFailure` (ActorId
source, Actor
sb, ActorId
target, Actor
tb)
           [ActorId
_] -> do
             UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ ActorId -> ActorId -> UpdAtomic
UpdDisplaceActor ActorId
source ActorId
target
             -- We leave or wipe out smell, for consistency, but it's not
             -- absolute consistency, e.g., blinking doesn't touch smell,
             -- so sometimes smellers will backtrack once to wipe smell. OK.
             ActorId -> m ()
forall (m :: * -> *). MonadServerAtomic m => ActorId -> m ()
affectSmell ActorId
source
             ActorId -> m ()
forall (m :: * -> *). MonadServerAtomic m => ActorId -> m ()
affectSmell ActorId
target
             -- Counts as bumping, because terrain transformation not intended.
             m (Maybe ReqFailure) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Maybe ReqFailure) -> m ()) -> m (Maybe ReqFailure) -> m ()
forall a b. (a -> b) -> a -> b
$ Bool
-> EffToUse -> Bool -> ActorId -> Point -> m (Maybe ReqFailure)
forall (m :: * -> *).
MonadServerAtomic m =>
Bool
-> EffToUse -> Bool -> ActorId -> Point -> m (Maybe ReqFailure)
reqAlterFail Bool
True EffToUse
EffBare Bool
False ActorId
source Point
tpos
               -- possibly alter or activate
             m (Maybe ReqFailure) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Maybe ReqFailure) -> m ()) -> m (Maybe ReqFailure) -> m ()
forall a b. (a -> b) -> a -> b
$ Bool
-> EffToUse -> Bool -> ActorId -> Point -> m (Maybe ReqFailure)
forall (m :: * -> *).
MonadServerAtomic m =>
Bool
-> EffToUse -> Bool -> ActorId -> Point -> m (Maybe ReqFailure)
reqAlterFail Bool
True EffToUse
EffBare Bool
False ActorId
target Point
spos
           [ActorId]
_ -> ActorId -> RequestTimed -> ReqFailure -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId -> RequestTimed -> ReqFailure -> m ()
execFailure ActorId
source RequestTimed
req ReqFailure
DisplaceMultiple
       else
         -- Client foolishly tries to displace an actor without access.
         ActorId -> RequestTimed -> ReqFailure -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId -> RequestTimed -> ReqFailure -> m ()
execFailure ActorId
source RequestTimed
req ReqFailure
DisplaceAccess

-- * ReqAlter

-- | Search and/or alter the tile.
reqAlter :: MonadServerAtomic m => ActorId -> Point -> m ()
reqAlter :: ActorId -> Point -> m ()
reqAlter ActorId
source Point
tpos = do
  COps{TileSpeedup
coTileSpeedup :: TileSpeedup
coTileSpeedup :: COps -> TileSpeedup
coTileSpeedup} <- (State -> COps) -> m COps
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  Actor
sb <- (State -> Actor) -> m Actor
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
source
  Level
lvl <- LevelId -> m Level
forall (m :: * -> *). MonadStateRead m => LevelId -> m Level
getLevel (LevelId -> m Level) -> LevelId -> m Level
forall a b. (a -> b) -> a -> b
$ Actor -> LevelId
blid Actor
sb
  -- This is explicit tile triggering. Walkable tiles are sparse enough
  -- that crafting effects can be activated without any others
  -- and without changing the tile and this is usually beneficial,
  -- so always attempted. OTOH, squeezing a hand into a non-walkable tile
  -- or barging into walkable tiles (but not as a projectile) activates all.
  let effToUse :: EffToUse
effToUse = if TileSpeedup -> ContentId TileKind -> Bool
Tile.isWalkable TileSpeedup
coTileSpeedup (Level
lvl Level -> Point -> ContentId TileKind
`at` Point
tpos)
                 then EffToUse
EffOnCombine
                 else EffToUse
EffBareAndOnCombine
  Maybe ReqFailure
mfail <- Bool
-> EffToUse -> Bool -> ActorId -> Point -> m (Maybe ReqFailure)
forall (m :: * -> *).
MonadServerAtomic m =>
Bool
-> EffToUse -> Bool -> ActorId -> Point -> m (Maybe ReqFailure)
reqAlterFail Bool
False EffToUse
effToUse Bool
True ActorId
source Point
tpos
  let req :: RequestTimed
req = Point -> RequestTimed
ReqAlter Point
tpos
  m () -> (ReqFailure -> m ()) -> Maybe ReqFailure -> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (ActorId -> RequestTimed -> ReqFailure -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId -> RequestTimed -> ReqFailure -> m ()
execFailure ActorId
source RequestTimed
req) Maybe ReqFailure
mfail

reqAlterFail :: forall m. MonadServerAtomic m
             => Bool -> EffToUse -> Bool -> ActorId -> Point
             -> m (Maybe ReqFailure)
reqAlterFail :: Bool
-> EffToUse -> Bool -> ActorId -> Point -> m (Maybe ReqFailure)
reqAlterFail Bool
bumping EffToUse
effToUse Bool
voluntary ActorId
source Point
tpos = do
  cops :: COps
cops@COps{ContentData TileKind
cotile :: COps -> ContentData TileKind
cotile :: ContentData TileKind
cotile, TileSpeedup
coTileSpeedup :: TileSpeedup
coTileSpeedup :: COps -> TileSpeedup
coTileSpeedup, RuleContent
corule :: COps -> RuleContent
corule :: RuleContent
corule} <- (State -> COps) -> m COps
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  Actor
sb <- (State -> Actor) -> m Actor
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
source
  Skills
actorMaxSk <- (State -> Skills) -> m Skills
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Skills) -> m Skills) -> (State -> Skills) -> m Skills
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Skills
getActorMaxSkills ActorId
source
  let calmE :: Bool
calmE = Actor -> Skills -> Bool
calmEnough Actor
sb Skills
actorMaxSk
      lid :: LevelId
lid = Actor -> LevelId
blid Actor
sb
  State
sClient <- (StateServer -> State) -> m State
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer ((StateServer -> State) -> m State)
-> (StateServer -> State) -> m State
forall a b. (a -> b) -> a -> b
$ (EnumMap FactionId State -> FactionId -> State
forall k a. Enum k => EnumMap k a -> k -> a
EM.! Actor -> FactionId
bfid Actor
sb) (EnumMap FactionId State -> State)
-> (StateServer -> EnumMap FactionId State) -> StateServer -> State
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateServer -> EnumMap FactionId State
sclientStates
  ItemId -> ItemFull
itemToF <- (State -> ItemId -> ItemFull) -> m (ItemId -> ItemFull)
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> ItemId -> ItemFull) -> m (ItemId -> ItemFull))
-> (State -> ItemId -> ItemFull) -> m (ItemId -> ItemFull)
forall a b. (a -> b) -> a -> b
$ (ItemId -> State -> ItemFull) -> State -> ItemId -> ItemFull
forall a b c. (a -> b -> c) -> b -> a -> c
flip ItemId -> State -> ItemFull
itemToFull
  Skills
actorSk <- ActorId -> m Skills
forall (m :: * -> *). MonadServer m => ActorId -> m Skills
currentSkillsServer ActorId
source
  Time
localTime <- (State -> Time) -> m Time
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Time) -> m Time) -> (State -> Time) -> m Time
forall a b. (a -> b) -> a -> b
$ LevelId -> State -> Time
getLocalTime LevelId
lid
  EnumMap ItemId ItemQuant
embeds <- (State -> EnumMap ItemId ItemQuant) -> m (EnumMap ItemId ItemQuant)
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> EnumMap ItemId ItemQuant)
 -> m (EnumMap ItemId ItemQuant))
-> (State -> EnumMap ItemId ItemQuant)
-> m (EnumMap ItemId ItemQuant)
forall a b. (a -> b) -> a -> b
$ LevelId -> Point -> State -> EnumMap ItemId ItemQuant
getEmbedBag LevelId
lid Point
tpos
  Level
lvl <- LevelId -> m Level
forall (m :: * -> *). MonadStateRead m => LevelId -> m Level
getLevel LevelId
lid
  ItemId -> ItemKind
getKind <- (State -> ItemId -> ItemKind) -> m (ItemId -> ItemKind)
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> ItemId -> ItemKind) -> m (ItemId -> ItemKind))
-> (State -> ItemId -> ItemKind) -> m (ItemId -> ItemKind)
forall a b. (a -> b) -> a -> b
$ (ItemId -> State -> ItemKind) -> State -> ItemId -> ItemKind
forall a b c. (a -> b -> c) -> b -> a -> c
flip ItemId -> State -> ItemKind
getIidKindServer
  let serverTile :: ContentId TileKind
serverTile = Level
lvl Level -> Point -> ContentId TileKind
`at` Point
tpos
      lvlClient :: Level
lvlClient = (EnumMap LevelId Level -> LevelId -> Level
forall k a. Enum k => EnumMap k a -> k -> a
EM.! LevelId
lid) (EnumMap LevelId Level -> Level)
-> (State -> EnumMap LevelId Level) -> State -> Level
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> EnumMap LevelId Level
sdungeon (State -> Level) -> State -> Level
forall a b. (a -> b) -> a -> b
$ State
sClient
      clientTile :: ContentId TileKind
clientTile = Level
lvlClient Level -> Point -> ContentId TileKind
`at` Point
tpos
      hiddenTile :: Maybe (ContentId TileKind)
hiddenTile = ContentData TileKind
-> ContentId TileKind -> Maybe (ContentId TileKind)
Tile.hideAs ContentData TileKind
cotile ContentId TileKind
serverTile
      alterSkill :: Int
alterSkill = Skill -> Skills -> Int
Ability.getSk Skill
Ability.SkAlter Skills
actorSk
      tileMinSkill :: Int
tileMinSkill = TileSpeedup -> ContentId TileKind -> Int
Tile.alterMinSkill TileSpeedup
coTileSpeedup ContentId TileKind
serverTile
      revealEmbeds :: m ()
revealEmbeds = Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (EnumMap ItemId ItemQuant -> Bool
forall k a. EnumMap k a -> Bool
EM.null EnumMap ItemId ItemQuant
embeds) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ Bool -> Container -> EnumMap ItemId ItemQuant -> UpdAtomic
UpdSpotItemBag Bool
True (LevelId -> Point -> Container
CEmbed LevelId
lid Point
tpos) EnumMap ItemId ItemQuant
embeds
      embedKindList :: [(ItemKind, (ItemId, ItemQuant))]
embedKindList =
        ((ItemId, ItemQuant) -> (ItemKind, (ItemId, ItemQuant)))
-> [(ItemId, ItemQuant)] -> [(ItemKind, (ItemId, ItemQuant))]
forall a b. (a -> b) -> [a] -> [b]
map (\(ItemId
iid, ItemQuant
kit) -> (ItemId -> ItemKind
getKind ItemId
iid, (ItemId
iid, ItemQuant
kit))) (EnumMap ItemId ItemQuant -> [(ItemId, ItemQuant)]
forall k a. Enum k => EnumMap k a -> [(k, a)]
EM.assocs EnumMap ItemId ItemQuant
embeds)
      sbItemKind :: ItemKind
sbItemKind = ItemId -> ItemKind
getKind (ItemId -> ItemKind) -> ItemId -> ItemKind
forall a b. (a -> b) -> a -> b
$ Actor -> ItemId
btrunk Actor
sb
      -- Prevent embeds triggering each other's exploding embeds
      -- via feeble mists, in the worst case, in a loop. However,
      -- if a tile can be changed with an item (e.g., the mist trunk)
      -- but without activating embeds, mists do fine.
      projNoDamage :: Bool
projNoDamage = Actor -> Bool
bproj Actor
sb Bool -> Bool -> Bool
&& Bool -> Bool
not (ItemKind -> Bool
IK.isDamagingKind ItemKind
sbItemKind)
      tryApplyEmbed :: (ItemId, ItemQuant) -> m UseResult
tryApplyEmbed (ItemId
iid, ItemQuant
kit) = do
        let itemFull :: ItemFull
itemFull = ItemId -> ItemFull
itemToF ItemId
iid
            -- Let even completely apply-unskilled actors trigger basic embeds.
            -- See the note about no skill check when melee triggers effects.
            legal :: Either ReqFailure Bool
legal = RuleContent
-> Time
-> Int
-> Bool
-> Maybe CStore
-> ItemFull
-> ItemQuant
-> Either ReqFailure Bool
permittedApply RuleContent
corule Time
localTime Int
forall a. Bounded a => a
maxBound Bool
calmE Maybe CStore
forall a. Maybe a
Nothing
                                   ItemFull
itemFull ItemQuant
kit
        case Either ReqFailure Bool
legal of
          Left ReqFailure
ApplyNoEffects -> UseResult -> m UseResult
forall (m :: * -> *) a. Monad m => a -> m a
return UseResult
UseDud  -- pure flavour embed
          Left ReqFailure
reqFail -> do
            -- The failure is fully expected, because client may choose
            -- to trigger some embeds, knowing that others won't fire.
            SfxAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => SfxAtomic -> m ()
execSfxAtomic (SfxAtomic -> m ()) -> SfxAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ FactionId -> SfxMsg -> SfxAtomic
SfxMsgFid (Actor -> FactionId
bfid Actor
sb)
                          (SfxMsg -> SfxAtomic) -> SfxMsg -> SfxAtomic
forall a b. (a -> b) -> a -> b
$ ItemId -> LevelId -> ReqFailure -> SfxMsg
SfxExpectedEmbed ItemId
iid LevelId
lid ReqFailure
reqFail
            UseResult -> m UseResult
forall (m :: * -> *) a. Monad m => a -> m a
return UseResult
UseDud
          Either ReqFailure Bool
_ -> EffToUse
-> Bool -> ActorId -> LevelId -> Point -> ItemId -> m UseResult
forall (m :: * -> *).
MonadServerAtomic m =>
EffToUse
-> Bool -> ActorId -> LevelId -> Point -> ItemId -> m UseResult
itemEffectEmbedded EffToUse
effToUse Bool
voluntary ActorId
source LevelId
lid Point
tpos ItemId
iid
                 -- when @effToUse == EffOnCombine@, terrain, e.g., fire,
                 -- may be removed safely, without adverse effects
                 -- by crafting, even any silly crafting as an exploit; OK
      underFeet :: Bool
underFeet = Point
tpos Point -> Point -> Bool
forall a. Eq a => a -> a -> Bool
== Actor -> Point
bpos Actor
sb  -- if enter and alter, be more permissive
      blockedByItem :: Bool
blockedByItem = Point -> EnumMap Point (EnumMap ItemId ItemQuant) -> Bool
forall k a. Enum k => k -> EnumMap k a -> Bool
EM.member Point
tpos (Level -> EnumMap Point (EnumMap ItemId ItemQuant)
lfloor Level
lvl)
  if Point -> Point -> Int
chessDist Point
tpos (Actor -> Point
bpos Actor
sb) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
  then Maybe ReqFailure -> m (Maybe ReqFailure)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ReqFailure -> m (Maybe ReqFailure))
-> Maybe ReqFailure -> m (Maybe ReqFailure)
forall a b. (a -> b) -> a -> b
$ ReqFailure -> Maybe ReqFailure
forall a. a -> Maybe a
Just ReqFailure
AlterDistant
  else if ContentId TileKind -> Maybe (ContentId TileKind)
forall a. a -> Maybe a
Just ContentId TileKind
clientTile Maybe (ContentId TileKind) -> Maybe (ContentId TileKind) -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe (ContentId TileKind)
hiddenTile then  -- searches
    -- Only non-projectile actors with SkAlter > 1 can search terrain.
    -- Even projectiles with large altering bonuses can't.
    if Actor -> Bool
bproj Actor
sb Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
underFeet Bool -> Bool -> Bool
&& Int
alterSkill Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1
    then Maybe ReqFailure -> m (Maybe ReqFailure)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ReqFailure -> m (Maybe ReqFailure))
-> Maybe ReqFailure -> m (Maybe ReqFailure)
forall a b. (a -> b) -> a -> b
$ ReqFailure -> Maybe ReqFailure
forall a. a -> Maybe a
Just ReqFailure
AlterUnskilled  -- don't leak about searching
    else do
      -- Blocking by items nor actors does not prevent searching.
      -- Searching broadcasted, in case actors from other factions are present
      -- so that they can learn the tile and learn our action.
      -- If they already know the tile, they will just consider our action
      -- a waste of time and ignore the command.
      UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ ActorId -> Point -> ContentId TileKind -> UpdAtomic
UpdSearchTile ActorId
source Point
tpos ContentId TileKind
serverTile
      -- Searching also reveals the embedded items of the tile.
      -- If the items are already seen by the client
      -- (e.g., due to item detection, despite tile being still hidden),
      -- the command is ignored on the client.
      m ()
revealEmbeds
      -- If the entries are already seen by the client
      -- the command is ignored on the client.
      case Point -> EnumMap Point PlaceEntry -> Maybe PlaceEntry
forall k a. Enum k => k -> EnumMap k a -> Maybe a
EM.lookup Point
tpos (EnumMap Point PlaceEntry -> Maybe PlaceEntry)
-> EnumMap Point PlaceEntry -> Maybe PlaceEntry
forall a b. (a -> b) -> a -> b
$ Level -> EnumMap Point PlaceEntry
lentry Level
lvl of
        Maybe PlaceEntry
Nothing -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just PlaceEntry
entry -> UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ LevelId -> [(Point, PlaceEntry)] -> UpdAtomic
UpdSpotEntry LevelId
lid [(Point
tpos, PlaceEntry
entry)]
      -- Seaching triggers the embeds as well, after they are revealed.
      -- The rationale is that the items were all the time present
      -- (just invisible to the client), so they need to be triggered.
      -- The exception is changable tiles, because they are not so easy
      -- to trigger; they need previous or subsequent altering.
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TileSpeedup -> ContentId TileKind -> Bool
Tile.isModifiable TileSpeedup
coTileSpeedup ContentId TileKind
serverTile Bool -> Bool -> Bool
|| Bool
projNoDamage) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        ((ItemId, ItemQuant) -> m ()) -> [(ItemId, ItemQuant)] -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m ()) -> t a -> m ()
mapM_ (m UseResult -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m UseResult -> m ())
-> ((ItemId, ItemQuant) -> m UseResult)
-> (ItemId, ItemQuant)
-> m ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ItemId, ItemQuant) -> m UseResult
tryApplyEmbed)
              (COps
-> ContentId TileKind
-> [(ItemKind, (ItemId, ItemQuant))]
-> [(ItemId, ItemQuant)]
sortEmbeds COps
cops ContentId TileKind
serverTile [(ItemKind, (ItemId, ItemQuant))]
embedKindList)
      Maybe ReqFailure -> m (Maybe ReqFailure)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ReqFailure
forall a. Maybe a
Nothing  -- searching is always success
  else
    -- Here either @clientTile == serverTile@ or the client
    -- is misguided re tile at that position, e.g., it is a projectile
    -- that can't see the tile and the tile was not revealed so far.
    -- In either case, try to alter the tile. If the messages
    -- are confusing, that's fair, situation is confusing.
    if Bool -> Bool
not (Actor -> Bool
bproj Actor
sb Bool -> Bool -> Bool
|| Bool
underFeet)  -- no global skill check in these cases
       Bool -> Bool -> Bool
&& Int
alterSkill Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
tileMinSkill
    then Maybe ReqFailure -> m (Maybe ReqFailure)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ReqFailure -> m (Maybe ReqFailure))
-> Maybe ReqFailure -> m (Maybe ReqFailure)
forall a b. (a -> b) -> a -> b
$ ReqFailure -> Maybe ReqFailure
forall a. a -> Maybe a
Just ReqFailure
AlterUnskilled  -- don't leak about altering
    else do
      -- Save the original content of ground and eqp to abort transformations
      -- if any item is removed, possibly an item intended as the fuel.
      EnumMap ItemId ItemQuant
groundBag <- (State -> EnumMap ItemId ItemQuant) -> m (EnumMap ItemId ItemQuant)
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> EnumMap ItemId ItemQuant)
 -> m (EnumMap ItemId ItemQuant))
-> (State -> EnumMap ItemId ItemQuant)
-> m (EnumMap ItemId ItemQuant)
forall a b. (a -> b) -> a -> b
$ Actor -> CStore -> State -> EnumMap ItemId ItemQuant
getBodyStoreBag Actor
sb CStore
CGround
      EnumMap ItemId ItemQuant
eqpBag <- (State -> EnumMap ItemId ItemQuant) -> m (EnumMap ItemId ItemQuant)
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> EnumMap ItemId ItemQuant)
 -> m (EnumMap ItemId ItemQuant))
-> (State -> EnumMap ItemId ItemQuant)
-> m (EnumMap ItemId ItemQuant)
forall a b. (a -> b) -> a -> b
$ Actor -> CStore -> State -> EnumMap ItemId ItemQuant
getBodyStoreBag Actor
sb CStore
CEqp
      -- Compute items to use for transformation early, before any extra
      -- items added by activated embeds, to use only intended items as fuel.
      -- Use even unidentified items --- one more way to id by use.
      [(ItemId, ItemFullKit)]
kitAssG <- (State -> [(ItemId, ItemFullKit)]) -> m [(ItemId, ItemFullKit)]
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> [(ItemId, ItemFullKit)]) -> m [(ItemId, ItemFullKit)])
-> (State -> [(ItemId, ItemFullKit)]) -> m [(ItemId, ItemFullKit)]
forall a b. (a -> b) -> a -> b
$ ActorId -> [CStore] -> State -> [(ItemId, ItemFullKit)]
kitAssocs ActorId
source [CStore
CGround]
      [(ItemId, ItemFullKit)]
kitAssE <- (State -> [(ItemId, ItemFullKit)]) -> m [(ItemId, ItemFullKit)]
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> [(ItemId, ItemFullKit)]) -> m [(ItemId, ItemFullKit)])
-> (State -> [(ItemId, ItemFullKit)]) -> m [(ItemId, ItemFullKit)]
forall a b. (a -> b) -> a -> b
$ ActorId -> [CStore] -> State -> [(ItemId, ItemFullKit)]
kitAssocs ActorId
source [CStore
CEqp]
      let kitAss :: [((CStore, Bool), (ItemId, ItemFullKit))]
kitAss = [(ItemId, ItemFullKit)]
-> [(ItemId, ItemFullKit)]
-> [((CStore, Bool), (ItemId, ItemFullKit))]
listToolsToConsume [(ItemId, ItemFullKit)]
kitAssG [(ItemId, ItemFullKit)]
kitAssE
          announceTileChange :: m ()
announceTileChange =
            -- If no embeds and the only thing that happens is the change
            -- of the tile, don't display a message, because the change
            -- is visible on the map (unless it changes into itself)
            -- and there's nothing more to speak about.
            -- However, even with embeds, don't spam if wading through
            -- terrain and changing it each step.
            Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
underFeet Bool -> Bool -> Bool
|| EnumMap ItemId ItemQuant -> Bool
forall k a. EnumMap k a -> Bool
EM.null EnumMap ItemId ItemQuant
embeds) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
              SfxAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => SfxAtomic -> m ()
execSfxAtomic (SfxAtomic -> m ()) -> SfxAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ ActorId -> LevelId -> Point -> ContentId TileKind -> SfxAtomic
SfxTrigger ActorId
source LevelId
lid Point
tpos ContentId TileKind
serverTile
          changeTo :: GroupName TileKind -> m ()
changeTo GroupName TileKind
tgroup = do
            -- No @SfxAlter@, because the effect is obvious (e.g., opened door).
            let nightCond :: TileKind -> Bool
nightCond TileKind
kt = Bool -> Bool
not (Feature -> TileKind -> Bool
Tile.kindHasFeature Feature
TK.Walkable TileKind
kt
                                    Bool -> Bool -> Bool
&& Feature -> TileKind -> Bool
Tile.kindHasFeature Feature
TK.Clear TileKind
kt)
                               Bool -> Bool -> Bool
|| (if Level -> Bool
lnight Level
lvl then Bool -> Bool
forall a. a -> a
id else Bool -> Bool
not)
                                    (Feature -> TileKind -> Bool
Tile.kindHasFeature Feature
TK.Dark TileKind
kt)
            -- Sometimes the tile is determined precisely by the ambient light
            -- of the source tiles. If not, default to cave day/night condition.
            Maybe (ContentId TileKind)
mtoTile <- Rnd (Maybe (ContentId TileKind)) -> m (Maybe (ContentId TileKind))
forall (m :: * -> *) a. MonadServer m => Rnd a -> m a
rndToAction (Rnd (Maybe (ContentId TileKind))
 -> m (Maybe (ContentId TileKind)))
-> Rnd (Maybe (ContentId TileKind))
-> m (Maybe (ContentId TileKind))
forall a b. (a -> b) -> a -> b
$ ContentData TileKind
-> GroupName TileKind
-> (TileKind -> Bool)
-> Rnd (Maybe (ContentId TileKind))
forall a.
Show a =>
ContentData a
-> GroupName a -> (a -> Bool) -> Rnd (Maybe (ContentId a))
opick ContentData TileKind
cotile GroupName TileKind
tgroup TileKind -> Bool
nightCond
            ContentId TileKind
toTile <- m (ContentId TileKind)
-> (ContentId TileKind -> m (ContentId TileKind))
-> Maybe (ContentId TileKind)
-> m (ContentId TileKind)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Rnd (ContentId TileKind) -> m (ContentId TileKind)
forall (m :: * -> *) a. MonadServer m => Rnd a -> m a
rndToAction
                             (Rnd (ContentId TileKind) -> m (ContentId TileKind))
-> Rnd (ContentId TileKind) -> m (ContentId TileKind)
forall a b. (a -> b) -> a -> b
$ ContentId TileKind
-> Maybe (ContentId TileKind) -> ContentId TileKind
forall a. a -> Maybe a -> a
fromMaybe (String -> ContentId TileKind
forall a. (?callStack::CallStack) => String -> a
error (String -> ContentId TileKind) -> String -> ContentId TileKind
forall a b. (a -> b) -> a -> b
$ String
"" String -> GroupName TileKind -> String
forall v. Show v => String -> v -> String
`showFailure` GroupName TileKind
tgroup)
                               (Maybe (ContentId TileKind) -> ContentId TileKind)
-> Rnd (Maybe (ContentId TileKind)) -> Rnd (ContentId TileKind)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContentData TileKind
-> GroupName TileKind
-> (TileKind -> Bool)
-> Rnd (Maybe (ContentId TileKind))
forall a.
Show a =>
ContentData a
-> GroupName a -> (a -> Bool) -> Rnd (Maybe (ContentId a))
opick ContentData TileKind
cotile GroupName TileKind
tgroup (Bool -> TileKind -> Bool
forall a b. a -> b -> a
const Bool
True))
                            ContentId TileKind -> m (ContentId TileKind)
forall (m :: * -> *) a. Monad m => a -> m a
return
                            Maybe (ContentId TileKind)
mtoTile
            EnumMap ItemId ItemQuant
embeds2 <- (State -> EnumMap ItemId ItemQuant) -> m (EnumMap ItemId ItemQuant)
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> EnumMap ItemId ItemQuant)
 -> m (EnumMap ItemId ItemQuant))
-> (State -> EnumMap ItemId ItemQuant)
-> m (EnumMap ItemId ItemQuant)
forall a b. (a -> b) -> a -> b
$ LevelId -> Point -> State -> EnumMap ItemId ItemQuant
getEmbedBag LevelId
lid Point
tpos
            let newHasEmbeds :: Bool
newHasEmbeds = TileSpeedup -> ContentId TileKind -> Bool
Tile.isEmbed TileSpeedup
coTileSpeedup ContentId TileKind
toTile
            -- Don't regenerate same tile, unless it had embeds, but all spent.
            Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ContentId TileKind
serverTile ContentId TileKind -> ContentId TileKind -> Bool
forall a. Eq a => a -> a -> Bool
/= ContentId TileKind
toTile
                  Bool -> Bool -> Bool
|| EnumMap ItemId ItemQuant -> Bool
forall k a. EnumMap k a -> Bool
EM.null EnumMap ItemId ItemQuant
embeds2 Bool -> Bool -> Bool
&& Bool
newHasEmbeds) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
              -- At most one of these two will be accepted on any given client.
              Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ContentId TileKind
serverTile ContentId TileKind -> ContentId TileKind -> Bool
forall a. Eq a => a -> a -> Bool
/= ContentId TileKind
toTile) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
                UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ LevelId
-> Point -> ContentId TileKind -> ContentId TileKind -> UpdAtomic
UpdAlterTile LevelId
lid Point
tpos ContentId TileKind
serverTile ContentId TileKind
toTile
              -- This case happens when a client does not see a searching
              -- action by another faction, but sees the subsequent altering
              -- or if another altering takes place in between.
              case Maybe (ContentId TileKind)
hiddenTile of
                Just ContentId TileKind
tHidden ->
                  UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ LevelId
-> Point -> ContentId TileKind -> ContentId TileKind -> UpdAtomic
UpdAlterTile LevelId
lid Point
tpos ContentId TileKind
tHidden ContentId TileKind
toTile
                Maybe (ContentId TileKind)
Nothing -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
              -- @UpdAlterExplorable@ is received by any client regardless
              -- of whether the alteration was seen and how.
              case (TileSpeedup -> ContentId TileKind -> Bool
Tile.isExplorable TileSpeedup
coTileSpeedup ContentId TileKind
serverTile,
                    TileSpeedup -> ContentId TileKind -> Bool
Tile.isExplorable TileSpeedup
coTileSpeedup ContentId TileKind
toTile) of
                (Bool
False, Bool
True) -> UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ LevelId -> Int -> UpdAtomic
UpdAlterExplorable LevelId
lid Int
1
                (Bool
True, Bool
False) -> UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ LevelId -> Int -> UpdAtomic
UpdAlterExplorable LevelId
lid (-Int
1)
                (Bool, Bool)
_ -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
              -- At the end we replace old embeds (even if partially used up)
              -- with new ones.
              -- If the source tile was hidden, the items could not be visible
              -- on a client, in which case the command would be ignored
              -- on the client, without causing any problems. Otherwise,
              -- if the position is in view, client has accurate info.
              Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (EnumMap ItemId ItemQuant -> Bool
forall k a. EnumMap k a -> Bool
EM.null EnumMap ItemId ItemQuant
embeds2) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
                UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ Bool -> Container -> EnumMap ItemId ItemQuant -> UpdAtomic
UpdLoseItemBag Bool
True (LevelId -> Point -> Container
CEmbed LevelId
lid Point
tpos) EnumMap ItemId ItemQuant
embeds2
              -- Altering always reveals the outcome tile, so it's not hidden
              -- and so its embedded items are always visible.
              LevelId -> Point -> ContentId TileKind -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
LevelId -> Point -> ContentId TileKind -> m ()
embedItemOnPos LevelId
lid Point
tpos ContentId TileKind
toTile
          tryChangeWith :: ( [(Int, GroupName IK.ItemKind)]
                           , GroupName TK.TileKind )
                        -> m Bool
          tryChangeWith :: ([(Int, GroupName ItemKind)], GroupName TileKind) -> m Bool
tryChangeWith ([(Int, GroupName ItemKind)]
tools0, GroupName TileKind
tgroup) = do
            let grps0 :: [(Bool, Int, GroupName ItemKind)]
grps0 = ((Int, GroupName ItemKind) -> (Bool, Int, GroupName ItemKind))
-> [(Int, GroupName ItemKind)] -> [(Bool, Int, GroupName ItemKind)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
x, GroupName ItemKind
y) -> (Bool
False, Int
x, GroupName ItemKind
y)) [(Int, GroupName ItemKind)]
tools0
                  -- apply if durable
                (EnumMap CStore (EnumMap ItemId ItemQuant)
bagsToLose, [(CStore, (ItemId, ItemFull))]
iidsToApply, [(Bool, Int, GroupName ItemKind)]
grps) =
                  ((EnumMap CStore (EnumMap ItemId ItemQuant),
  [(CStore, (ItemId, ItemFull))], [(Bool, Int, GroupName ItemKind)])
 -> ((CStore, Bool), (ItemId, ItemFullKit))
 -> (EnumMap CStore (EnumMap ItemId ItemQuant),
     [(CStore, (ItemId, ItemFull))], [(Bool, Int, GroupName ItemKind)]))
-> (EnumMap CStore (EnumMap ItemId ItemQuant),
    [(CStore, (ItemId, ItemFull))], [(Bool, Int, GroupName ItemKind)])
-> [((CStore, Bool), (ItemId, ItemFullKit))]
-> (EnumMap CStore (EnumMap ItemId ItemQuant),
    [(CStore, (ItemId, ItemFull))], [(Bool, Int, GroupName ItemKind)])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (EnumMap CStore (EnumMap ItemId ItemQuant),
 [(CStore, (ItemId, ItemFull))], [(Bool, Int, GroupName ItemKind)])
-> ((CStore, Bool), (ItemId, ItemFullKit))
-> (EnumMap CStore (EnumMap ItemId ItemQuant),
    [(CStore, (ItemId, ItemFull))], [(Bool, Int, GroupName ItemKind)])
subtractIidfromGrps (EnumMap CStore (EnumMap ItemId ItemQuant)
forall k a. EnumMap k a
EM.empty, [], [(Bool, Int, GroupName ItemKind)]
grps0) [((CStore, Bool), (ItemId, ItemFullKit))]
kitAss
            if [(Bool, Int, GroupName ItemKind)] -> Bool
forall a. [a] -> Bool
null [(Bool, Int, GroupName ItemKind)]
grps then do
              m ()
announceTileChange  -- first the result is foretold
              ActorId
-> EnumMap CStore (EnumMap ItemId ItemQuant)
-> [(CStore, (ItemId, ItemFull))]
-> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId
-> EnumMap CStore (EnumMap ItemId ItemQuant)
-> [(CStore, (ItemId, ItemFull))]
-> m ()
consumeItems ActorId
source EnumMap CStore (EnumMap ItemId ItemQuant)
bagsToLose [(CStore, (ItemId, ItemFull))]
iidsToApply  -- then the cost
              GroupName TileKind -> m ()
changeTo GroupName TileKind
tgroup  -- then result is seen
              Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
            else Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
          feats :: [Feature]
feats = TileKind -> [Feature]
TK.tfeature (TileKind -> [Feature]) -> TileKind -> [Feature]
forall a b. (a -> b) -> a -> b
$ ContentData TileKind -> ContentId TileKind -> TileKind
forall a. ContentData a -> ContentId a -> a
okind ContentData TileKind
cotile ContentId TileKind
serverTile
          tileActions :: [TileAction]
tileActions =
            (Feature -> Maybe TileAction) -> [Feature] -> [TileAction]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Bool
-> Bool
-> [(ItemKind, (ItemId, ItemQuant))]
-> Feature
-> Maybe TileAction
parseTileAction
                        (Actor -> Bool
bproj Actor
sb)
                        (Bool
underFeet Bool -> Bool -> Bool
|| Bool
blockedByItem)  -- avoids AlterBlockItem
                        [(ItemKind, (ItemId, ItemQuant))]
embedKindList)
                     [Feature]
feats
          groupWithFromAction :: TileAction -> Maybe [(Int, GroupName ItemKind)]
groupWithFromAction TileAction
action = case TileAction
action of
            WithAction [(Int, GroupName ItemKind)]
grps GroupName TileKind
_ | Bool -> Bool
not Bool
bumping -> [(Int, GroupName ItemKind)] -> Maybe [(Int, GroupName ItemKind)]
forall a. a -> Maybe a
Just [(Int, GroupName ItemKind)]
grps
            TileAction
_ -> Maybe [(Int, GroupName ItemKind)]
forall a. Maybe a
Nothing
          groupsToAlterWith :: [[(Int, GroupName ItemKind)]]
groupsToAlterWith = (TileAction -> Maybe [(Int, GroupName ItemKind)])
-> [TileAction] -> [[(Int, GroupName ItemKind)]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TileAction -> Maybe [(Int, GroupName ItemKind)]
groupWithFromAction [TileAction]
tileActions
          processTileActions :: Maybe UseResult -> [TileAction] -> m Bool
          processTileActions :: Maybe UseResult -> [TileAction] -> m Bool
processTileActions Maybe UseResult
museResult [] =
            Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$! Bool -> (UseResult -> Bool) -> Maybe UseResult -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (UseResult -> UseResult -> Bool
forall a. Eq a => a -> a -> Bool
/= UseResult
UseDud) Maybe UseResult
museResult
          processTileActions Maybe UseResult
museResult (TileAction
ta : [TileAction]
rest) = case TileAction
ta of
            EmbedAction (ItemId
iid, ItemQuant
kit) ->
              -- Embeds are activated in the order in tile definition
              -- and never after the tile is changed.
              -- If any embedded item was present and processed,
              -- but none was triggered, both free and item-consuming terrain
              -- alteration is disabled. The exception is projectiles
              -- not being able to process embeds due to skill required,
              -- which does not block future terrain alteration.
              -- Skill check for non-projectiles is performed much earlier.
              -- All projectiles have 0 skill for the purpose of embed
              -- activation, regardless of their trunk.
              if | Actor -> Bool
bproj Actor
sb Bool -> Bool -> Bool
&& Int
tileMinSkill Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 ->  -- local skill check
                   Maybe UseResult -> [TileAction] -> m Bool
processTileActions Maybe UseResult
museResult [TileAction]
rest
                     -- not blocking future terrain altering, e.g., oil mist
                     -- not slowed over water tile that has @talter@ equal to 2,
                     -- but able to change it into oil spill soon after
                 | Bool
projNoDamage ->
                   Maybe UseResult -> [TileAction] -> m Bool
processTileActions (UseResult -> Maybe UseResult
forall a. a -> Maybe a
Just UseResult
UseDud) [TileAction]
rest
                     -- projectiles having enough skill, but no damage,
                     -- not only can't activate embeds, but block future
                     -- terrain altering, e.g., oil mist not puncturing
                     -- a barrel and causing explosion, and so also
                     -- not causing it to disappear later on
                 | Bool
otherwise -> do
                     -- here falls the case of fragmentation blast puncturing
                     -- a barrel and so causing an explosion
                     UseResult
triggered <- (ItemId, ItemQuant) -> m UseResult
tryApplyEmbed (ItemId
iid, ItemQuant
kit)
                     let useResult :: UseResult
useResult = UseResult -> Maybe UseResult -> UseResult
forall a. a -> Maybe a -> a
fromMaybe UseResult
UseDud Maybe UseResult
museResult
                     Maybe UseResult -> [TileAction] -> m Bool
processTileActions (UseResult -> Maybe UseResult
forall a. a -> Maybe a
Just (UseResult -> Maybe UseResult) -> UseResult -> Maybe UseResult
forall a b. (a -> b) -> a -> b
$ UseResult -> UseResult -> UseResult
forall a. Ord a => a -> a -> a
max UseResult
useResult UseResult
triggered) [TileAction]
rest
                       -- max means that even one activated embed is enough
                       -- to alter terrain in a future action
            ToAction GroupName TileKind
tgroup -> Bool -> m Bool -> m Bool
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Bool -> Bool
not (Actor -> Bool
bproj Actor
sb)) (m Bool -> m Bool) -> m Bool -> m Bool
forall a b. (a -> b) -> a -> b
$
              -- @parseTileAction@ ensures the above assertion
              -- so that projectiles never cause normal transitions and,
              -- e.g., mists douse fires or two flames thrown, first ignites,
              -- second douses immediately afterwards
              if Bool -> (UseResult -> Bool) -> Maybe UseResult -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (UseResult -> UseResult -> Bool
forall a. Eq a => a -> a -> Bool
== UseResult
UseUp) Maybe UseResult
museResult
              then do
                m ()
announceTileChange
                GroupName TileKind -> m ()
changeTo GroupName TileKind
tgroup
                Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
              else Maybe UseResult -> [TileAction] -> m Bool
processTileActions Maybe UseResult
museResult [TileAction]
rest
            WithAction [(Int, GroupName ItemKind)]
grps GroupName TileKind
tgroup -> do
              -- Note that there is no skill check if the source actors
              -- is a projectile. Permission is conveyed in @ProjYes@ instead.
              EnumMap ItemId ItemQuant
groundBag2 <- (State -> EnumMap ItemId ItemQuant) -> m (EnumMap ItemId ItemQuant)
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> EnumMap ItemId ItemQuant)
 -> m (EnumMap ItemId ItemQuant))
-> (State -> EnumMap ItemId ItemQuant)
-> m (EnumMap ItemId ItemQuant)
forall a b. (a -> b) -> a -> b
$ Actor -> CStore -> State -> EnumMap ItemId ItemQuant
getBodyStoreBag Actor
sb CStore
CGround
              EnumMap ItemId ItemQuant
eqpBag2 <- (State -> EnumMap ItemId ItemQuant) -> m (EnumMap ItemId ItemQuant)
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> EnumMap ItemId ItemQuant)
 -> m (EnumMap ItemId ItemQuant))
-> (State -> EnumMap ItemId ItemQuant)
-> m (EnumMap ItemId ItemQuant)
forall a b. (a -> b) -> a -> b
$ Actor -> CStore -> State -> EnumMap ItemId ItemQuant
getBodyStoreBag Actor
sb CStore
CEqp
              if (Bool -> Bool
not Bool
bumping Bool -> Bool -> Bool
|| [(Int, GroupName ItemKind)] -> Bool
forall a. [a] -> Bool
null [(Int, GroupName ItemKind)]
grps)
                   -- 'M' confirmation needed to consume items, bump not enough
                 Bool -> Bool -> Bool
&& (Actor -> Bool
bproj Actor
sb Bool -> Bool -> Bool
|| Bool
voluntary Bool -> Bool -> Bool
|| [(Int, GroupName ItemKind)] -> Bool
forall a. [a] -> Bool
null [(Int, GroupName ItemKind)]
grps)
                       -- consume only if voluntary or released as projectile
                 Bool -> Bool -> Bool
&& (Bool -> (UseResult -> Bool) -> Maybe UseResult -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (UseResult -> UseResult -> Bool
forall a. Eq a => a -> a -> Bool
== UseResult
UseUp) Maybe UseResult
museResult
                     Bool -> Bool -> Bool
|| EffToUse
effToUse EffToUse -> EffToUse -> Bool
forall a. Eq a => a -> a -> Bool
== EffToUse
EffOnCombine)
                          -- unwanted crafting shouldn't block transformations
                 Bool -> Bool -> Bool
&& let f :: (a, b) -> (a, b) -> Bool
f (a
k1, b
_) (a
k2, b
_) = a
k1 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
k2
                    in (ItemQuant -> ItemQuant -> Bool)
-> EnumMap ItemId ItemQuant -> EnumMap ItemId ItemQuant -> Bool
forall a b k.
(a -> b -> Bool) -> EnumMap k a -> EnumMap k b -> Bool
EM.isSubmapOfBy ItemQuant -> ItemQuant -> Bool
forall a b b. Ord a => (a, b) -> (a, b) -> Bool
f EnumMap ItemId ItemQuant
groundBag EnumMap ItemId ItemQuant
groundBag2
                       Bool -> Bool -> Bool
&& (ItemQuant -> ItemQuant -> Bool)
-> EnumMap ItemId ItemQuant -> EnumMap ItemId ItemQuant -> Bool
forall a b k.
(a -> b -> Bool) -> EnumMap k a -> EnumMap k b -> Bool
EM.isSubmapOfBy ItemQuant -> ItemQuant -> Bool
forall a b b. Ord a => (a, b) -> (a, b) -> Bool
f EnumMap ItemId ItemQuant
eqpBag EnumMap ItemId ItemQuant
eqpBag2
                      -- don't transform if items, possibly intended for
                      -- transformation, removed; also when only crafting
                      -- was intended, which almost always removes some items
              then do
                Bool
altered <- ([(Int, GroupName ItemKind)], GroupName TileKind) -> m Bool
tryChangeWith ([(Int, GroupName ItemKind)]
grps, GroupName TileKind
tgroup)
                if Bool
altered
                then Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                else Maybe UseResult -> [TileAction] -> m Bool
processTileActions Maybe UseResult
museResult [TileAction]
rest
              else Maybe UseResult -> [TileAction] -> m Bool
processTileActions Maybe UseResult
museResult [TileAction]
rest
      -- Note that stray embedded items (not from tile content definition)
      -- are never activated.
      if [TileAction] -> Bool
forall a. [a] -> Bool
null [TileAction]
tileActions then
        Maybe ReqFailure -> m (Maybe ReqFailure)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ReqFailure -> m (Maybe ReqFailure))
-> Maybe ReqFailure -> m (Maybe ReqFailure)
forall a b. (a -> b) -> a -> b
$! if Bool
blockedByItem
                     Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
underFeet
                     Bool -> Bool -> Bool
&& TileSpeedup -> ContentId TileKind -> Bool
Tile.isModifiable TileSpeedup
coTileSpeedup ContentId TileKind
serverTile
                  then ReqFailure -> Maybe ReqFailure
forall a. a -> Maybe a
Just ReqFailure
AlterBlockItem  -- likely cause
                  else ReqFailure -> Maybe ReqFailure
forall a. a -> Maybe a
Just ReqFailure
AlterNothing  -- can't do; silly client; fail
      else
        if Bool
underFeet Bool -> Bool -> Bool
|| Bool -> Bool
not (Point -> Level -> Bool
occupiedBigLvl Point
tpos Level
lvl)
                        Bool -> Bool -> Bool
&& Bool -> Bool
not (Point -> Level -> Bool
occupiedProjLvl Point
tpos Level
lvl) then do
          -- The items are first revealed for the sake of clients that
          -- may see the tile as hidden. Note that the tile is not revealed
          -- (unless it's altered later on, in which case the new one is).
          m ()
revealEmbeds
          Bool
tileTriggered <- Maybe UseResult -> [TileAction] -> m Bool
processTileActions Maybe UseResult
forall a. Maybe a
Nothing [TileAction]
tileActions
          let potentiallyMissing :: [[(Int, GroupName ItemKind)]]
potentiallyMissing = ([(Int, GroupName ItemKind)] -> Bool)
-> [[(Int, GroupName ItemKind)]] -> [[(Int, GroupName ItemKind)]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ([(Int, GroupName ItemKind)] -> Bool)
-> [(Int, GroupName ItemKind)]
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Int, GroupName ItemKind)] -> Bool
forall a. [a] -> Bool
null) [[(Int, GroupName ItemKind)]]
groupsToAlterWith
          Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
tileTriggered Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
underFeet Bool -> Bool -> Bool
&& Bool
voluntary
                Bool -> Bool -> Bool
&& Bool -> Bool
not ([[(Int, GroupName ItemKind)]] -> Bool
forall a. [a] -> Bool
null [[(Int, GroupName ItemKind)]]
potentiallyMissing)) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
            SfxAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => SfxAtomic -> m ()
execSfxAtomic (SfxAtomic -> m ()) -> SfxAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ FactionId -> SfxMsg -> SfxAtomic
SfxMsgFid (Actor -> FactionId
bfid Actor
sb)
                          (SfxMsg -> SfxAtomic) -> SfxMsg -> SfxAtomic
forall a b. (a -> b) -> a -> b
$ [[(Int, GroupName ItemKind)]] -> SfxMsg
SfxNoItemsForTile [[(Int, GroupName ItemKind)]]
potentiallyMissing
          Maybe ReqFailure -> m (Maybe ReqFailure)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ReqFailure
forall a. Maybe a
Nothing  -- altered as much as items allowed; success
        else Maybe ReqFailure -> m (Maybe ReqFailure)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ReqFailure -> m (Maybe ReqFailure))
-> Maybe ReqFailure -> m (Maybe ReqFailure)
forall a b. (a -> b) -> a -> b
$ ReqFailure -> Maybe ReqFailure
forall a. a -> Maybe a
Just ReqFailure
AlterBlockActor

-- * ReqWait

-- | Do nothing. Wait skill 1 required. Bracing requires 2, sleep 3, lurking 4.
--
-- Something is sometimes done in 'processWatchfulness'.
reqWait :: MonadServerAtomic m => ActorId -> m ()
{-# INLINE reqWait #-}
reqWait :: ActorId -> m ()
reqWait ActorId
source = do
  Skills
actorSk <- ActorId -> m Skills
forall (m :: * -> *). MonadServer m => ActorId -> m Skills
currentSkillsServer ActorId
source
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Skill -> Skills -> Int
Ability.getSk Skill
Ability.SkWait Skills
actorSk Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    ActorId -> RequestTimed -> ReqFailure -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId -> RequestTimed -> ReqFailure -> m ()
execFailure ActorId
source RequestTimed
ReqWait ReqFailure
WaitUnskilled

-- * ReqWait10

-- | Do nothing.
--
-- Something is sometimes done in 'processWatchfulness'.
reqWait10 :: MonadServerAtomic m => ActorId -> m ()
{-# INLINE reqWait10 #-}
reqWait10 :: ActorId -> m ()
reqWait10 ActorId
source = do
  Skills
actorSk <- ActorId -> m Skills
forall (m :: * -> *). MonadServer m => ActorId -> m Skills
currentSkillsServer ActorId
source
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Skill -> Skills -> Int
Ability.getSk Skill
Ability.SkWait Skills
actorSk Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
4) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    ActorId -> RequestTimed -> ReqFailure -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId -> RequestTimed -> ReqFailure -> m ()
execFailure ActorId
source RequestTimed
ReqWait10 ReqFailure
WaitUnskilled

-- * ReqYell

-- | Yell/yawn/stretch/taunt.
-- Wakes up (gradually) from sleep. Causes noise heard by enemies on the level
-- even if out of their hearing range.
--
-- Governed by the waiting skill (because everyone is supposed to have it).
-- unlike @ReqWait@, induces overhead.
--
-- This is similar to the effect @Yell@, but always voluntary.
reqYell :: MonadServerAtomic m => ActorId -> m ()
reqYell :: ActorId -> m ()
reqYell ActorId
aid = do
  Skills
actorSk <- ActorId -> m Skills
forall (m :: * -> *). MonadServer m => ActorId -> m Skills
currentSkillsServer ActorId
aid
  if | Skill -> Skills -> Int
Ability.getSk Skill
Ability.SkWait Skills
actorSk Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 ->
       -- Last yawn before waking up is displayed as a yell, but that's fine.
       -- To fix that, we'd need to move the @SfxTaunt@
       -- to @processWatchfulness@.
       SfxAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => SfxAtomic -> m ()
execSfxAtomic (SfxAtomic -> m ()) -> SfxAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ Bool -> ActorId -> SfxAtomic
SfxTaunt Bool
True ActorId
aid
     | Skill -> Skills -> Int
Ability.getSk Skill
Ability.SkMove Skills
actorSk Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0
       Bool -> Bool -> Bool
|| Skill -> Skills -> Int
Ability.getSk Skill
Ability.SkDisplace Skills
actorSk Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0
       Bool -> Bool -> Bool
|| Skill -> Skills -> Int
Ability.getSk Skill
Ability.SkMelee Skills
actorSk Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 ->
       -- Potentially, only waiting is possible, so given that it's drained,
       -- don't let the actor be stuck nor alarm about server failure.
       SfxAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => SfxAtomic -> m ()
execSfxAtomic (SfxAtomic -> m ()) -> SfxAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ Bool -> ActorId -> SfxAtomic
SfxTaunt Bool
False ActorId
aid
     | Bool
otherwise -> do
       -- In most situation one of the 3 actions above
       -- can be performed and waiting skill is not needed for that,
       -- so given the 3 skills are available, waste turn, waiting until
       -- they can be performed, but don't alarm, because it does happen
       -- sometimes in crowds. No bracing granted, either, but mark
       -- waiting so that AI knows to change leader.
       --   execFailure aid ReqYell YellUnskilled
       Actor
b <- (State -> Actor) -> m Actor
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
aid
       case Actor -> Watchfulness
bwatch Actor
b of
         WWait Int
_ -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
         Watchfulness
_ -> UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ ActorId -> Watchfulness -> Watchfulness -> UpdAtomic
UpdWaitActor ActorId
aid (Actor -> Watchfulness
bwatch Actor
b) (Int -> Watchfulness
WWait Int
0)

-- * ReqMoveItems

reqMoveItems :: MonadServerAtomic m
             => ActorId -> [(ItemId, Int, CStore, CStore)] -> m ()
reqMoveItems :: ActorId -> [(ItemId, Int, CStore, CStore)] -> m ()
reqMoveItems ActorId
source [(ItemId, Int, CStore, CStore)]
l = do
  Skills
actorSk <- ActorId -> m Skills
forall (m :: * -> *). MonadServer m => ActorId -> m Skills
currentSkillsServer ActorId
source
  if Skill -> Skills -> Int
Ability.getSk Skill
Ability.SkMoveItem Skills
actorSk Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then do
    Actor
b <- (State -> Actor) -> m Actor
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
source
    Skills
actorMaxSk <- (State -> Skills) -> m Skills
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Skills) -> m Skills) -> (State -> Skills) -> m Skills
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Skills
getActorMaxSkills ActorId
source
    -- Server accepts item movement based on calm at the start, not end
    -- or in the middle, to avoid interrupted or partially ignored commands.
    let calmE :: Bool
calmE = Actor -> Skills -> Bool
calmEnough Actor
b Skills
actorMaxSk
    case [(ItemId, Int, CStore, CStore)]
l of
      [] -> ActorId -> RequestTimed -> ReqFailure -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId -> RequestTimed -> ReqFailure -> m ()
execFailure ActorId
source ([(ItemId, Int, CStore, CStore)] -> RequestTimed
ReqMoveItems [(ItemId, Int, CStore, CStore)]
l) ReqFailure
ItemNothing
      (ItemId, Int, CStore, CStore)
iid : [(ItemId, Int, CStore, CStore)]
rest -> do
        Bool -> ActorId -> Bool -> (ItemId, Int, CStore, CStore) -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
Bool -> ActorId -> Bool -> (ItemId, Int, CStore, CStore) -> m ()
reqMoveItem Bool
False ActorId
source Bool
calmE (ItemId, Int, CStore, CStore)
iid
        -- Dropping previous may destroy next items.
        ((ItemId, Int, CStore, CStore) -> m ())
-> [(ItemId, Int, CStore, CStore)] -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m ()) -> t a -> m ()
mapM_ (Bool -> ActorId -> Bool -> (ItemId, Int, CStore, CStore) -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
Bool -> ActorId -> Bool -> (ItemId, Int, CStore, CStore) -> m ()
reqMoveItem Bool
True ActorId
source Bool
calmE) [(ItemId, Int, CStore, CStore)]
rest
  else ActorId -> RequestTimed -> ReqFailure -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId -> RequestTimed -> ReqFailure -> m ()
execFailure ActorId
source ([(ItemId, Int, CStore, CStore)] -> RequestTimed
ReqMoveItems [(ItemId, Int, CStore, CStore)]
l) ReqFailure
MoveItemUnskilled

reqMoveItem :: MonadServerAtomic m
            => Bool -> ActorId -> Bool -> (ItemId, Int, CStore, CStore) -> m ()
reqMoveItem :: Bool -> ActorId -> Bool -> (ItemId, Int, CStore, CStore) -> m ()
reqMoveItem Bool
absentPermitted ActorId
aid Bool
calmE (ItemId
iid, Int
kOld, CStore
fromCStore, CStore
toCStore) = do
  Actor
b <- (State -> Actor) -> m Actor
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
aid
  let fromC :: Container
fromC = ActorId -> CStore -> Container
CActor ActorId
aid CStore
fromCStore
      req :: RequestTimed
req = [(ItemId, Int, CStore, CStore)] -> RequestTimed
ReqMoveItems [(ItemId
iid, Int
kOld, CStore
fromCStore, CStore
toCStore)]
  Container
toC <- case CStore
toCStore of
    CStore
CGround -> Bool -> ActorId -> Actor -> m Container
forall (m :: * -> *).
MonadStateRead m =>
Bool -> ActorId -> Actor -> m Container
pickDroppable Bool
False ActorId
aid Actor
b  -- drop over fog, etc.
    CStore
_ -> Container -> m Container
forall (m :: * -> *) a. Monad m => a -> m a
return (Container -> m Container) -> Container -> m Container
forall a b. (a -> b) -> a -> b
$! ActorId -> CStore -> Container
CActor ActorId
aid CStore
toCStore
  EnumMap ItemId ItemQuant
bagFrom <- (State -> EnumMap ItemId ItemQuant) -> m (EnumMap ItemId ItemQuant)
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> EnumMap ItemId ItemQuant)
 -> m (EnumMap ItemId ItemQuant))
-> (State -> EnumMap ItemId ItemQuant)
-> m (EnumMap ItemId ItemQuant)
forall a b. (a -> b) -> a -> b
$ Container -> State -> EnumMap ItemId ItemQuant
getContainerBag (ActorId -> CStore -> Container
CActor ActorId
aid CStore
fromCStore)
  EnumMap ItemId ItemQuant
bagBefore <- (State -> EnumMap ItemId ItemQuant) -> m (EnumMap ItemId ItemQuant)
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> EnumMap ItemId ItemQuant)
 -> m (EnumMap ItemId ItemQuant))
-> (State -> EnumMap ItemId ItemQuant)
-> m (EnumMap ItemId ItemQuant)
forall a b. (a -> b) -> a -> b
$ Container -> State -> EnumMap ItemId ItemQuant
getContainerBag Container
toC
  -- The effect of dropping previous items from this series may have
  -- increased or decreased the number of this item.
  let k :: Int
k = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
kOld (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ ItemQuant -> Int
forall a b. (a, b) -> a
fst (ItemQuant -> Int) -> ItemQuant -> Int
forall a b. (a -> b) -> a -> b
$ ItemQuant -> ItemId -> EnumMap ItemId ItemQuant -> ItemQuant
forall k a. Enum k => a -> k -> EnumMap k a -> a
EM.findWithDefault (Int
0, []) ItemId
iid EnumMap ItemId ItemQuant
bagFrom
  let !_A :: Bool
_A = Bool
absentPermitted Bool -> Bool -> Bool
|| Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
kOld
  if
   | Bool
absentPermitted Bool -> Bool -> Bool
&& Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
   | Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1 Bool -> Bool -> Bool
|| CStore
fromCStore CStore -> CStore -> Bool
forall a. Eq a => a -> a -> Bool
== CStore
toCStore -> ActorId -> RequestTimed -> ReqFailure -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId -> RequestTimed -> ReqFailure -> m ()
execFailure ActorId
aid RequestTimed
req ReqFailure
ItemNothing
   | CStore
fromCStore CStore -> CStore -> Bool
forall a. Eq a => a -> a -> Bool
== CStore
CEqp Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
calmE ->
     ActorId -> RequestTimed -> ReqFailure -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId -> RequestTimed -> ReqFailure -> m ()
execFailure ActorId
aid RequestTimed
req ReqFailure
ItemNotCalm
   | CStore
toCStore CStore -> CStore -> Bool
forall a. Eq a => a -> a -> Bool
== CStore
CEqp Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
calmE ->
     ActorId -> RequestTimed -> ReqFailure -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId -> RequestTimed -> ReqFailure -> m ()
execFailure ActorId
aid RequestTimed
req ReqFailure
ItemNotCalm
   | CStore
toCStore CStore -> CStore -> Bool
forall a. Eq a => a -> a -> Bool
== CStore
CEqp Bool -> Bool -> Bool
&& Actor -> Int -> Bool
eqpOverfull Actor
b Int
k ->
     ActorId -> RequestTimed -> ReqFailure -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId -> RequestTimed -> ReqFailure -> m ()
execFailure ActorId
aid RequestTimed
req ReqFailure
EqpOverfull
   | Bool
otherwise -> do
    [UpdAtomic]
upds <- Bool -> ItemId -> Int -> Container -> Container -> m [UpdAtomic]
forall (m :: * -> *).
MonadStateRead m =>
Bool -> ItemId -> Int -> Container -> Container -> m [UpdAtomic]
generalMoveItem Bool
True ItemId
iid Int
k Container
fromC Container
toC
    (UpdAtomic -> m ()) -> [UpdAtomic] -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m ()) -> t a -> m ()
mapM_ UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic [UpdAtomic]
upds
    ItemFull
itemFull <- (State -> ItemFull) -> m ItemFull
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> ItemFull) -> m ItemFull)
-> (State -> ItemFull) -> m ItemFull
forall a b. (a -> b) -> a -> b
$ ItemId -> State -> ItemFull
itemToFull ItemId
iid
    -- Let any item manipulation attempt to identify, in case the item
    -- got into stash, e.g., by being thrown at the stash location,
    -- and gets identified only when equipped or dropped and picked up again.
    Container -> ItemId -> ContentId ItemKind -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
Container -> ItemId -> ContentId ItemKind -> m ()
discoverIfMinorEffects Container
toC ItemId
iid (ItemFull -> ContentId ItemKind
itemKindId ItemFull
itemFull)
    -- The first recharging period after equipping is random,
    -- between 1 and 2 standard timeouts of the item.
    -- Timeouts for items in shared stash are not consistent wrt the actor's
    -- local time, because actors from many levels put items there
    -- all the time (and don't rebase it to the clock of the stash's level).
    -- If wrong local time in shared stash causes an item to recharge
    -- for a very long time wrt actor on some level,
    -- the player can reset it by dropping the item and picking up again
    -- (as a flip side, a charging item in stash may sometimes
    -- be used at once on another level, with different local time, but only
    -- once, because after first use, the timeout is set to local time).
    -- This is not terribly consistent, but not recharging in stash is
    -- not better, because either we block activation of any items with timeout,
    -- or encourage moving items out of stash, recharging and moving in.
    -- Which is not fun at all, but one more thing to remember doing regularly.
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CStore
toCStore CStore -> [CStore] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CStore
CEqp, CStore
COrgan]
          Bool -> Bool -> Bool
&& CStore
fromCStore CStore -> [CStore] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [CStore
CEqp, CStore
COrgan]
          Bool -> Bool -> Bool
|| CStore
fromCStore CStore -> CStore -> Bool
forall a. Eq a => a -> a -> Bool
== CStore
CStash) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      let beforeIt :: ItemTimers
beforeIt = case ItemId
iid ItemId -> EnumMap ItemId ItemQuant -> Maybe ItemQuant
forall k a. Enum k => k -> EnumMap k a -> Maybe a
`EM.lookup` EnumMap ItemId ItemQuant
bagBefore of
            Maybe ItemQuant
Nothing -> []  -- no such items before move
            Just (Int
_, ItemTimers
it2) -> ItemTimers
it2
      Int -> ItemId -> ItemFull -> ItemTimers -> Container -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
Int -> ItemId -> ItemFull -> ItemTimers -> Container -> m ()
randomResetTimeout Int
k ItemId
iid ItemFull
itemFull ItemTimers
beforeIt Container
toC

-- * ReqProject

reqProject :: MonadServerAtomic m
           => ActorId    -- ^ actor projecting the item (is on current lvl)
           -> Point      -- ^ target position of the projectile
           -> Int        -- ^ digital line parameter
           -> ItemId     -- ^ the item to be projected
           -> CStore     -- ^ which store the items comes from
           -> m ()
reqProject :: ActorId -> Point -> Int -> ItemId -> CStore -> m ()
reqProject ActorId
source Point
tpxy Int
eps ItemId
iid CStore
cstore = do
  let req :: RequestTimed
req = Point -> Int -> ItemId -> CStore -> RequestTimed
ReqProject Point
tpxy Int
eps ItemId
iid CStore
cstore
  Actor
b <- (State -> Actor) -> m Actor
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
source
  Challenge
curChalSer <- (StateServer -> Challenge) -> m Challenge
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer ((StateServer -> Challenge) -> m Challenge)
-> (StateServer -> Challenge) -> m Challenge
forall a b. (a -> b) -> a -> b
$ ServerOptions -> Challenge
scurChalSer (ServerOptions -> Challenge)
-> (StateServer -> ServerOptions) -> StateServer -> Challenge
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateServer -> ServerOptions
soptions
  Faction
fact <- (State -> Faction) -> m Faction
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Faction) -> m Faction)
-> (State -> Faction) -> m Faction
forall a b. (a -> b) -> a -> b
$ (FactionDict -> FactionId -> Faction
forall k a. Enum k => EnumMap k a -> k -> a
EM.! Actor -> FactionId
bfid Actor
b) (FactionDict -> Faction)
-> (State -> FactionDict) -> State -> Faction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> FactionDict
sfactionD
  Skills
actorMaxSk <- (State -> Skills) -> m Skills
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Skills) -> m Skills) -> (State -> Skills) -> m Skills
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Skills
getActorMaxSkills ActorId
source
  let calmE :: Bool
calmE = Actor -> Skills -> Bool
calmEnough Actor
b Skills
actorMaxSk
  if | Challenge -> Bool
ckeeper Challenge
curChalSer Bool -> Bool -> Bool
&& FactionKind -> Bool
fhasUI (Faction -> FactionKind
gkind Faction
fact) ->
        ActorId -> RequestTimed -> ReqFailure -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId -> RequestTimed -> ReqFailure -> m ()
execFailure ActorId
source RequestTimed
req ReqFailure
ProjectFinderKeeper
     | CStore
cstore CStore -> CStore -> Bool
forall a. Eq a => a -> a -> Bool
== CStore
CEqp Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
calmE -> ActorId -> RequestTimed -> ReqFailure -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId -> RequestTimed -> ReqFailure -> m ()
execFailure ActorId
source RequestTimed
req ReqFailure
ItemNotCalm
     | Bool
otherwise -> do
         Maybe ReqFailure
mfail <-
           ActorId
-> ActorId
-> Point
-> Point
-> Int
-> Bool
-> ItemId
-> CStore
-> Bool
-> m (Maybe ReqFailure)
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId
-> ActorId
-> Point
-> Point
-> Int
-> Bool
-> ItemId
-> CStore
-> Bool
-> m (Maybe ReqFailure)
projectFail ActorId
source ActorId
source (Actor -> Point
bpos Actor
b) Point
tpxy Int
eps Bool
False ItemId
iid CStore
cstore Bool
False
         m () -> (ReqFailure -> m ()) -> Maybe ReqFailure -> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (ActorId -> RequestTimed -> ReqFailure -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId -> RequestTimed -> ReqFailure -> m ()
execFailure ActorId
source RequestTimed
req) Maybe ReqFailure
mfail

-- * ReqApply

reqApply :: MonadServerAtomic m
         => ActorId  -- ^ actor applying the item (is on current level)
         -> ItemId   -- ^ the item to be applied
         -> CStore   -- ^ the location of the item
         -> m ()
reqApply :: ActorId -> ItemId -> CStore -> m ()
reqApply ActorId
aid ItemId
iid CStore
cstore = do
  COps{RuleContent
corule :: RuleContent
corule :: COps -> RuleContent
corule} <- (State -> COps) -> m COps
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  let req :: RequestTimed
req = ItemId -> CStore -> RequestTimed
ReqApply ItemId
iid CStore
cstore
  Actor
b <- (State -> Actor) -> m Actor
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
aid
  Skills
actorMaxSk <- (State -> Skills) -> m Skills
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Skills) -> m Skills) -> (State -> Skills) -> m Skills
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Skills
getActorMaxSkills ActorId
aid
  let calmE :: Bool
calmE = Actor -> Skills -> Bool
calmEnough Actor
b Skills
actorMaxSk
  if CStore
cstore CStore -> CStore -> Bool
forall a. Eq a => a -> a -> Bool
== CStore
CEqp Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
calmE then ActorId -> RequestTimed -> ReqFailure -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId -> RequestTimed -> ReqFailure -> m ()
execFailure ActorId
aid RequestTimed
req ReqFailure
ItemNotCalm
  else do
    EnumMap ItemId ItemQuant
bag <- (State -> EnumMap ItemId ItemQuant) -> m (EnumMap ItemId ItemQuant)
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> EnumMap ItemId ItemQuant)
 -> m (EnumMap ItemId ItemQuant))
-> (State -> EnumMap ItemId ItemQuant)
-> m (EnumMap ItemId ItemQuant)
forall a b. (a -> b) -> a -> b
$ Actor -> CStore -> State -> EnumMap ItemId ItemQuant
getBodyStoreBag Actor
b CStore
cstore
    case ItemId -> EnumMap ItemId ItemQuant -> Maybe ItemQuant
forall k a. Enum k => k -> EnumMap k a -> Maybe a
EM.lookup ItemId
iid EnumMap ItemId ItemQuant
bag of
      Maybe ItemQuant
Nothing -> ActorId -> RequestTimed -> ReqFailure -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId -> RequestTimed -> ReqFailure -> m ()
execFailure ActorId
aid RequestTimed
req ReqFailure
ApplyOutOfReach
      Just ItemQuant
kit -> do
        ItemFull
itemFull <- (State -> ItemFull) -> m ItemFull
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> ItemFull) -> m ItemFull)
-> (State -> ItemFull) -> m ItemFull
forall a b. (a -> b) -> a -> b
$ ItemId -> State -> ItemFull
itemToFull ItemId
iid
        Skills
actorSk <- ActorId -> m Skills
forall (m :: * -> *). MonadServer m => ActorId -> m Skills
currentSkillsServer ActorId
aid
        Time
localTime <- (State -> Time) -> m Time
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Time) -> m Time) -> (State -> Time) -> m Time
forall a b. (a -> b) -> a -> b
$ LevelId -> State -> Time
getLocalTime (Actor -> LevelId
blid Actor
b)
        let skill :: Int
skill = Skill -> Skills -> Int
Ability.getSk Skill
Ability.SkApply Skills
actorSk
            legal :: Either ReqFailure Bool
legal = RuleContent
-> Time
-> Int
-> Bool
-> Maybe CStore
-> ItemFull
-> ItemQuant
-> Either ReqFailure Bool
permittedApply RuleContent
corule Time
localTime Int
skill Bool
calmE (CStore -> Maybe CStore
forall a. a -> Maybe a
Just CStore
cstore)
                                   ItemFull
itemFull ItemQuant
kit
        case Either ReqFailure Bool
legal of
          Left ReqFailure
reqFail -> ActorId -> RequestTimed -> ReqFailure -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId -> RequestTimed -> ReqFailure -> m ()
execFailure ActorId
aid RequestTimed
req ReqFailure
reqFail
          Right Bool
_ -> ActorId -> ItemId -> CStore -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId -> ItemId -> CStore -> m ()
applyItem ActorId
aid ItemId
iid CStore
cstore

-- * ReqGameRestart

reqGameRestart :: MonadServerAtomic m
               => ActorId -> GroupName ModeKind -> Challenge
               -> m ()
reqGameRestart :: ActorId -> GroupName ModeKind -> Challenge -> m ()
reqGameRestart ActorId
aid GroupName ModeKind
groupName Challenge
scurChalSer = do
  Bool
noConfirmsGame <- m Bool
forall (m :: * -> *). MonadStateRead m => m Bool
isNoConfirmsGame
  FactionDict
factionD <- (State -> FactionDict) -> m FactionDict
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> FactionDict
sfactionD
  let fidsUI :: [FactionId]
fidsUI = ((FactionId, Faction) -> FactionId)
-> [(FactionId, Faction)] -> [FactionId]
forall a b. (a -> b) -> [a] -> [b]
map (FactionId, Faction) -> FactionId
forall a b. (a, b) -> a
fst ([(FactionId, Faction)] -> [FactionId])
-> [(FactionId, Faction)] -> [FactionId]
forall a b. (a -> b) -> a -> b
$ ((FactionId, Faction) -> Bool)
-> [(FactionId, Faction)] -> [(FactionId, Faction)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(FactionId
_, Faction
fact) -> FactionKind -> Bool
fhasUI (Faction -> FactionKind
gkind Faction
fact))
                                (FactionDict -> [(FactionId, Faction)]
forall k a. Enum k => EnumMap k a -> [(k, a)]
EM.assocs FactionDict
factionD)
  -- This call to `revealItems` and `revealPerception` is really needed,
  -- because the other happens only at natural game conclusion,
  -- not at forced quitting.
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
noConfirmsGame (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    (FactionId -> m ()) -> [FactionId] -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m ()) -> t a -> m ()
mapM_ FactionId -> m ()
forall (m :: * -> *). MonadServerAtomic m => FactionId -> m ()
revealAll [FactionId]
fidsUI
  -- Announcing end of game, we send lore, because game is over.
  Actor
b <- (State -> Actor) -> m Actor
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
aid
  Maybe Status
oldSt <- (State -> Maybe Status) -> m (Maybe Status)
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Maybe Status) -> m (Maybe Status))
-> (State -> Maybe Status) -> m (Maybe Status)
forall a b. (a -> b) -> a -> b
$ Faction -> Maybe Status
gquit (Faction -> Maybe Status)
-> (State -> Faction) -> State -> Maybe Status
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FactionDict -> FactionId -> Faction
forall k a. Enum k => EnumMap k a -> k -> a
EM.! Actor -> FactionId
bfid Actor
b) (FactionDict -> Faction)
-> (State -> FactionDict) -> State -> Faction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> FactionDict
sfactionD
  FactionAnalytics
factionAn <- (StateServer -> FactionAnalytics) -> m FactionAnalytics
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> FactionAnalytics
sfactionAn
  GenerationAnalytics
generationAn <- (StateServer -> GenerationAnalytics) -> m GenerationAnalytics
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> GenerationAnalytics
sgenerationAn
  UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ FactionId
-> Maybe Status
-> Maybe Status
-> Maybe (FactionAnalytics, GenerationAnalytics)
-> UpdAtomic
UpdQuitFaction
                    (Actor -> FactionId
bfid Actor
b)
                    Maybe Status
oldSt
                    (Status -> Maybe Status
forall a. a -> Maybe a
Just (Status -> Maybe Status) -> Status -> Maybe Status
forall a b. (a -> b) -> a -> b
$ Outcome -> Int -> Maybe (GroupName ModeKind) -> Status
Status Outcome
Restart (LevelId -> Int
forall a. Enum a => a -> Int
fromEnum (LevelId -> Int) -> LevelId -> Int
forall a b. (a -> b) -> a -> b
$ Actor -> LevelId
blid Actor
b) (GroupName ModeKind -> Maybe (GroupName ModeKind)
forall a. a -> Maybe a
Just GroupName ModeKind
groupName))
                    ((FactionAnalytics, GenerationAnalytics)
-> Maybe (FactionAnalytics, GenerationAnalytics)
forall a. a -> Maybe a
Just (FactionAnalytics
factionAn, GenerationAnalytics
generationAn))
  -- We don't save game and don't wait for clips end. ASAP.
  (StateServer -> StateServer) -> m ()
forall (m :: * -> *).
MonadServer m =>
(StateServer -> StateServer) -> m ()
modifyServer ((StateServer -> StateServer) -> m ())
-> (StateServer -> StateServer) -> m ()
forall a b. (a -> b) -> a -> b
$ \StateServer
ser -> StateServer
ser { sbreakASAP :: Bool
sbreakASAP = Bool
True
                             , soptionsNxt :: ServerOptions
soptionsNxt = (StateServer -> ServerOptions
soptionsNxt StateServer
ser) {Challenge
scurChalSer :: Challenge
scurChalSer :: Challenge
scurChalSer} }

-- * ReqGameDropAndExit

-- After we break out of the game loop, we will notice from @Camping@
-- we shouldn exit the game.
reqGameDropAndExit :: MonadServerAtomic m => ActorId -> m ()
reqGameDropAndExit :: ActorId -> m ()
reqGameDropAndExit ActorId
aid = do
  m ()
forall (m :: * -> *). MonadServer m => m ()
verifyAssertExplored
  Actor
b <- (State -> Actor) -> m Actor
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
aid
  Maybe Status
oldSt <- (State -> Maybe Status) -> m (Maybe Status)
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Maybe Status) -> m (Maybe Status))
-> (State -> Maybe Status) -> m (Maybe Status)
forall a b. (a -> b) -> a -> b
$ Faction -> Maybe Status
gquit (Faction -> Maybe Status)
-> (State -> Faction) -> State -> Maybe Status
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FactionDict -> FactionId -> Faction
forall k a. Enum k => EnumMap k a -> k -> a
EM.! Actor -> FactionId
bfid Actor
b) (FactionDict -> Faction)
-> (State -> FactionDict) -> State -> Faction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> FactionDict
sfactionD
  UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ FactionId
-> Maybe Status
-> Maybe Status
-> Maybe (FactionAnalytics, GenerationAnalytics)
-> UpdAtomic
UpdQuitFaction
                    (Actor -> FactionId
bfid Actor
b)
                    Maybe Status
oldSt
                    (Status -> Maybe Status
forall a. a -> Maybe a
Just (Status -> Maybe Status) -> Status -> Maybe Status
forall a b. (a -> b) -> a -> b
$ Outcome -> Int -> Maybe (GroupName ModeKind) -> Status
Status Outcome
Camping (LevelId -> Int
forall a. Enum a => a -> Int
fromEnum (LevelId -> Int) -> LevelId -> Int
forall a b. (a -> b) -> a -> b
$ Actor -> LevelId
blid Actor
b) Maybe (GroupName ModeKind)
forall a. Maybe a
Nothing)
                    Maybe (FactionAnalytics, GenerationAnalytics)
forall a. Maybe a
Nothing
  (StateServer -> StateServer) -> m ()
forall (m :: * -> *).
MonadServer m =>
(StateServer -> StateServer) -> m ()
modifyServer ((StateServer -> StateServer) -> m ())
-> (StateServer -> StateServer) -> m ()
forall a b. (a -> b) -> a -> b
$ \StateServer
ser -> StateServer
ser { sbreakASAP :: Bool
sbreakASAP = Bool
True
                             , sbreakLoop :: Bool
sbreakLoop = Bool
True }

verifyAssertExplored :: MonadServer m => m ()
verifyAssertExplored :: m ()
verifyAssertExplored = do
  Maybe Int
assertExplored <- (StateServer -> Maybe Int) -> m (Maybe Int)
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer ((StateServer -> Maybe Int) -> m (Maybe Int))
-> (StateServer -> Maybe Int) -> m (Maybe Int)
forall a b. (a -> b) -> a -> b
$ ServerOptions -> Maybe Int
sassertExplored (ServerOptions -> Maybe Int)
-> (StateServer -> ServerOptions) -> StateServer -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateServer -> ServerOptions
soptions
  case Maybe Int
assertExplored of
    Maybe Int
Nothing -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just Int
lvlN -> do
      -- Exploration (by any party) verfied via spawning; beware of levels
      -- with disabled spawning.
      EnumMap LevelId Int
snumSpawned <- (StateServer -> EnumMap LevelId Int) -> m (EnumMap LevelId Int)
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> EnumMap LevelId Int
snumSpawned
      let !_A :: ()
_A = Bool -> () -> ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Int -> LevelId
forall a. Enum a => Int -> a
toEnum Int
lvlN LevelId -> EnumMap LevelId Int -> Bool
forall k a. Enum k => k -> EnumMap k a -> Bool
`EM.member` EnumMap LevelId Int
snumSpawned
                        Bool -> Bool -> Bool
|| Int -> LevelId
forall a. Enum a => Int -> a
toEnum (- Int
lvlN) LevelId -> EnumMap LevelId Int -> Bool
forall k a. Enum k => k -> EnumMap k a -> Bool
`EM.member` EnumMap LevelId Int
snumSpawned
                        Bool -> (String, Int) -> Bool
forall a. Show a => Bool -> a -> Bool
`blame` String
"by game end, exploration haven't reached the expected level depth, indicating stuck AI (or just very busy initial levels)"
                        String -> Int -> (String, Int)
forall v. String -> v -> (String, v)
`swith` Int
lvlN) ()
      () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- * ReqGameSaveAndExit

-- After we break out of the game loop, we will notice from @Camping@
-- we shouldn exit the game.
reqGameSaveAndExit :: MonadServerAtomic m => ActorId -> m ()
reqGameSaveAndExit :: ActorId -> m ()
reqGameSaveAndExit ActorId
aid = do
  m ()
forall (m :: * -> *). MonadServer m => m ()
verifyAssertExplored
  Actor
b <- (State -> Actor) -> m Actor
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
aid
  Maybe Status
oldSt <- (State -> Maybe Status) -> m (Maybe Status)
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Maybe Status) -> m (Maybe Status))
-> (State -> Maybe Status) -> m (Maybe Status)
forall a b. (a -> b) -> a -> b
$ Faction -> Maybe Status
gquit (Faction -> Maybe Status)
-> (State -> Faction) -> State -> Maybe Status
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FactionDict -> FactionId -> Faction
forall k a. Enum k => EnumMap k a -> k -> a
EM.! Actor -> FactionId
bfid Actor
b) (FactionDict -> Faction)
-> (State -> FactionDict) -> State -> Faction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> FactionDict
sfactionD
  UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ FactionId
-> Maybe Status
-> Maybe Status
-> Maybe (FactionAnalytics, GenerationAnalytics)
-> UpdAtomic
UpdQuitFaction
                    (Actor -> FactionId
bfid Actor
b)
                    Maybe Status
oldSt
                    (Status -> Maybe Status
forall a. a -> Maybe a
Just (Status -> Maybe Status) -> Status -> Maybe Status
forall a b. (a -> b) -> a -> b
$ Outcome -> Int -> Maybe (GroupName ModeKind) -> Status
Status Outcome
Camping (LevelId -> Int
forall a. Enum a => a -> Int
fromEnum (LevelId -> Int) -> LevelId -> Int
forall a b. (a -> b) -> a -> b
$ Actor -> LevelId
blid Actor
b) Maybe (GroupName ModeKind)
forall a. Maybe a
Nothing)
                    Maybe (FactionAnalytics, GenerationAnalytics)
forall a. Maybe a
Nothing
  (StateServer -> StateServer) -> m ()
forall (m :: * -> *).
MonadServer m =>
(StateServer -> StateServer) -> m ()
modifyServer ((StateServer -> StateServer) -> m ())
-> (StateServer -> StateServer) -> m ()
forall a b. (a -> b) -> a -> b
$ \StateServer
ser -> StateServer
ser { sbreakASAP :: Bool
sbreakASAP = Bool
True
                             , swriteSave :: Bool
swriteSave = Bool
True }

-- * ReqGameSave

-- After we break out of the game loop, we will notice we shouldn't quit
-- the game and we will enter the game loop again.
reqGameSave :: MonadServer m => m ()
reqGameSave :: m ()
reqGameSave =
  (StateServer -> StateServer) -> m ()
forall (m :: * -> *).
MonadServer m =>
(StateServer -> StateServer) -> m ()
modifyServer ((StateServer -> StateServer) -> m ())
-> (StateServer -> StateServer) -> m ()
forall a b. (a -> b) -> a -> b
$ \StateServer
ser -> StateServer
ser { sbreakASAP :: Bool
sbreakASAP = Bool
True
                             , swriteSave :: Bool
swriteSave = Bool
True }

-- * ReqDoctrine

reqDoctrine :: MonadServerAtomic m => FactionId -> Ability.Doctrine -> m ()
reqDoctrine :: FactionId -> Doctrine -> m ()
reqDoctrine FactionId
fid Doctrine
toT = do
  Doctrine
fromT <- (State -> Doctrine) -> m Doctrine
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Doctrine) -> m Doctrine)
-> (State -> Doctrine) -> m Doctrine
forall a b. (a -> b) -> a -> b
$ Faction -> Doctrine
gdoctrine (Faction -> Doctrine) -> (State -> Faction) -> State -> Doctrine
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FactionDict -> FactionId -> Faction
forall k a. Enum k => EnumMap k a -> k -> a
EM.! FactionId
fid) (FactionDict -> Faction)
-> (State -> FactionDict) -> State -> Faction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> FactionDict
sfactionD
  UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ FactionId -> Doctrine -> Doctrine -> UpdAtomic
UpdDoctrineFaction FactionId
fid Doctrine
toT Doctrine
fromT

-- * ReqAutomate

reqAutomate :: MonadServerAtomic m => FactionId -> m ()
reqAutomate :: FactionId -> m ()
reqAutomate FactionId
fid = UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ FactionId -> Bool -> UpdAtomic
UpdAutoFaction FactionId
fid Bool
True