{-# LANGUAGE RankNTypes #-}
module Game.LambdaHack.Client.UI.RunM
( continueRun
#ifdef EXPOSE_INTERNAL
, continueRunDir, walkableDir, tryTurning, checkAndRun
#endif
) where
import Prelude ()
import Game.LambdaHack.Core.Prelude
import qualified Data.EnumMap.Strict as EM
import GHC.Exts (inline)
import Game.LambdaHack.Client.CommonM
import Game.LambdaHack.Client.MonadClient
import Game.LambdaHack.Client.Request
import Game.LambdaHack.Client.State
import Game.LambdaHack.Client.UI.MonadClientUI
import Game.LambdaHack.Client.UI.Msg
import Game.LambdaHack.Client.UI.SessionUI
import Game.LambdaHack.Common.Actor
import Game.LambdaHack.Common.ActorState
import Game.LambdaHack.Common.Faction
import Game.LambdaHack.Common.Kind
import Game.LambdaHack.Common.Level
import Game.LambdaHack.Common.MonadStateRead
import Game.LambdaHack.Common.State
import qualified Game.LambdaHack.Common.Tile as Tile
import Game.LambdaHack.Common.Types
import Game.LambdaHack.Common.Vector
import Game.LambdaHack.Content.TileKind (TileKind)
import Game.LambdaHack.Common.Point
import qualified Game.LambdaHack.Definition.Ability as Ability
import Game.LambdaHack.Definition.Defs
continueRun :: MonadClientUI m
=> LevelId -> RunParams
-> m (Either Text RequestTimed)
continueRun arena paramOld = case paramOld of
RunParams{ runMembers = []
, runStopMsg = Just stopMsg } -> return $ Left stopMsg
RunParams{ runMembers = []
, runStopMsg = Nothing } ->
return $ Left "selected actors no longer there"
RunParams{ runLeader
, runMembers = r : rs
, runInitial
, runStopMsg } -> do
let runInitialNew = runInitial && r /= runLeader
paramIni = paramOld {runInitial = runInitialNew}
onLevel <- getsState $ memActor r arena
onLevelLeader <- getsState $ memActor runLeader arena
if | not onLevel -> do
let paramNew = paramIni {runMembers = rs }
continueRun arena paramNew
| not onLevelLeader -> do
let paramNew = paramIni {runLeader = r}
continueRun arena paramNew
| otherwise -> do
mdirOrRunStopMsgCurrent <- continueRunDir paramOld
let runStopMsgCurrent =
either Just (const Nothing) mdirOrRunStopMsgCurrent
runStopMsgNew = runStopMsg `mplus` runStopMsgCurrent
runMembersNew = if isJust runStopMsgNew then rs else rs ++ [r]
paramNew = paramIni { runMembers = runMembersNew
, runStopMsg = runStopMsgNew }
case mdirOrRunStopMsgCurrent of
Left _ -> continueRun arena paramNew
Right dir -> do
updateClientLeader r
modifySession $ \sess -> sess {srunning = Just paramNew}
return $ Right $ ReqMove dir
continueRunDir :: MonadClientUI m
=> RunParams -> m (Either Text Vector)
continueRunDir params = case params of
RunParams{ runMembers = [] } -> error $ "" `showFailure` params
RunParams{ runLeader
, runMembers = aid : _
, runInitial } -> do
report <- getsSession $ newReport . shistory
let msgInterrupts = anyInReport interruptsRunning report
if msgInterrupts then return $ Left "message shown"
else do
cops@COps{cotile} <- getsState scops
rbody <- getsState $ getActorBody runLeader
let rposHere = bpos rbody
rposLast = fromMaybe (error $ "" `showFailure` (runLeader, rbody))
(boldpos rbody)
dir = rposHere `vectorToFrom` rposLast
body <- getsState $ getActorBody aid
let lid = blid body
lvl <- getLevel lid
let posHere = bpos body
posThere = posHere `shift` dir
bigActorThere = occupiedBigLvl posThere lvl
projsThere = occupiedProjLvl posThere lvl
let openableLast = Tile.isOpenable cotile (lvl `at` (posHere `shift` dir))
check
| bigActorThere = return $ Left "actor in the way"
| projsThere = return $ Left "projectile in the way"
| walkableDir cops lvl posHere dir =
if runInitial && aid /= runLeader
then return $ Right dir
else checkAndRun aid dir
| not (runInitial && aid == runLeader) = return $ Left "blocked"
| openableLast = return $ Left "blocked by a closed door"
| otherwise =
tryTurning aid
check
walkableDir :: COps -> Level -> Point -> Vector -> Bool
walkableDir COps{coTileSpeedup} lvl spos dir =
Tile.isWalkable coTileSpeedup $ lvl `at` (spos `shift` dir)
tryTurning :: MonadClientRead m
=> ActorId -> m (Either Text Vector)
tryTurning aid = do
cops@COps{cotile} <- getsState scops
body <- getsState $ getActorBody aid
let lid = blid body
lvl <- getLevel lid
let posHere = bpos body
posLast = fromMaybe (error $ "" `showFailure` (aid, body)) (boldpos body)
dirLast = posHere `vectorToFrom` posLast
let openableDir dir = Tile.isOpenable cotile (lvl `at` (posHere `shift` dir))
dirWalkable dir = walkableDir cops lvl posHere dir || openableDir dir
dirNearby dir1 dir2 = euclidDistSqVector dir1 dir2 == 1
dirSimilar dir = dirNearby dirLast dir && dirWalkable dir
dirsSimilar = filter dirSimilar moves
case dirsSimilar of
[] -> return $ Left "dead end"
d1 : ds | all (dirNearby d1) ds ->
case sortOn (euclidDistSqVector dirLast)
$ filter (walkableDir cops lvl posHere) $ d1 : ds of
[] ->
return $ Left "blocked and all similar directions are non-walkable"
d : _ -> checkAndRun aid d
_ -> return $ Left "blocked and many distant similar directions found"
checkAndRun :: MonadClientRead m
=> ActorId -> Vector -> m (Either Text Vector)
checkAndRun aid dir = do
COps{coTileSpeedup} <- getsState scops
actorSk <- currentSkillsClient aid
actorMaxSkills <- getsState sactorMaxSkills
body <- getsState $ getActorBody aid
fact <- getsState $ (EM.! bfid body) . sfactionD
smarkSuspect <- getsClient smarkSuspect
let lid = blid body
lvl <- getLevel lid
actorD <- getsState sactorD
let posHere = bpos body
posHasItems pos = EM.member pos $ lfloor lvl
posThere = posHere `shift` dir
bigActorThere = occupiedBigLvl posThere lvl
enemyThreatensThere =
let f !p = case posToBigLvl p lvl of
Nothing -> False
Just aid2 -> g aid2 $ actorD EM.! aid2
g aid2 !b2 = inline isFoe (bfid body) fact (bfid b2)
&& actorCanMelee actorMaxSkills aid2 b2
&& bhp b2 > 0
in any f $ vicinityUnsafe posThere
projsThere = occupiedProjLvl posThere lvl
let posLast = fromMaybe (error $ "" `showFailure` (aid, body)) (boldpos body)
dirLast = posHere `vectorToFrom` posLast
anglePos :: Point -> Vector -> RadianAngle -> Point
anglePos pos d angle = shift pos (rotate angle d)
tileLast = lvl `at` posLast
tileHere = lvl `at` posHere
tileThere = lvl `at` posThere
leftPsLast = map (anglePos posHere dirLast) [pi/2, 3*pi/4]
++ map (anglePos posHere dir) [pi/2, 3*pi/4]
rightPsLast = map (anglePos posHere dirLast) [-pi/2, -3*pi/4]
++ map (anglePos posHere dir) [-pi/2, -3*pi/4]
leftForwardPosHere = anglePos posHere dir (pi/4)
rightForwardPosHere = anglePos posHere dir (-pi/4)
leftTilesLast = map (lvl `at`) leftPsLast
rightTilesLast = map (lvl `at`) rightPsLast
leftForwardTileHere = lvl `at` leftForwardPosHere
rightForwardTileHere = lvl `at` rightForwardPosHere
tilePropAt :: ContentId TileKind -> (Bool, Bool, Bool)
tilePropAt tile =
let suspect =
smarkSuspect > 0 && Tile.isSuspect coTileSpeedup tile
|| smarkSuspect > 1 && Tile.isHideAs coTileSpeedup tile
alterSkill = Ability.getSk Ability.SkAlter actorSk
alterable = alterSkill >= Tile.alterMinSkill coTileSpeedup tile
walkable = Tile.isWalkable coTileSpeedup tile
in (suspect, alterable, walkable)
terrainChangeMiddle = tilePropAt tileThere
`notElem` map tilePropAt [tileLast, tileHere]
terrainChangeLeft = tilePropAt leftForwardTileHere
`notElem` map tilePropAt leftTilesLast
terrainChangeRight = tilePropAt rightForwardTileHere
`notElem` map tilePropAt rightTilesLast
itemChangeLeft = posHasItems leftForwardPosHere
`notElem` map posHasItems leftPsLast
itemChangeRight = posHasItems rightForwardPosHere
`notElem` map posHasItems rightPsLast
check
| bigActorThere = return $ Left "actor in the way"
| enemyThreatensThere = return $ Left "enemy threatens the position"
| projsThere = return $ Left "projectile in the way"
| terrainChangeLeft = return $ Left "terrain change on the left"
| terrainChangeRight = return $ Left "terrain change on the right"
| itemChangeLeft = return $ Left "item change on the left"
| itemChangeRight = return $ Left "item change on the right"
| terrainChangeMiddle = return $ Left "terrain change in the middle"
| otherwise = return $ Right dir
check