module Game.LambdaHack.Client.ClientSem where
import Control.Exception.Assert.Sugar
import Control.Monad
import qualified Data.EnumMap.Strict as EM
import Data.List
import qualified Data.Map.Strict as M
import Data.Maybe
import Data.Ord
import qualified Data.Text as T
import Game.LambdaHack.Client.Action
import Game.LambdaHack.Client.Binding
import Game.LambdaHack.Client.Config
import Game.LambdaHack.Client.Draw
import Game.LambdaHack.Client.HumanSem
import Game.LambdaHack.Client.RunAction
import Game.LambdaHack.Client.State
import Game.LambdaHack.Client.Strategy
import Game.LambdaHack.Client.StrategyAction
import Game.LambdaHack.Common.Action
import Game.LambdaHack.Common.Actor
import Game.LambdaHack.Common.ActorState
import Game.LambdaHack.Common.Faction
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.Point
import Game.LambdaHack.Common.Random
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.FactionKind
import Game.LambdaHack.Utils.Frequency
queryAI :: MonadClient m => ActorId -> m CmdTakeTimeSer
queryAI oldAid = do
Kind.COps{cotile, cofaction=Kind.Ops{okind}} <- getsState scops
oldBody <- getsState $ getActorBody oldAid
let side = bfid oldBody
arena = blid oldBody
fact <- getsState $ (EM.! side) . sfactionD
lvl <- getLevel arena
let leaderStuck = waitedLastTurn oldBody
t = lvl `at` bpos oldBody
abilityLeader = fAbilityLeader $ okind $ gkind fact
abilityOther = fAbilityOther $ okind $ gkind fact
mleader <- getsClient _sleader
ours <- getsState $ actorNotProjAssocs (== side) arena
let pickOld = do
void $ refreshTarget oldAid (oldAid, oldBody)
queryAIPick (oldAid, oldBody)
case ours of
_ |
mleader /= Just oldAid
|| abilityLeader == abilityOther
|| isSpawnFact fact
|| not leaderStuck && Tile.isStair cotile t
-> pickOld
[] -> assert `failure` (oldAid, oldBody)
[_] -> pickOld
(captain, captainBody) : (sergeant, sergeantBody) : _ -> do
oursTgt <- fmap catMaybes $ mapM (refreshTarget oldAid) ours
let targetTEnemy (_, (TEnemy{}, _)) = True
targetTEnemy _ = False
(oursTEnemy, oursOther) = partition targetTEnemy oursTgt
targetBlocked our@((_aid, _b), (_tgt, (path, _etc))) =
let next = case path of
[] -> assert `failure` our
[_goal] -> Nothing
_ : q : _ -> Just q
in any ((== next) . Just . bpos . snd) ours
(oursBlocked, oursPos) = partition targetBlocked oursOther
valueOurs :: ((ActorId, Actor), (Target, PathEtc))
-> (Int, Int, Bool)
valueOurs our@((aid, b), (TEnemy{}, (_, (_, d)))) =
( d + if targetBlocked our then 2 else 0
, 10 * (bhp b `div` 10)
, aid /= oldAid )
valueOurs ((aid, b), (_tgt, (_path, (goal, d)))) =
let
minSpread = 7
maxSpread = 12 * 2
dcaptain p =
chessDistVector $ displacement p (bpos captainBody)
dsergeant p =
chessDistVector $ displacement p (bpos sergeantBody)
minDist | aid == captain = dsergeant (bpos b)
| aid == sergeant = dcaptain (bpos b)
| otherwise = dsergeant (bpos b)
`min` dcaptain (bpos b)
pDist p = dcaptain p + dsergeant p
sumDist = pDist (bpos b)
diffDist = sumDist pDist goal
minCoeff | minDist < minSpread =
(minDist minSpread) `div` 3
if aid == oldAid then 3 else 0
| otherwise = 0
explorationValue = diffDist * (sumDist `div` 4)
sumCoeff | sumDist > maxSpread = explorationValue
| otherwise = 0
in ( if d == 0 then d
else max 1 $ minCoeff + if d < 10
then 3 + d `div` 4
else 9 + d `div` 10
, sumCoeff
, aid /= oldAid )
sortOurs = sortBy $ comparing valueOurs
goodGeneric _our@((aid, b), (_tgt, _pathEtc)) =
bhp b > 0
&& not (aid == oldAid && waitedLastTurn b)
goodTEnemy our@((_aid, b), (_tgt, (_path, (goal, _d)))) =
not (adjacent (bpos b) goal)
&& goodGeneric our
oursTEnemyGood = filter goodTEnemy oursTEnemy
oursPosGood = filter goodGeneric oursPos
oursBlockedGood = filter goodGeneric oursBlocked
candidates = sortOurs oursTEnemyGood
++ sortOurs oursPosGood
++ sortOurs oursBlockedGood
case candidates of
[] -> queryAIPick (oldAid, oldBody)
c : _ -> do
let best = takeWhile ((== valueOurs c) . valueOurs) candidates
freq = uniformFreq "candidates for AI leader" best
((aid, b), _) <- rndToAction $ frequency freq
s <- getState
modifyClient $ updateLeader aid s
queryAIPick (aid, b)
refreshTarget :: MonadClient m
=> ActorId -> (ActorId, Actor)
-> m (Maybe ((ActorId, Actor), (Target, PathEtc)))
refreshTarget oldLeader (aid, body) = do
side <- getsClient sside
assert (bfid body == side `blame` "AI tries to move an enemy actor"
`twith` (aid, body, side)) skip
assert (not (bproj body) `blame` "AI gets to manually move its projectiles"
`twith` (aid, body, side)) skip
stratTarget <- targetStrategy oldLeader aid
tgtMPath <-
if nullStrategy stratTarget then
return Nothing
else do
(tgt, path) <- rndToAction $ frequency $ bestVariant stratTarget
return $ Just (tgt, Just path)
let _debug = T.unpack
$ "\nHandleAI symbol:" <+> tshow (bsymbol body)
<> ", aid:" <+> tshow aid
<> ", pos:" <+> tshow (bpos body)
<> "\nHandleAI starget:" <+> tshow stratTarget
<> "\nHandleAI target:" <+> tshow tgtMPath
modifyClient $ \cli ->
cli {stargetD = EM.alter (const $ tgtMPath) aid (stargetD cli)}
return $! case tgtMPath of
Just (tgt, Just pathEtc) -> Just ((aid, body), (tgt, pathEtc))
_ -> Nothing
queryAIPick :: MonadClient m => (ActorId, Actor) -> m CmdTakeTimeSer
queryAIPick (aid, body) = do
side <- getsClient sside
assert (bfid body == side `blame` "AI tries to move enemy actor"
`twith` (aid, bfid body, side)) skip
assert (not (bproj body) `blame` "AI gets to manually move its projectiles"
`twith` (aid, bfid body, side)) skip
stratAction <- actionStrategy aid
rndToAction $ frequency $ bestVariant stratAction
queryUI :: MonadClientUI m => ActorId -> m CmdSer
queryUI aid = do
side <- getsClient sside
fact <- getsState $ (EM.! side) . sfactionD
leader <- getLeaderUI
assert (leader == aid `blame` "player moves not his leader"
`twith` (leader, aid)) skip
srunning <- getsClient srunning
case srunning of
Nothing -> humanCommand Nothing
Just RunParams{runMembers} | isSpawnFact fact && runMembers /= [aid] -> do
stopRunning
ConfigUI{configRunStopMsgs} <- getsClient sconfigUI
let msg = if configRunStopMsgs
then Just $ "Run stop: spawner leader change"
else Nothing
humanCommand msg
Just runParams -> do
runOutcome <- continueRun runParams
case runOutcome of
Left stopMsg -> do
stopRunning
ConfigUI{configRunStopMsgs} <- getsClient sconfigUI
let msg = if configRunStopMsgs
then Just $ "Run stop:" <+> stopMsg
else Nothing
humanCommand msg
Right (paramNew, runCmd) -> do
modifyClient $ \cli -> cli {srunning = Just paramNew}
return $! CmdTakeTimeSer runCmd
humanCommand :: forall m. MonadClientUI m
=> Maybe Msg
-> m CmdSer
humanCommand msgRunStop = do
modifyClient $ \cli -> cli {sbfsD = EM.empty}
let loop :: Maybe (Bool, Overlay) -> m CmdSer
loop mover = do
(lastBlank, over) <- case mover of
Nothing -> do
modifyClient $ \cli -> cli {slastKey = Nothing}
sli <- promptToSlideshow ""
return (False, head . snd $! slideshow sli)
Just bLast ->
return bLast
(seqCurrent, seqPrevious, k) <- getsClient slastRecord
case k of
0 -> do
let slastRecord = ([], seqCurrent, 0)
modifyClient $ \cli -> cli {slastRecord}
_ -> do
let slastRecord = ([], seqCurrent ++ seqPrevious, k 1)
modifyClient $ \cli -> cli {slastRecord}
km <- getKeyOverlayCommand lastBlank over
recordHistory
abortOrCmd <- do
Binding{bcmdMap} <- askBinding
case M.lookup km bcmdMap of
Just (_, _, cmd) -> do
lastKey <- getsClient slastKey
stgtMode <- getsClient stgtMode
modifyClient $ \cli -> cli
{swaitTimes = if swaitTimes cli > 0
then swaitTimes cli
else 0}
if Just km == lastKey
|| km == K.escKey && isNothing stgtMode && isJust mover
then do
modifyClient $ \cli -> cli {slastKey = Nothing}
cmdHumanSem Clear
else do
modifyClient $ \cli -> cli {slastKey = Just km}
cmdHumanSem cmd
Nothing -> let msgKey = "unknown command <" <> K.showKM km <> ">"
in fmap Left $ promptToSlideshow msgKey
case abortOrCmd of
Right cmdS -> do
modifyClient $ \cli -> cli {slastKey = Nothing}
case cmdS of
CmdTakeTimeSer cmd ->
modifyClient $ \cli -> cli {slastCmd = Just cmd}
_ -> return ()
return cmdS
Left slides -> do
let (onBlank, sli) = slideshow slides
mLast <- case reverse sli of
[] -> return Nothing
[sLast] -> return $ Just (onBlank, sLast)
sls@(sLast : _) -> do
go <- getInitConfirms ColorFull [km]
$ toSlideshow onBlank $ reverse $ map overlay sls
return $! if go then Just (onBlank, sLast) else Nothing
loop mLast
case msgRunStop of
Nothing -> loop Nothing
Just msg -> do
sli <- promptToSlideshow msg
loop $ Just (False, head . snd $ slideshow sli)