module Game.LambdaHack.Client.RunAction
( continueRun, moveRunAid
) where
import Control.Exception.Assert.Sugar
import Control.Monad
import qualified Data.ByteString.Char8 as BS
import qualified Data.EnumMap.Strict as EM
import Data.Function
import Data.List
import Data.Maybe
import Game.LambdaHack.Client.Action
import Game.LambdaHack.Client.State
import Game.LambdaHack.Common.Action
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.Msg
import Game.LambdaHack.Common.Point
import Game.LambdaHack.Common.ServerCmd
import Game.LambdaHack.Common.State
import qualified Game.LambdaHack.Common.Tile as Tile
import Game.LambdaHack.Common.Vector
import Game.LambdaHack.Content.TileKind
continueRun :: MonadClient m
=> RunParams -> m (Either Msg (RunParams, CmdTakeTimeSer))
continueRun paramOld =
case paramOld of
RunParams{ runMembers = []
, runStopMsg = Just stopMsg } -> return $ Left stopMsg
RunParams{ runLeader
, runMembers = r : rs
, runDist = 0
, runStopMsg
, runInitDir = Just dir } ->
if r == runLeader then do
let runDistNew = if null rs then 0 else 1
continueRun paramOld{runDist = runDistNew, runInitDir = Nothing}
else do
runOutcome <- continueRunDir r 0 (Just dir)
case runOutcome of
Left "" -> do
runStopOrCmd <- moveRunAid r dir
let runMembersNew = if isJust runStopMsg then rs else rs ++ [r]
paramNew = paramOld {runMembers = runMembersNew}
return $! case runStopOrCmd of
Left stopMsg -> assert `failure` (paramOld, stopMsg)
Right runCmd -> Right (paramNew, runCmd)
Left runStopMsgCurrent -> do
let runStopMsgNew = fromMaybe runStopMsgCurrent runStopMsg
paramNew = paramOld { runMembers = rs
, runStopMsg = Just runStopMsgNew }
continueRun paramNew
_ -> assert `failure` (paramOld, runOutcome)
RunParams{ runLeader
, runMembers = r : rs
, runDist
, runStopMsg
, runInitDir = Nothing } -> do
let runDistNew = if r == runLeader then runDist + 1 else runDist
mdirOrRunStopMsgCurrent <- continueRunDir r runDistNew Nothing
let runStopMsgCurrent =
either Just (const Nothing) mdirOrRunStopMsgCurrent
runStopMsgNew = runStopMsg `mplus` runStopMsgCurrent
runMembersNew = if isJust runStopMsgNew then rs else rs ++ [r]
paramNew = paramOld { runMembers = runMembersNew
, runDist = runDistNew
, runStopMsg = runStopMsgNew }
case mdirOrRunStopMsgCurrent of
Left _ -> continueRun paramNew
Right dir -> return $ Right (paramNew, MoveSer r dir)
_ -> assert `failure` paramOld
moveRunAid :: MonadClient m
=> ActorId -> Vector -> m (Either Msg CmdTakeTimeSer)
moveRunAid source dir = do
cops@Kind.COps{cotile} <- getsState scops
sb <- getsState $ getActorBody source
let lid = blid sb
lvl <- getLevel lid
let spos = bpos sb
tpos = spos `shift` dir
t = lvl `at` tpos
runStopOrCmd =
if accessible cops lvl spos tpos then
Right $ MoveSer source dir
else if not (Tile.isWalkable cotile t)
&& (isSecretPos lvl tpos
&& (Tile.isSuspect cotile t
|| hideTile cotile lvl tpos /= t)
|| Tile.isOpenable cotile t
|| Tile.isClosable cotile t
|| Tile.isChangeable cotile t) then
if not $ EM.null $ lvl `atI` tpos then
Left $ showFailureSer AlterBlockItem
else
Right $ AlterSer source tpos Nothing
else Left "never mind"
return $! runStopOrCmd
continueRunDir :: MonadClient m
=> ActorId -> Int -> Maybe Vector -> m (Either Msg Vector)
continueRunDir aid distLast mdir = do
sreport <- getsClient sreport
let boringMsgs = map BS.pack [ "You hear some noises."
, "reveals that the" ]
boring repLine = any (`BS.isInfixOf` repLine) boringMsgs
msgShown = isJust $ findInReport (not . boring) sreport
if msgShown then return $ Left "message shown"
else do
let maxDistance = 20
cops@Kind.COps{cotile} <- getsState scops
body <- getsState $ getActorBody aid
let lid = blid body
lvl <- getLevel lid
let posHere = bpos body
posLast = boldpos body
dirLast = displacement posLast posHere
dir = fromMaybe dirLast mdir
posThere = posHere `shift` dir
actorsThere <- getsState $ posToActors posThere lid
let openableLast = Tile.isOpenable cotile (lvl `at` (posHere `shift` dir))
check
| not $ null actorsThere = return $ Left "actor in the way"
| distLast >= maxDistance =
return $ Left $ "reached max run distance" <+> tshow maxDistance
| accessibleDir cops lvl posHere dir =
if distLast == 0
then return $ Left ""
else checkAndRun aid dir
| distLast /= 1 = return $ Left "blocked"
| openableLast = return $ Left "blocked by a closed door"
| otherwise =
tryTurning aid
check
tryTurning :: MonadClient m
=> ActorId -> m (Either Msg 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 = boldpos body
dirLast = displacement posLast posHere
let openableDir dir = Tile.isOpenable cotile (lvl `at` (posHere `shift` dir))
dirEnterable dir = accessibleDir 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 (accessibleDir 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 Msg Vector)
checkAndRun aid dir = do
Kind.COps{cotile=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 = not $ EM.null $ lvl `atI` pos
posThere = posHere `shift` dir
actorsThere <- getsState $ posToActors posThere lid
let posLast = boldpos body
dirLast = displacement posLast posHere
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 = actionFeatures smarkSuspect . okind
terrainChangeMiddle = null (Tile.causeEffects cotile tileThere)
&& 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