{-# LANGUAGE RankNTypes #-}
module Game.LambdaHack.Client.UI.RunM
( continueRun
) where
import Prelude ()
import Game.LambdaHack.Common.Prelude
import qualified Data.EnumMap.Strict as EM
import Data.Function
import Game.LambdaHack.Client.MonadClient
import Game.LambdaHack.Client.State
import Game.LambdaHack.Client.UI.MonadClientUI
import Game.LambdaHack.Client.UI.Msg
import Game.LambdaHack.Client.UI.Overlay
import Game.LambdaHack.Client.UI.SessionUI
import Game.LambdaHack.Common.Actor
import Game.LambdaHack.Common.ActorState
import qualified Game.LambdaHack.Common.Kind as Kind
import Game.LambdaHack.Common.Level
import Game.LambdaHack.Common.MonadStateRead
import Game.LambdaHack.Common.Point
import Game.LambdaHack.Common.Request
import Game.LambdaHack.Common.State
import qualified Game.LambdaHack.Common.Tile as Tile
import Game.LambdaHack.Common.Vector
import qualified Game.LambdaHack.Content.TileKind as TK
continueRun :: MonadClientUI m
=> LevelId -> RunParams
-> m (Either Text RequestAnyAbility)
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
s <- getState
modifyClient $ updateLeader r s
modifySession $ \sess -> sess {srunning = Just paramNew}
return $ Right $ RequestAnyAbility $ 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 _sreport
let boringMsgs = map stringToAL
[ "You hear a distant"
, "reveals that the"
, "Macro will be recorded"
, "Macro activated"
, "Voicing '" ]
boring l = any (`isInfixOf` l) boringMsgs
msgShown = isJust $ findInReport (not . boring) report
if msgShown then return $ Left "message shown"
else do
cops@Kind.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
actorsThere = posToAidsLvl posThere lvl
let openableLast = Tile.isOpenable cotile (lvl `at` (posHere `shift` dir))
check
| not $ null actorsThere = return $ Left "actor in the way"
| enterableDir 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
enterableDir :: Kind.COps -> Level -> Point -> Vector -> Bool
enterableDir Kind.COps{coTileSpeedup} lvl spos dir =
Tile.isWalkable coTileSpeedup $ lvl `at` (spos `shift` dir)
tryTurning :: MonadClient m
=> ActorId -> m (Either Text Vector)
tryTurning aid = do
cops@Kind.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))
dirEnterable dir = enterableDir cops lvl posHere dir || openableDir dir
dirNearby dir1 dir2 = euclidDistSqVector dir1 dir2 `elem` [1, 2]
dirSimilar dir = dirNearby dirLast dir && dirEnterable dir
dirsSimilar = filter dirSimilar moves
case dirsSimilar of
[] -> return $ Left "dead end"
d1 : ds | all (dirNearby d1) ds ->
case sortBy (compare `on` euclidDistSqVector dirLast)
$ filter (enterableDir cops lvl posHere) $ d1 : ds of
[] ->
return $ Left "blocked and all similar directions are closed doors"
d : _ -> checkAndRun aid d
_ -> return $ Left "blocked and many distant similar directions found"
checkAndRun :: MonadClient m
=> ActorId -> Vector -> m (Either Text Vector)
checkAndRun aid dir = do
Kind.COps{cotile=Kind.Ops{okind}} <- getsState scops
body <- getsState $ getActorBody aid
smarkSuspect <- getsClient smarkSuspect
let lid = blid body
lvl <- getLevel lid
let posHere = bpos body
posHasItems pos = EM.member pos $ lfloor lvl
posThere = posHere `shift` dir
actorsThere = posToAidsLvl 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
featAt = TK.actionFeatures (smarkSuspect > 0) . okind
terrainChangeMiddle =
featAt tileThere `notElem` map featAt [tileLast, tileHere]
terrainChangeLeft = featAt leftForwardTileHere
`notElem` map featAt leftTilesLast
terrainChangeRight = featAt rightForwardTileHere
`notElem` map featAt rightTilesLast
itemChangeLeft = posHasItems leftForwardPosHere
`notElem` map posHasItems leftPsLast
itemChangeRight = posHasItems rightForwardPosHere
`notElem` map posHasItems rightPsLast
check
| not $ null actorsThere = return $ Left "actor 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