module Game.LambdaHack.Client.StrategyAction
( targetStrategy, actionStrategy, visibleFoes
) where
import Control.Monad
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.Client.Strategy
import Game.LambdaHack.Common.Ability (Ability)
import qualified Game.LambdaHack.Common.Ability as Ability
import Game.LambdaHack.Common.Action
import Game.LambdaHack.Common.Actor
import Game.LambdaHack.Common.ActorState
import qualified Game.LambdaHack.Common.Effect as Effect
import Game.LambdaHack.Common.Faction
import qualified Game.LambdaHack.Common.Feature as F
import Game.LambdaHack.Common.Item
import qualified Game.LambdaHack.Common.Kind as Kind
import Game.LambdaHack.Common.Level
import Game.LambdaHack.Common.Perception
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.Time
import Game.LambdaHack.Common.Vector
import Game.LambdaHack.Content.ActorKind
import Game.LambdaHack.Content.ItemKind
import Game.LambdaHack.Content.RuleKind
import Game.LambdaHack.Utils.Assert
import Game.LambdaHack.Utils.Frequency
targetStrategy :: MonadClient m
=> ActorId -> [Ability]
-> m (Strategy (Maybe Target))
targetStrategy actor factionAbilities = do
btarget <- getsClient $ getTarget actor
fper <- getsClient sfper
reacquireTgt fper actor btarget factionAbilities
visibleFoes :: MonadActionRO m
=> FactionPers -> ActorId -> m [(ActorId, Actor)]
visibleFoes fper aid = do
b <- getsState $ getActorBody aid
assert (not $ bproj b) skip
let per = fper EM.! blid b
fact <- getsState $ \s -> sfactionD s EM.! bfid b
foes <- getsState $ actorNotProjAssocs (isAtWar fact) (blid b)
return $! filter (actorSeesLoc per aid . bpos . snd) foes
reacquireTgt :: MonadActionRO m
=> FactionPers -> ActorId -> Maybe Target -> [Ability]
-> m (Strategy (Maybe Target))
reacquireTgt fper aid btarget factionAbilities = do
cops@Kind.COps{coactor=coactor@Kind.Ops{okind}} <- getsState scops
b <- getsState $ getActorBody aid
assert (not $ bproj b) skip
lvl@Level{lxsize} <- getsState $ \s -> sdungeon s EM.! blid b
visFoes <- visibleFoes fper aid
actorD <- getsState sactorD
noFoes :: Strategy (Maybe Target) <- getsState $ \s ->
(Just . TPos . (bpos b `shift`)) `liftM` moveStrategy cops aid s Nothing
let per = fper EM.! blid b
mk = okind $ bkind b
actorAbilities = acanDo mk `intersect` factionAbilities
focused = actorSpeed coactor b <= speedNormal
&& Ability.Chase `elem` actorAbilities
closest :: Strategy (Maybe Target)
closest =
let distB = chessDist lxsize (bpos b)
foeDist = map (\(_, body) -> distB (bpos body)) visFoes
minDist | null foeDist = maxBound
| otherwise = minimum foeDist
minFoes =
filter (\(_, body) -> distB (bpos body) == minDist) visFoes
minTargets = map (\(a, body) ->
Just $ TEnemy a $ bpos body) minFoes
minTgtS = liftFrequency $ uniformFreq "closest" minTargets
in minTgtS .| noFoes .| returN "TCursor" Nothing
reacquire :: Maybe Target -> Strategy (Maybe Target)
reacquire tgt =
case tgt of
Just (TEnemy a ll) | focused ->
case fmap bpos $ EM.lookup a actorD of
Just l | actorSeesLoc per aid l ->
returN "TEnemy" $ Just $ TEnemy a l
_ -> if null visFoes
&& bpos b /= ll
then returN "last known" $ Just $ TPos ll
else closest
Just TEnemy{} -> closest
Just (TPos pos) | bpos b == pos -> closest
Just (TPos pos) | not $ bumpableHere cops lvl False pos ->
closest
Just TPos{} | null visFoes -> returN "TPos" tgt
Just TPos{} -> closest
Nothing -> closest
return $! reacquire btarget
actionStrategy :: MonadClient m
=> ActorId -> [Ability]
-> m (Strategy CmdSer)
actionStrategy actor factionAbilities = do
cops <- getsState scops
s <- getState
btarget <- getsClient $ getTarget actor
disco <- getsClient sdisco
return $! proposeAction cops actor btarget disco s factionAbilities
proposeAction :: Kind.COps -> ActorId
-> Maybe Target -> Discovery -> State -> [Ability]
-> Strategy CmdSer
proposeAction cops actor btarget disco s factionAbilities =
sumS prefix .| combineDistant distant .| sumS suffix
.| waitBlockNow actor
where
Kind.COps{coactor=Kind.Ops{okind}} = cops
Actor{bkind, bpos} = getActorBody actor s
(fpos, foeVisible) =
case btarget of
Just (TEnemy _ l) -> (l, True)
Just (TPos l) -> (l, False)
Nothing -> (bpos, False)
combineDistant as = liftFrequency $ sumF as
aFrequency :: Ability -> Frequency CmdSer
aFrequency Ability.Ranged = if foeVisible
then rangedFreq cops actor disco s fpos
else mzero
aFrequency Ability.Tools = if foeVisible
then toolsFreq cops actor disco s
else mzero
aFrequency Ability.Chase = if fpos /= bpos
then chaseFreq
else mzero
aFrequency _ = assert `failure` distant
chaseFreq =
scaleFreq 30 $ bestVariant $ chase cops actor s (fpos, foeVisible)
aStrategy :: Ability -> Strategy CmdSer
aStrategy Ability.Track = track cops actor s
aStrategy Ability.Heal = mzero
aStrategy Ability.Flee = mzero
aStrategy Ability.Melee = foeVisible .=> melee actor s fpos
aStrategy Ability.Pickup = not foeVisible .=> pickup actor s
aStrategy Ability.Wander = wander cops actor s
aStrategy _ = assert `failure` actorAbilities
actorAbilities = acanDo (okind bkind) `intersect` factionAbilities
isDistant = (`elem` [Ability.Ranged, Ability.Tools, Ability.Chase])
(prefix, rest) = break isDistant actorAbilities
(distant, suffix) = partition isDistant rest
sumS = msum . map aStrategy
sumF = msum . map aFrequency
waitBlockNow :: ActorId -> Strategy CmdSer
waitBlockNow actor = returN "wait" $ WaitSer actor
track :: Kind.COps -> ActorId -> State -> Strategy CmdSer
track cops actor s =
strat
where
lvl = sdungeon s EM.! blid
b@Actor{bpos, bpath, blid} = getActorBody actor s
clearPath = returN "ClearPathSer" $ SetPathSer actor []
strat = case bpath of
Just [] -> assert `failure` (actor, b, s)
Just (d : _) | not $ accessibleDir cops lvl bpos d -> clearPath
Just lv -> returN "SetPathSer" $ SetPathSer actor lv
Nothing -> reject
pickup :: ActorId -> State -> Strategy CmdSer
pickup actor s =
lootHere bpos .=> actionPickup
where
lvl = sdungeon s EM.! blid
body@Actor{bpos, blid} = getActorBody actor s
lootHere x = not $ EM.null $ lvl `atI` x
actionPickup = case EM.minViewWithKey $ lvl `atI` bpos of
Nothing -> assert `failure` (actor, bpos, lvl)
Just ((iid, k), _) ->
let item = getItemBody iid s
l = if jsymbol item == '$' then Just $ InvChar '$' else Nothing
in case assignLetter iid l body of
Just l2 -> returN "pickup" $ PickupSer actor iid k l2
Nothing -> returN "pickup" $ WaitSer actor
melee :: ActorId -> State -> Point -> Strategy CmdSer
melee actor s fpos =
foeAdjacent .=> returN "melee" (MoveSer actor dir)
where
Level{lxsize} = sdungeon s EM.! blid
Actor{bpos, blid} = getActorBody actor s
foeAdjacent = adjacent lxsize bpos fpos
dir = displacement bpos fpos
rangedFreq :: Kind.COps -> ActorId -> Discovery -> State -> Point
-> Frequency CmdSer
rangedFreq cops actor disco s fpos =
toFreq "throwFreq" $
case bl of
Just (pos1 : _) ->
if not foesAdj
&& asight mk
&& accessible cops lvl bpos pos1
&& isNothing (posToActor pos1 blid s)
then throwFreq bbag 3 (actorContainer actor binv)
++ throwFreq tis 6 (const $ CFloor blid bpos)
else []
_ -> []
where
Kind.COps{ coactor=Kind.Ops{okind}
, coitem=Kind.Ops{okind=iokind}
, corule
} = cops
lvl@Level{lxsize, lysize} = sdungeon s EM.! blid
Actor{bkind, bpos, bfid, blid, bbag, binv} = getActorBody actor s
mk = okind bkind
tis = lvl `atI` bpos
fact = sfactionD s EM.! bfid
foes = actorNotProjAssocs (isAtWar fact) blid s
foesAdj = foesAdjacent lxsize lysize bpos (map snd foes)
eps = 0
bl = bla lxsize lysize eps bpos fpos
throwFreq bag multi container =
[ ( benefit * multi,
ProjectSer actor fpos eps iid (container iid))
| (iid, i) <- map (\iid -> (iid, getItemBody iid s))
$ EM.keys bag
, let benefit =
case jkind disco i of
Nothing ->
Effect.effectToBenefit (jeffect i)
Just _ki ->
let _kik = iokind _ki
_unneeded = isymbol _kik
in Effect.effectToBenefit (jeffect i)
, benefit < 0
, jsymbol i `elem` ritemProject (Kind.stdRuleset corule) ]
toolsFreq :: Kind.COps -> ActorId -> Discovery -> State -> Frequency CmdSer
toolsFreq cops actor disco s =
toFreq "quaffFreq"
$ quaffFreq bbag 1 (actorContainer actor binv)
++ quaffFreq tis 2 (const $ CFloor blid bpos)
where
Kind.COps{coitem=Kind.Ops{okind=_iokind}} = cops
Actor{bpos, blid, bbag, binv} = getActorBody actor s
lvl = sdungeon s EM.! blid
tis = lvl `atI` bpos
quaffFreq bag multi container =
[ (benefit * multi, ApplySer actor iid (container iid))
| (iid, i) <- map (\iid -> (iid, getItemBody iid s))
$ EM.keys bag
, let benefit =
case jkind disco i of
Nothing -> 30
Just _ki -> Effect.effectToBenefit $ jeffect i
, benefit > 0
, jsymbol i == '!' ]
moveStrategy :: Kind.COps -> ActorId -> State -> Maybe (Point, Bool)
-> Strategy Vector
moveStrategy cops actor s mFoe =
case mFoe of
Just (fpos, _) ->
let towardsFoe =
let tolerance | adjacent lxsize bpos fpos = 0
| otherwise = 1
foeDir = towards lxsize bpos fpos
in only (\x -> euclidDistSq lxsize foeDir x <= tolerance)
in if fpos == bpos
then reject
else towardsFoe
$ if foeVisible
then moveClear
.| moveOpenable
else moveOpenable
.| moveClear
Nothing ->
let smells =
map (map fst)
$ groupBy ((==) `on` snd)
$ sortBy (flip compare `on` snd)
$ filter (\(_, sm) -> sm > timeZero)
$ map (\x ->
let sml = EM.findWithDefault
timeZero (bpos `shift` x) lsmell
in (x, sml `timeAdd` timeNegate ltime))
sensible
in asmell mk .=> foldr ((.|)
. liftFrequency
. uniformFreq "smell k") reject smells
.| moveOpenable
.| moveClear
where
Kind.COps{cotile, coactor=Kind.Ops{okind}} = cops
lvl@Level{lsmell, lxsize, lysize, ltime} = sdungeon s EM.! blid
Actor{bkind, bpos, boldpos, bfid, blid} = getActorBody actor s
mk = okind bkind
lootHere x = not $ EM.null $ lvl `atI` x
onlyLoot = onlyMoves lootHere
interestHere x = let t = lvl `at` x
ts = map (lvl `at`) $ vicinity lxsize lysize x
in Tile.hasFeature cotile F.Exit t
|| asight mk && Tile.hasFeature cotile F.Suspect t
|| (not (Tile.hasFeature cotile F.Lit t)
&& (x == bpos || accessible cops lvl x bpos)
&& any (Tile.hasFeature cotile F.Lit) ts)
onlyInterest = onlyMoves interestHere
bdirAI | bpos == boldpos = Nothing
| otherwise = Just $ towards lxsize boldpos bpos
onlyKeepsDir k =
only (\x -> maybe True (\d -> euclidDistSq lxsize d x <= k) bdirAI)
onlyKeepsDir_9 = only (\x -> maybe True (\d -> neg x /= d) bdirAI)
foeVisible = fmap snd mFoe == Just True
moveIQ | foeVisible = onlyKeepsDir_9 moveRandomly
| otherwise =
aiq mk > 15 .=> onlyKeepsDir 0 moveRandomly
.| aiq mk > 10 .=> onlyKeepsDir 1 moveRandomly
.| aiq mk > 5 .=> onlyKeepsDir 2 moveRandomly
.| onlyKeepsDir_9 moveRandomly
interestFreq | interestHere bpos =
mzero
| otherwise =
scaleFreq 5 $ bestVariant $ onlyInterest $ onlyKeepsDir 2 moveRandomly
interestIQFreq = interestFreq `mplus` bestVariant moveIQ
moveClear = onlyMoves (not . bumpableHere cops lvl foeVisible) moveFreely
moveOpenable = onlyMoves (bumpableHere cops lvl foeVisible) moveFreely
moveNewLoot = onlyLoot (onlyKeepsDir 2 moveRandomly)
moveFreely = moveNewLoot
.| liftFrequency interestIQFreq
.| moveIQ
.| moveRandomly
onlyMoves :: (Point -> Bool) -> Strategy Vector -> Strategy Vector
onlyMoves p = only (\x -> p (bpos `shift` x))
moveRandomly :: Strategy Vector
moveRandomly = liftFrequency $ uniformFreq "moveRandomly" sensible
accessibleHere = accessible cops lvl bpos
fact = sfactionD s EM.! bfid
friends = actorList (not . isAtWar fact) blid s
noFriends | asight mk = unoccupied friends
| otherwise = const True
isSensible l = noFriends l && (accessibleHere l
|| bumpableHere cops lvl foeVisible l)
sensible = filter (isSensible . (bpos `shift`)) (moves lxsize)
bumpableHere :: Kind.COps -> Level -> Bool -> Point -> Bool
bumpableHere Kind.COps{cotile} lvl foeVisible pos =
let t = lvl `at` pos
in Tile.hasFeature cotile F.Openable t
||
not foeVisible && Tile.hasFeature cotile F.Suspect t
chase :: Kind.COps -> ActorId -> State -> (Point, Bool) -> Strategy CmdSer
chase cops actor s foe@(_, foeVisible) =
let mFoe = Just foe
fight = not foeVisible
in if fight
then ExploreSer actor `liftM` moveStrategy cops actor s mFoe
else RunSer actor `liftM` moveStrategy cops actor s mFoe
wander :: Kind.COps -> ActorId -> State -> Strategy CmdSer
wander cops actor s =
let mFoe = Nothing
in ExploreSer actor `liftM` moveStrategy cops actor s mFoe