module Game.LambdaHack.Client.Action
(
MonadClient( getClient, getsClient, putClient, modifyClient, saveClient )
, MonadClientUI
, MonadClientReadServer(..), MonadClientWriteServer(..)
, SessionUI(..), ConnFrontend(..), connFrontend
, mkConfigUI
, askBinding, getPerFid
, msgAdd, msgReset, recordHistory
, getKeyOverlayCommand, getInitConfirms, stopPlayBack, stopRunning
, displayFrames, displayMore, displayYesNo, displayChoiceUI
, promptToSlideshow, overlayToSlideshow, overlayToBlankSlideshow
, drawOverlay, animate
, restoreGame, removeServerSave, displayPush, scoreToSlideshow
, rndToAction, getArenaUI, getLeaderUI, targetDescLeader, viewedLevel
, aidTgtToPos, aidTgtAims, leaderTgtToPos, leaderTgtAims, cursorToPos
, partAidLeader, partActorLeader, unexploredDepth
, getCacheBfsAndPath, getCacheBfs, accessCacheBfs, actorAimsPos
, closestUnknown, closestSmell, furthestKnown, closestTriggers
, closestItems, closestFoes, actorAbilities
, debugPrint
) where
import Control.Arrow ((&&&))
import Control.Concurrent
import Control.Concurrent.STM
import Control.DeepSeq
import Control.Exception.Assert.Sugar
import Control.Monad
import qualified Control.Monad.State as St
import qualified Data.EnumMap.Strict as EM
import qualified Data.EnumSet as ES
import qualified Data.Ini as Ini
import qualified Data.Ini.Reader as Ini
import qualified Data.Ini.Types as Ini
import Data.List
import qualified Data.Map.Strict as M
import Data.Maybe
import Data.Monoid
import Data.Ord
import Data.Text (Text)
import qualified Data.Text as T
import qualified NLP.Miniutter.English as MU
import System.Directory
import System.FilePath
import System.Time
import Text.Read
import Game.LambdaHack.Client.Action.ActionClass
import Game.LambdaHack.Client.Binding
import Game.LambdaHack.Client.Config
import Game.LambdaHack.Client.Draw
import Game.LambdaHack.Client.State
import Game.LambdaHack.Common.Ability (Ability)
import Game.LambdaHack.Common.Action
import Game.LambdaHack.Common.Actor
import Game.LambdaHack.Common.ActorState
import Game.LambdaHack.Common.Animation
import qualified Game.LambdaHack.Common.Effect as Effect
import Game.LambdaHack.Common.Faction
import qualified Game.LambdaHack.Common.HighScore as HighScore
import Game.LambdaHack.Common.HumanCmd
import qualified Game.LambdaHack.Common.Key as K
import qualified Game.LambdaHack.Common.Kind as Kind
import Game.LambdaHack.Common.Level
import Game.LambdaHack.Common.Msg
import Game.LambdaHack.Common.Perception
import Game.LambdaHack.Common.Point
import qualified Game.LambdaHack.Common.PointArray as PointArray
import Game.LambdaHack.Common.Random
import qualified Game.LambdaHack.Common.Save as Save
import Game.LambdaHack.Common.State
import qualified Game.LambdaHack.Common.Tile as Tile
import Game.LambdaHack.Common.Time
import Game.LambdaHack.Common.Vector
import Game.LambdaHack.Content.ActorKind
import Game.LambdaHack.Content.FactionKind
import Game.LambdaHack.Content.ModeKind
import Game.LambdaHack.Content.RuleKind
import Game.LambdaHack.Content.TileKind
import qualified Game.LambdaHack.Frontend as Frontend
import Game.LambdaHack.Utils.File
debugPrint :: MonadClient m => Text -> m ()
debugPrint t = do
sdbgMsgCli <- getsClient $ sdbgMsgCli . sdebugCli
when sdbgMsgCli $ liftIO $ Save.delayPrint t
connFrontend :: FactionId -> Frontend.ChanFrontend -> ConnFrontend
connFrontend fid fromF = ConnFrontend
{ readConnFrontend =
liftIO $ atomically $ readTQueue fromF
, writeConnFrontend = \efr -> do
let toF = Frontend.toMulti Frontend.connMulti
liftIO $ atomically $ writeTQueue toF (fid, efr)
}
displayFrame :: MonadClientUI m => Bool -> Maybe SingleFrame -> m ()
displayFrame isRunning mf = do
ConnFrontend{writeConnFrontend} <- getsSession sfconn
let frame = case mf of
Nothing -> AcDelay
Just fr | isRunning -> AcRunning fr
Just fr -> AcNormal fr
writeConnFrontend $ Frontend.FrontFrame frame
promptGetKey :: MonadClientUI m => [K.KM] -> SingleFrame -> m K.KM
promptGetKey frontKM frontFr = do
lastPlayOld <- getsClient slastPlay
km <- case lastPlayOld of
km : kms | null frontKM || km `elem` frontKM -> do
displayFrame False $ Just frontFr
modifyClient $ \cli -> cli {slastPlay = kms}
return km
_ -> do
unless (null lastPlayOld) stopPlayBack
ConnFrontend{..} <- getsSession sfconn
writeConnFrontend Frontend.FrontKey {..}
readConnFrontend
(seqCurrent, seqPrevious, k) <- getsClient slastRecord
let slastRecord = (km : seqCurrent, seqPrevious, k)
modifyClient $ \cli -> cli {slastRecord}
return km
stopPlayBack :: MonadClientUI m => m ()
stopPlayBack = do
modifyClient $ \cli -> cli
{ slastPlay = []
, slastRecord = let (seqCurrent, seqPrevious, _) = slastRecord cli
in (seqCurrent, seqPrevious, 0)
, swaitTimes = swaitTimes cli
}
stopRunning
stopRunning :: MonadClientUI m => m ()
stopRunning = do
srunning <- getsClient srunning
case srunning of
Nothing -> return ()
Just RunParams{runLeader} -> do
side <- getsClient sside
fact <- getsState $ (EM.! side) . sfactionD
arena <- getArenaUI
s <- getState
when (memActor runLeader arena s && not (isSpawnFact fact)) $
modifyClient $ updateLeader runLeader s
modifyClient (\cli -> cli { srunning = Nothing })
getInitConfirms :: MonadClientUI m
=> ColorMode -> [K.KM] -> Slideshow -> m Bool
getInitConfirms dm frontClear slides = do
ConnFrontend{..} <- getsSession sfconn
let (onBlank, ovs) = slideshow slides
frontSlides <- mapM (drawOverlay onBlank dm) ovs
case frontSlides of
[] -> return True
[x] -> do
displayFrame False $ Just x
return True
_ -> do
writeConnFrontend Frontend.FrontSlides{..}
km <- readConnFrontend
return $! km /= K.escKey
askBinding :: MonadClientUI m => m Binding
askBinding = getsSession sbinding
msgAdd :: MonadClientUI m => Msg -> m ()
msgAdd msg = modifyClient $ \d -> d {sreport = addMsg (sreport d) msg}
msgReset :: MonadClient m => Msg -> m ()
msgReset msg = modifyClient $ \d -> d {sreport = singletonReport msg}
recordHistory :: MonadClient m => m ()
recordHistory = do
StateClient{sreport, shistory} <- getClient
unless (nullReport sreport) $ do
ConfigUI{configHistoryMax} <- getsClient sconfigUI
msgReset ""
let nhistory = takeHistory configHistoryMax $! addReport sreport shistory
modifyClient $ \cli -> cli {shistory = nhistory}
getPerFid :: MonadClient m => LevelId -> m Perception
getPerFid lid = do
fper <- getsClient sfper
return $! fromMaybe (assert `failure` "no perception at given level"
`twith` (lid, fper))
$ EM.lookup lid fper
getKeyOverlayCommand :: MonadClientUI m => Bool -> Overlay -> m K.KM
getKeyOverlayCommand onBlank overlay = do
frame <- drawOverlay onBlank ColorFull overlay
liftIO $ threadDelay 1000
promptGetKey [] frame
displayFrames :: MonadClientUI m => Frames -> m ()
displayFrames = mapM_ (displayFrame False)
getYesNo :: MonadClientUI m => SingleFrame -> m Bool
getYesNo frame = do
let keys = [ K.KM {key=K.Char 'y', modifier=K.NoModifier}
, K.KM {key=K.Char 'n', modifier=K.NoModifier}
, K.escKey
]
K.KM {key} <- promptGetKey keys frame
case key of
K.Char 'y' -> return True
_ -> return False
displayMore :: MonadClientUI m => ColorMode -> Msg -> m Bool
displayMore dm prompt = do
slides <- promptToSlideshow $ prompt <+> moreMsg
getInitConfirms dm [] $ slides <> toSlideshow False [[]]
displayYesNo :: MonadClientUI m => ColorMode -> Msg -> m Bool
displayYesNo dm prompt = do
sli <- promptToSlideshow $ prompt <+> yesnoMsg
frame <- drawOverlay False dm $ head . snd $ slideshow sli
getYesNo frame
displayChoiceUI :: MonadClientUI m
=> Msg -> Overlay -> [K.KM] -> m (Either Slideshow K.KM)
displayChoiceUI prompt ov keys = do
(_, ovs) <- fmap slideshow $ overlayToSlideshow (prompt <> ", ESC]") ov
let legalKeys =
[ K.KM {key=K.Space, modifier=K.NoModifier}
, K.escKey ]
++ keys
loop [] = fmap Left $ promptToSlideshow "never mind"
loop (x : xs) = do
frame <- drawOverlay False ColorFull x
km@K.KM {..} <- promptGetKey legalKeys frame
case key of
K.Esc -> fmap Left $ promptToSlideshow "never mind"
K.Space -> loop xs
_ -> return $ Right km
loop ovs
promptToSlideshow :: MonadClientUI m => Msg -> m Slideshow
promptToSlideshow prompt = overlayToSlideshow prompt emptyOverlay
overlayToSlideshow :: MonadClientUI m => Msg -> Overlay -> m Slideshow
overlayToSlideshow prompt overlay = do
lid <- getArenaUI
Level{lxsize, lysize} <- getLevel lid
sreport <- getsClient sreport
let msg = splitReport lxsize (addMsg sreport prompt)
return $! splitOverlay False (lysize + 1) msg overlay
overlayToBlankSlideshow :: MonadClientUI m => Msg -> Overlay -> m Slideshow
overlayToBlankSlideshow prompt overlay = do
lid <- getArenaUI
Level{lysize} <- getLevel lid
return $! splitOverlay True (lysize + 3) (toOverlay [prompt]) overlay
drawOverlay :: MonadClientUI m => Bool -> ColorMode -> Overlay -> m SingleFrame
drawOverlay onBlank dm over = do
cops <- getsState scops
lid <- viewedLevel
mleader <- getsClient _sleader
s <- getState
cli <- getClient
per <- getPerFid lid
tgtPos <- leaderTgtToPos
cursorPos <- cursorToPos
let pathFromLeader leader =
maybe (return Nothing) (fmap Just . getCacheBfsAndPath leader) tgtPos
bfsmpath <- maybe (return Nothing) pathFromLeader mleader
tgtDesc <- maybe (return "------") targetDescLeader mleader
cursorDesc <- targetDescCursor
return $! draw onBlank dm cops per lid mleader cursorPos tgtPos
bfsmpath cli s cursorDesc tgtDesc over
displayPush :: MonadClientUI m => m ()
displayPush = do
sls <- promptToSlideshow ""
let slide = head . snd $ slideshow sls
frame <- drawOverlay False ColorFull slide
srunning <- getsClient srunning
displayFrame (isJust srunning) $ Just frame
scoreToSlideshow :: MonadClientUI m => Int -> Status -> m Slideshow
scoreToSlideshow total status = do
fid <- getsClient sside
fact <- getsState $ (EM.! fid) . sfactionD
table <- getsState shigh
time <- getsState stime
date <- liftIO getClockTime
scurDifficulty <- getsClient scurDifficulty
let showScore (ntable, pos) = HighScore.highSlideshow ntable pos status
diff | not $ playerUI $ gplayer fact = 0
| otherwise = scurDifficulty
return $! maybe mempty showScore
$ HighScore.register table total time status date diff
restoreGame :: MonadClient m => m (Maybe (State, StateClient))
restoreGame = do
Kind.COps{corule} <- getsState scops
let stdRuleset = Kind.stdRuleset corule
pathsDataFile = rpathsDataFile stdRuleset
cfgUIName = rcfgUIName stdRuleset
side <- getsClient sside
isAI <- getsClient sisAI
prefix <- getsClient $ ssavePrefixCli . sdebugCli
let copies = [( "GameDefinition" </> cfgUIName <.> "default"
, cfgUIName <.> "ini" )]
name = fromMaybe "save" prefix <.> saveName side isAI
liftIO $ Save.restoreGame name copies pathsDataFile
removeServerSave :: MonadClient m => m ()
removeServerSave = do
prefix <- getsClient $ ssavePrefixCli . sdebugCli
dataDir <- liftIO appDataDir
let serverSaveFile = dataDir
</> fromMaybe "save" prefix
<.> serverSaveName
bSer <- liftIO $ doesFileExist serverSaveFile
when bSer $ liftIO $ renameFile serverSaveFile (serverSaveFile <.> "bkp")
rndToAction :: MonadClient m => Rnd a -> m a
rndToAction r = do
g <- getsClient srandom
let (a, ng) = St.runState r g
modifyClient $ \cli -> cli {srandom = ng}
return a
animate :: MonadClientUI m => LevelId -> Animation -> m Frames
animate arena anim = do
cops <- getsState scops
sreport <- getsClient sreport
mleader <- getsClient _sleader
Level{lxsize, lysize} <- getLevel arena
cli <- getClient
s <- getState
per <- getPerFid arena
tgtPos <- leaderTgtToPos
cursorPos <- cursorToPos
let pathFromLeader leader =
maybe (return Nothing) (fmap Just . getCacheBfsAndPath leader) tgtPos
bfsmpath <- maybe (return Nothing) pathFromLeader mleader
tgtDesc <- maybe (return "------") targetDescLeader mleader
cursorDesc <- targetDescCursor
let over = renderReport sreport
topLineOnly = truncateToOverlay lxsize over
basicFrame =
draw False ColorFull cops per arena mleader
cursorPos tgtPos bfsmpath cli s cursorDesc tgtDesc topLineOnly
snoAnim <- getsClient $ snoAnim . sdebugCli
return $! if fromMaybe False snoAnim
then [Just basicFrame]
else renderAnim lxsize lysize basicFrame anim
partActorLeader :: MonadClient m => ActorId -> Actor -> m MU.Part
partActorLeader aid b = do
mleader <- getsClient _sleader
return $! case mleader of
Just leader | aid == leader -> "you"
_ -> partActor b
partAidLeader :: MonadClient m => ActorId -> m MU.Part
partAidLeader aid = do
b <- getsState $ getActorBody aid
partActorLeader aid b
parseConfigUI :: Ini.Config -> ConfigUI
parseConfigUI cfg =
let configCommands =
let mkCommand (ident, keydef) =
case stripPrefix "Macro_" ident of
Just _ ->
let (key, def) = read keydef
in (K.mkKM key, def :: (CmdCategory, HumanCmd))
Nothing -> assert `failure` "wrong macro id" `twith` ident
section = Ini.allItems "extra_commands" cfg
in map mkCommand section
configHeroNames =
let toNumber (ident, name) =
case stripPrefix "HeroName_" ident of
Just n -> (read n, T.pack name)
Nothing -> assert `failure` "wrong hero name id" `twith` ident
section = Ini.allItems "hero_names" cfg
in map toNumber section
getOption :: forall a. Read a => String -> a
getOption optionName =
let lookupFail :: forall b. String -> b
lookupFail err =
assert `failure` ("config file access failed:" <+> T.pack err)
`twith` (optionName, cfg)
s = fromMaybe (lookupFail "") $ Ini.getOption "ui" optionName cfg
in either lookupFail id $ readEither s
configFont = getOption "font"
configHistoryMax = getOption "historyMax"
configMaxFps = getOption "maxFps"
configNoAnim = getOption "noAnim"
configRunStopMsgs = getOption "runStopMsgs"
in ConfigUI{..}
mkConfigUI :: Kind.Ops RuleKind -> IO ConfigUI
mkConfigUI corule = do
let stdRuleset = Kind.stdRuleset corule
cfgUIName = rcfgUIName stdRuleset
commentsUIDefault = init $ map (drop 2) $ lines $ rcfgUIDefault stdRuleset
sUIDefault = unlines commentsUIDefault
cfgUIDefault = either (assert `failure`) id $ Ini.parse sUIDefault
dataDir <- appDataDir
let userPath = dataDir </> cfgUIName <.> "ini"
cfgUser <- do
cpExists <- doesFileExist userPath
if not cpExists
then return Ini.emptyConfig
else do
sUser <- readFile userPath
return $! either (assert `failure`) id $ Ini.parse sUser
let cfgUI = M.unionWith M.union cfgUser cfgUIDefault
conf = parseConfigUI cfgUI
return $! deepseq conf conf
getCacheBfsAndPath :: forall m. MonadClient m
=> ActorId -> Point
-> m (PointArray.Array BfsDistance, Maybe [Point])
getCacheBfsAndPath aid target = do
seps <- getsClient seps
let pathAndStore :: PointArray.Array BfsDistance
-> m (PointArray.Array BfsDistance, Maybe [Point])
pathAndStore bfs = do
computePath <- computePathBFS aid
let mpath = computePath target seps bfs
modifyClient $ \cli ->
cli {sbfsD = EM.insert aid (bfs, target, seps, mpath) (sbfsD cli)}
return (bfs, mpath)
mbfs <- getsClient $ EM.lookup aid . sbfsD
case mbfs of
Just (bfs, targetOld, sepsOld, mpath) | targetOld == target
&& sepsOld == seps ->
return (bfs, mpath)
Just (bfs, _, _, _) -> pathAndStore bfs
Nothing -> do
bfs <- computeBFS aid
pathAndStore bfs
getCacheBfs :: MonadClient m => ActorId -> m (PointArray.Array BfsDistance)
getCacheBfs aid = do
mbfs <- getsClient $ EM.lookup aid . sbfsD
case mbfs of
Just (bfs, _, _, _) -> return bfs
Nothing -> fmap fst $ getCacheBfsAndPath aid (Point 0 0)
computeBFS :: MonadClient m => ActorId -> m (PointArray.Array BfsDistance)
computeBFS = computeAnythingBFS $ \isEnterable passUnknown aid -> do
b <- getsState $ getActorBody aid
Level{lxsize, lysize} <- getLevel $ blid b
let origin = bpos b
vInitial = PointArray.replicateA lxsize lysize apartBfs
return $ fillBfs isEnterable passUnknown origin vInitial
computePathBFS :: MonadClient m
=> ActorId
-> m (Point -> Int -> PointArray.Array BfsDistance
-> Maybe [Point])
computePathBFS = computeAnythingBFS $ \isEnterable passUnknown aid -> do
b <- getsState $ getActorBody aid
let origin = bpos b
return $ findPathBfs isEnterable passUnknown origin
computeAnythingBFS :: MonadClient m
=> ((Point -> Point -> MoveLegal)
-> (Point -> Point -> Bool)
-> ActorId
-> m a)
-> ActorId
-> m a
computeAnythingBFS fAnything aid = do
cops@Kind.COps{cotile=cotile@Kind.Ops{ouniqGroup}} <- getsState scops
b <- getsState $ getActorBody aid
lvl <- getLevel $ blid b
smarkSuspect <- getsClient smarkSuspect
sisAI <- getsClient sisAI
let
passSuspect = smarkSuspect || sisAI
unknownId = ouniqGroup "unknown space"
chAccess = checkAccess cops lvl
chDoorAccess = checkDoorAccess cops lvl
conditions = catMaybes [chAccess, chDoorAccess]
isEnterable :: Point -> Point -> MoveLegal
isEnterable spos tpos =
let tt = lvl `at` tpos
allOK = all (\f -> f spos tpos) conditions
in if tt == unknownId
then if allOK
then MoveToUnknown
else MoveBlocked
else if Tile.isSuspect cotile tt
then if passSuspect && allOK
then MoveToUnknown
else MoveBlocked
else if Tile.isPassable cotile tt && allOK
then MoveToOpen
else MoveBlocked
passUnknown :: Point -> Point -> Bool
passUnknown = case chAccess of
Nothing -> \_ tpos -> let tt = lvl `at` tpos
in tt == unknownId
|| passSuspect && Tile.isSuspect cotile tt
Just ch -> \spos tpos -> let tt = lvl `at` tpos
in (tt == unknownId
|| passSuspect
&& Tile.isSuspect cotile tt)
&& ch spos tpos
fAnything isEnterable passUnknown aid
accessCacheBfs :: MonadClient m => ActorId -> Point -> m (Maybe Int)
accessCacheBfs aid target = do
bfs <- getCacheBfs aid
return $! accessBfs bfs target
actorAimsPos :: MonadClient m => ActorId -> Point -> m Bool
actorAimsPos aid target = do
bfs <- getCacheBfs aid
b <- getsState $ getActorBody aid
return $! posAimsPos bfs (bpos b) target
targetDesc :: MonadClientUI m => Maybe Target -> m Text
targetDesc target = do
lidV <- viewedLevel
mleader <- getsClient _sleader
case target of
Just (TEnemy a _) ->
getsState $ bname . getActorBody a
Just (TEnemyPos _ lid p _) ->
return $! if lid == lidV
then "hot spot" <+> (T.pack . show) p
else "a hot spot on level" <+> tshow (abs $ fromEnum lid)
Just (TPoint lid p) ->
return $! if lid == lidV
then "exact spot" <+> (T.pack . show) p
else "an exact spot on level" <+> tshow (abs $ fromEnum lid)
Just TVector{} ->
case mleader of
Nothing -> return "a relative shift"
Just aid -> do
tgtPos <- aidTgtToPos aid lidV target
let invalidMsg = "an invalid relative shift"
validMsg p = "shift to" <+> (T.pack . show) p
return $! maybe invalidMsg validMsg tgtPos
Nothing -> return "cursor location"
targetDescLeader :: MonadClientUI m => ActorId -> m Text
targetDescLeader leader = do
tgt <- getsClient $ getTarget leader
targetDesc tgt
targetDescCursor :: MonadClientUI m => m Text
targetDescCursor = do
scursor <- getsClient scursor
targetDesc $ Just scursor
getLeaderUI :: MonadClientUI m => m ActorId
getLeaderUI = do
cli <- getClient
case _sleader cli of
Nothing -> assert `failure` "leader expected but not found" `twith` cli
Just leader -> return leader
getArenaUI :: MonadClientUI m => m LevelId
getArenaUI = do
mleader <- getsClient _sleader
case mleader of
Just leader -> getsState $ blid . getActorBody leader
Nothing -> do
side <- getsClient sside
factionD <- getsState sfactionD
let fact = factionD EM.! side
case gquit fact of
Just Status{stDepth} -> return $! toEnum stDepth
Nothing -> do
dungeon <- getsState sdungeon
let (minD, maxD) =
case (EM.minViewWithKey dungeon, EM.maxViewWithKey dungeon) of
(Just ((s, _), _), Just ((e, _), _)) -> (s, e)
_ -> assert `failure` "empty dungeon" `twith` dungeon
return $! max minD $ min maxD $ playerEntry $ gplayer fact
viewedLevel :: MonadClientUI m => m LevelId
viewedLevel = do
arena <- getArenaUI
stgtMode <- getsClient stgtMode
return $! maybe arena tgtLevelId stgtMode
aidTgtToPos :: MonadClient m
=> ActorId -> LevelId -> Maybe Target -> m (Maybe Point)
aidTgtToPos aid lidV tgt =
case tgt of
Just (TEnemy a _) -> do
body <- getsState $ getActorBody a
return $! if blid body == lidV
then Just (bpos body)
else Nothing
Just (TEnemyPos _ lid p _) ->
return $! if lid == lidV then Just p else Nothing
Just (TPoint lid p) ->
return $! if lid == lidV then Just p else Nothing
Just (TVector v) -> do
b <- getsState $ getActorBody aid
Level{lxsize, lysize} <- getLevel lidV
let shifted = shiftBounded lxsize lysize (bpos b) v
return $! if shifted == bpos b && v /= Vector 0 0
then Nothing
else Just shifted
Nothing -> do
scursor <- getsClient scursor
aidTgtToPos aid lidV $ Just scursor
aidTgtAims :: MonadClient m
=> ActorId -> LevelId -> Maybe Target -> m (Maybe Text)
aidTgtAims aid lidV tgt = do
case tgt of
Just (TEnemy a _) -> do
body <- getsState $ getActorBody a
let pos = bpos body
b <- getsState $ getActorBody aid
if blid b == lidV then do
aims <- actorAimsPos aid pos
if aims
then return Nothing
else return $ Just "aiming line to the opponent blocked"
else return $ Just "target opponent not on this level"
Just TEnemyPos{} -> return $ Just "target opponent not visible"
Just TPoint{} -> return Nothing
Just TVector{} -> return Nothing
Nothing -> do
scursor <- getsClient scursor
aidTgtAims aid lidV $ Just scursor
leaderTgtToPos :: MonadClientUI m => m (Maybe Point)
leaderTgtToPos = do
lidV <- viewedLevel
mleader <- getsClient _sleader
case mleader of
Nothing -> return Nothing
Just aid -> do
tgt <- getsClient $ getTarget aid
aidTgtToPos aid lidV tgt
leaderTgtAims :: MonadClientUI m => m (Maybe Text)
leaderTgtAims = do
lidV <- viewedLevel
mleader <- getsClient _sleader
case mleader of
Nothing -> return $ Just "no leader to target with"
Just aid -> do
tgt <- getsClient $ getTarget aid
aidTgtAims aid lidV tgt
cursorToPos :: MonadClientUI m => m (Maybe Point)
cursorToPos = do
lidV <- viewedLevel
mleader <- getsClient _sleader
scursor <- getsClient scursor
case mleader of
Nothing -> return Nothing
Just aid -> aidTgtToPos aid lidV $ Just scursor
furthestKnown :: MonadClient m => ActorId -> m (Maybe Point)
furthestKnown aid = do
bfs <- getCacheBfs aid
getMaxIndex <- rndToAction $ oneOf [ PointArray.maxIndexA
, PointArray.maxLastIndexA ]
let furthestPos = getMaxIndex bfs
dist = bfs PointArray.! furthestPos
return $! if dist <= apartBfs
then assert `failure` (aid, furthestPos, dist)
else if dist == succ apartBfs
then Nothing
else Just furthestPos
closestUnknown :: MonadClient m => ActorId -> m (Maybe Point)
closestUnknown aid = do
bfs <- getCacheBfs aid
getMinIndex <- rndToAction $ oneOf [ PointArray.minIndexA
, PointArray.minLastIndexA ]
let closestPos = getMinIndex bfs
dist = bfs PointArray.! closestPos
if dist >= apartBfs then do
body <- getsState $ getActorBody aid
smarkSuspect <- getsClient smarkSuspect
sisAI <- getsClient sisAI
let passSuspect = smarkSuspect || sisAI
when passSuspect $
modifyClient $ \cli ->
cli {sexplored = ES.insert (blid body) (sexplored cli)}
return Nothing
else return $ Just closestPos
closestSmell :: MonadClient m => ActorId -> m [(Int, (Point, Tile.SmellTime))]
closestSmell aid = do
body <- getsState $ getActorBody aid
Level{lsmell} <- getLevel $ blid body
let smells = EM.assocs lsmell
case smells of
[] -> return []
_ -> do
bfs <- getCacheBfs aid
let ts = mapMaybe (\x@(p, _) -> fmap (,x) (accessBfs bfs p)) smells
ds = filter (\(d, _) -> d /= 0) ts
return $! sortBy (comparing (fst &&& timeNegate . snd . snd)) ds
closestTriggers :: MonadClient m => Maybe Bool -> Bool -> ActorId -> m [Point]
closestTriggers onlyDir exploredToo aid = do
Kind.COps{cotile} <- getsState scops
body <- getsState $ getActorBody aid
lvl <- getLevel $ blid body
dungeon <- getsState sdungeon
explored <- getsClient sexplored
unexploredD <- unexploredDepth
let allExplored = ES.size explored == EM.size dungeon
unexUp = onlyDir /= Just False && unexploredD 1 (blid body)
unexDown = onlyDir /= Just True && unexploredD (1) (blid body)
unexEffect (Effect.Ascend p) = if p > 0 then unexUp else unexDown
unexEffect _ =
allExplored
isTrigger
| exploredToo = \t -> Tile.isWalkable cotile t
&& not (null $ Tile.causeEffects cotile t)
| otherwise = \t -> Tile.isWalkable cotile t
&& any unexEffect (Tile.causeEffects cotile t)
f :: [Point] -> Point -> Kind.Id TileKind -> [Point]
f acc p t = if isTrigger t then p : acc else acc
let triggersAll = PointArray.ifoldlA f [] $ ltile lvl
triggers | length triggersAll > 1 = delete (bpos body) triggersAll
| otherwise = triggersAll
case triggers of
[] -> return []
_ -> do
bfs <- getCacheBfs aid
let ds = mapMaybe (\p -> fmap (,p) (accessBfs bfs p)) triggers
return $! map snd $ sortBy (comparing fst) ds
unexploredDepth :: MonadClient m => m (Int -> LevelId -> Bool)
unexploredDepth = do
dungeon <- getsState sdungeon
explored <- getsClient sexplored
let allExplored = ES.size explored == EM.size dungeon
unexploredD p =
let unex lid = allExplored && lescape (dungeon EM.! lid)
|| ES.notMember lid explored
|| unexploredD p lid
in any unex . ascendInBranch dungeon p
return unexploredD
closestItems :: MonadClient m => ActorId -> m ([(Int, (Point, ItemBag))])
closestItems aid = do
body <- getsState $ getActorBody aid
Level{lfloor} <- getLevel $ blid body
let items = EM.assocs lfloor
case items of
[] -> return []
_ -> do
bfs <- getCacheBfs aid
let ds = mapMaybe (\x@(p, _) -> fmap (,x) (accessBfs bfs p)) items
return $! sortBy (comparing fst) ds
closestFoes :: MonadClient m => ActorId -> m [(Int, (ActorId, Actor))]
closestFoes aid = do
body <- getsState $ getActorBody aid
fact <- getsState $ \s -> sfactionD s EM.! bfid body
foes <- getsState $ actorNotProjAssocs (isAtWar fact) (blid body)
case foes of
[] -> return []
_ -> do
bfs <- getCacheBfs aid
let ds = mapMaybe (\x@(_, b) -> fmap (,x) (accessBfs bfs (bpos b))) foes
return $! sortBy (comparing fst) ds
actorAbilities :: MonadClient m => ActorId -> Maybe ActorId -> m [Ability]
actorAbilities aid mleader = do
Kind.COps{ coactor=Kind.Ops{okind}
, cofaction=Kind.Ops{okind=fokind} } <- getsState scops
body <- getsState $ getActorBody aid
fact <- getsState $ (EM.! bfid body) . sfactionD
let factionAbilities
| Just aid == mleader = fAbilityLeader $ fokind $ gkind fact
| otherwise = fAbilityOther $ fokind $ gkind fact
return $! acanDo (okind $ bkind body) `intersect` factionAbilities