-- | Semantics of "Game.LambdaHack.Client.UI.HumanCmd"
-- client commands that return server requests.
-- A couple of them do not take time, the rest does.
-- Here prompts and menus are displayed, but any feedback resulting
-- from the commands (e.g., from inventory manipulation) is generated later on,
-- by the server, for all clients that witness the results of the commands.
module Game.LambdaHack.Client.UI.HandleHumanGlobalM
  ( -- * Meta commands
    byAreaHuman, byAimModeHuman
  , composeIfLocalHuman, composeUnlessErrorHuman, compose2ndLocalHuman
  , loopOnNothingHuman, executeIfClearHuman
    -- * Global commands that usually take time
  , waitHuman, waitHuman10, yellHuman, moveRunHuman
  , runOnceAheadHuman, moveOnceToXhairHuman
  , runOnceToXhairHuman, continueToXhairHuman
  , moveItemHuman, projectHuman, applyHuman
  , alterDirHuman, alterWithPointerHuman, closeDirHuman
  , helpHuman, hintHuman, dashboardHuman, itemMenuHuman, chooseItemMenuHuman
  , mainMenuHuman, mainMenuAutoOnHuman, mainMenuAutoOffHuman
  , settingsMenuHuman, challengeMenuHuman, gameDifficultyIncr
  , gameFishToggle, gameGoodsToggle, gameWolfToggle, gameKeeperToggle
  , gameScenarioIncr
    -- * Global commands that never take time
  , gameExitWithHuman, ExitStrategy(..), gameDropHuman, gameExitHuman
  , gameSaveHuman, doctrineHuman, automateHuman, automateToggleHuman
  , automateBackHuman
#ifdef EXPOSE_INTERNAL
    -- * Internal operations
  , areaToRectangles, meleeAid, displaceAid, moveSearchAlter, alterCommon
  , goToXhair, goToXhairExplorationMode, goToXhairGoTo
  , multiActorGoTo, moveOrSelectItem, selectItemsToMove, moveItems
  , projectItem, applyItem, alterTileAtPos, verifyAlters, processTileActions
  , verifyEscape, verifyToolEffect, closeTileAtPos, msgAddDone, pickPoint
  , generateMenu
#endif
  ) where

import Prelude ()

import Game.LambdaHack.Core.Prelude

import qualified Data.Char as Char
import           Data.Either
import qualified Data.EnumMap.Strict as EM
import qualified Data.EnumSet as ES
import qualified Data.Map.Strict as M
import qualified Data.Text as T
import           Data.Version
import qualified NLP.Miniutter.English as MU

import           Game.LambdaHack.Client.Bfs
import           Game.LambdaHack.Client.BfsM
import           Game.LambdaHack.Client.CommonM
import           Game.LambdaHack.Client.MonadClient
import           Game.LambdaHack.Client.Request
import           Game.LambdaHack.Client.State
import           Game.LambdaHack.Client.UI.ActorUI
import           Game.LambdaHack.Client.UI.Content.Input
import           Game.LambdaHack.Client.UI.Content.Screen
import           Game.LambdaHack.Client.UI.ContentClientUI
import           Game.LambdaHack.Client.UI.Frame
import           Game.LambdaHack.Client.UI.FrameM
import           Game.LambdaHack.Client.UI.HandleHelperM
import           Game.LambdaHack.Client.UI.HandleHumanLocalM
import           Game.LambdaHack.Client.UI.HumanCmd
import           Game.LambdaHack.Client.UI.InventoryM
import           Game.LambdaHack.Client.UI.ItemDescription
import qualified Game.LambdaHack.Client.UI.Key as K
import           Game.LambdaHack.Client.UI.KeyBindings
import           Game.LambdaHack.Client.UI.MonadClientUI
import           Game.LambdaHack.Client.UI.Msg
import           Game.LambdaHack.Client.UI.MsgM
import           Game.LambdaHack.Client.UI.Overlay
import           Game.LambdaHack.Client.UI.PointUI
import           Game.LambdaHack.Client.UI.RunM
import           Game.LambdaHack.Client.UI.SessionUI
import           Game.LambdaHack.Client.UI.Slideshow
import           Game.LambdaHack.Client.UI.SlideshowM
import           Game.LambdaHack.Client.UI.UIOptions
import           Game.LambdaHack.Common.Actor
import           Game.LambdaHack.Common.ActorState
import           Game.LambdaHack.Common.Area
import           Game.LambdaHack.Common.ClientOptions
import           Game.LambdaHack.Common.Faction
import           Game.LambdaHack.Common.Item
import qualified Game.LambdaHack.Common.ItemAspect as IA
import           Game.LambdaHack.Common.Kind
import           Game.LambdaHack.Common.Level
import           Game.LambdaHack.Common.Misc
import           Game.LambdaHack.Common.MonadStateRead
import           Game.LambdaHack.Common.Point
import           Game.LambdaHack.Common.ReqFailure
import           Game.LambdaHack.Common.State
import qualified Game.LambdaHack.Common.Tile as Tile
import           Game.LambdaHack.Common.Types
import           Game.LambdaHack.Common.Vector
import qualified Game.LambdaHack.Content.FactionKind as FK
import qualified Game.LambdaHack.Content.ItemKind as IK
import qualified Game.LambdaHack.Content.ModeKind as MK
import           Game.LambdaHack.Content.RuleKind
import qualified Game.LambdaHack.Content.TileKind as TK
import qualified Game.LambdaHack.Core.Dice as Dice
import           Game.LambdaHack.Core.Random
import qualified Game.LambdaHack.Definition.Ability as Ability
import qualified Game.LambdaHack.Definition.Color as Color
import           Game.LambdaHack.Definition.Defs
import qualified Game.LambdaHack.Definition.DefsInternal as DefsInternal

-- * ByArea

-- | Pick command depending on area the mouse pointer is in.
-- The first matching area is chosen. If none match, only interrupt.
byAreaHuman :: MonadClientUI m
            => (K.KM -> HumanCmd -> m (Either MError ReqUI))
            -> [(CmdArea, HumanCmd)]
            -> m (Either MError ReqUI)
byAreaHuman :: forall (m :: * -> *).
MonadClientUI m =>
(KM -> HumanCmd -> m (Either MError ReqUI))
-> [(CmdArea, HumanCmd)] -> m (Either MError ReqUI)
byAreaHuman KM -> HumanCmd -> m (Either MError ReqUI)
cmdSemInCxtOfKM [(CmdArea, HumanCmd)]
l = do
  CCUI{coinput=InputContent{brevMap}} <- (SessionUI -> CCUI) -> m CCUI
forall a. (SessionUI -> a) -> m a
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> CCUI
sccui
  pUI <- getsSession spointer
  let PointSquare px py = uiToSquare pUI
      p = Point {Int
px :: Int
py :: Int
py :: Int
px :: Int
..}  -- abuse of convention: @Point@, not @PointSquare@ used
                      -- for the whole UI screen in square font coordinates
      pointerInArea CmdArea
a = do
        rs <- CmdArea -> m [Maybe Area]
forall (m :: * -> *). MonadClientUI m => CmdArea -> m [Maybe Area]
areaToRectangles CmdArea
a
        return $! any (`inside` p) $ catMaybes rs
  cmds <- filterM (pointerInArea . fst) l
  case cmds of
    [] -> do
      m ()
forall (m :: * -> *). MonadClientUI m => m ()
stopPlayBack
      Either MError ReqUI -> m (Either MError ReqUI)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either MError ReqUI -> m (Either MError ReqUI))
-> Either MError ReqUI -> m (Either MError ReqUI)
forall a b. (a -> b) -> a -> b
$ MError -> Either MError ReqUI
forall a b. a -> Either a b
Left MError
forall a. Maybe a
Nothing
    (CmdArea
_, HumanCmd
cmd) : [(CmdArea, HumanCmd)]
_ -> do
      let kmFound :: KM
kmFound = case HumanCmd -> Map HumanCmd [KM] -> Maybe [KM]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup HumanCmd
cmd Map HumanCmd [KM]
brevMap of
            Just (KM
km : [KM]
_) -> KM
km
            Maybe [KM]
_ -> KM
K.escKM
      KM -> HumanCmd -> m (Either MError ReqUI)
cmdSemInCxtOfKM KM
kmFound HumanCmd
cmd

-- Many values here are shared with "Game.LambdaHack.Client.UI.DrawM".
areaToRectangles :: MonadClientUI m => CmdArea -> m [Maybe Area]
areaToRectangles :: forall (m :: * -> *). MonadClientUI m => CmdArea -> m [Maybe Area]
areaToRectangles CmdArea
ca = ((Int, Int, Int, Int) -> Maybe Area)
-> [(Int, Int, Int, Int)] -> [Maybe Area]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Int, Int, Int) -> Maybe Area
toArea ([(Int, Int, Int, Int)] -> [Maybe Area])
-> m [(Int, Int, Int, Int)] -> m [Maybe Area]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
 CCUI{coscreen=ScreenContent{rwidth, rheight}} <- (SessionUI -> CCUI) -> m CCUI
forall a. (SessionUI -> a) -> m a
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> CCUI
sccui
 case ca of
  CmdArea
CaMessage -> [(Int, Int, Int, Int)] -> m [(Int, Int, Int, Int)]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [(Int
0, Int
0, Int
rwidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, Int
0)]
  CmdArea
CaMapLeader -> do  -- takes preference over @CaMapParty@ and @CaMap@
    mleader <- (StateClient -> Maybe ActorId) -> m (Maybe ActorId)
forall a. (StateClient -> a) -> m a
forall (m :: * -> *) a.
MonadClientRead m =>
(StateClient -> a) -> m a
getsClient StateClient -> Maybe ActorId
sleader
    case mleader of
      Maybe ActorId
Nothing -> [(Int, Int, Int, Int)] -> m [(Int, Int, Int, Int)]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
      Just ActorId
leader -> do
        b <- (State -> Actor) -> m Actor
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
leader
        let PointSquare x y = mapToSquare $ bpos b
        return [(x, y, x, y)]
  CmdArea
CaMapParty -> do  -- takes preference over @CaMap@
    lidV <- m LevelId
forall (m :: * -> *). MonadClientUI m => m LevelId
viewedLevelUI
    side <- getsClient sside
    ours <- getsState $ filter (not . bproj) . map snd
                        . actorAssocs (== side) lidV
    let rectFromB Point
p = let PointSquare Int
x Int
y = Point -> PointSquare
mapToSquare Point
p
                      in (Int
x, Int
y, Int
x, Int
y)
    return $! map (rectFromB . bpos) ours
  CmdArea
CaMap ->
    let PointSquare Int
xo Int
yo = Point -> PointSquare
mapToSquare Point
originPoint
        PointSquare Int
xe Int
ye = Point -> PointSquare
mapToSquare (Point -> PointSquare) -> Point -> PointSquare
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Point
Point (Int
rwidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Int
rheight Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
4)
    in [(Int, Int, Int, Int)] -> m [(Int, Int, Int, Int)]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [(Int
xo, Int
yo, Int
xe, Int
ye)]
  CmdArea
CaLevelNumber -> let y :: Int
y = Int
rheight Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2
                   in [(Int, Int, Int, Int)] -> m [(Int, Int, Int, Int)]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [(Int
0, Int
y, Int
1, Int
y)]
  CmdArea
CaArenaName -> let y :: Int
y = Int
rheight Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2
                     x :: Int
x = (Int
rwidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
11
                 in [(Int, Int, Int, Int)] -> m [(Int, Int, Int, Int)]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [(Int
3, Int
y, Int
x, Int
y)]
  CmdArea
CaPercentSeen -> let y :: Int
y = Int
rheight Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2
                       x :: Int
x = (Int
rwidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
                   in [(Int, Int, Int, Int)] -> m [(Int, Int, Int, Int)]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [(Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
9, Int
y, Int
x, Int
y)]
  CmdArea
CaXhairDesc -> let y :: Int
y = Int
rheight Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2
                     x :: Int
x = (Int
rwidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2
                 in [(Int, Int, Int, Int)] -> m [(Int, Int, Int, Int)]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [(Int
x, Int
y, Int
rwidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, Int
y)]
  CmdArea
CaSelected -> let y :: Int
y = Int
rheight Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
                    x :: Int
x = (Int
rwidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
                in [(Int, Int, Int, Int)] -> m [(Int, Int, Int, Int)]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [(Int
0, Int
y, Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
24, Int
y)]
  CmdArea
CaCalmGauge -> let y :: Int
y = Int
rheight Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
                     x :: Int
x = (Int
rwidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
                 in [(Int, Int, Int, Int)] -> m [(Int, Int, Int, Int)]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [(Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
22, Int
y, Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
18, Int
y)]
  CmdArea
CaCalmValue -> let y :: Int
y = Int
rheight Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
                     x :: Int
x = (Int
rwidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
                 in [(Int, Int, Int, Int)] -> m [(Int, Int, Int, Int)]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [(Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
17, Int
y, Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
11, Int
y)]
  CmdArea
CaHPGauge -> let y :: Int
y = Int
rheight Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
                   x :: Int
x = (Int
rwidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
               in [(Int, Int, Int, Int)] -> m [(Int, Int, Int, Int)]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [(Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
9, Int
y, Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
6, Int
y)]
  CmdArea
CaHPValue -> let y :: Int
y = Int
rheight Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
                   x :: Int
x = (Int
rwidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
               in [(Int, Int, Int, Int)] -> m [(Int, Int, Int, Int)]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [(Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
6, Int
y, Int
x, Int
y)]
  CmdArea
CaLeaderDesc -> let y :: Int
y = Int
rheight Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
                      x :: Int
x = (Int
rwidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2
                  in [(Int, Int, Int, Int)] -> m [(Int, Int, Int, Int)]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [(Int
x, Int
y, Int
rwidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, Int
y)]

-- * ByAimMode

byAimModeHuman :: MonadClientUI m
               => m (Either MError ReqUI) -> m (Either MError ReqUI)
               -> m (Either MError ReqUI)
byAimModeHuman :: forall (m :: * -> *).
MonadClientUI m =>
m (Either MError ReqUI)
-> m (Either MError ReqUI) -> m (Either MError ReqUI)
byAimModeHuman m (Either MError ReqUI)
cmdNotAimingM m (Either MError ReqUI)
cmdAimingM = do
  aimMode <- (SessionUI -> Maybe AimMode) -> m (Maybe AimMode)
forall a. (SessionUI -> a) -> m a
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> Maybe AimMode
saimMode
  if isNothing aimMode then cmdNotAimingM else cmdAimingM

-- * ComposeIfLocal

composeIfLocalHuman :: MonadClientUI m
                    => m (Either MError ReqUI) -> m (Either MError ReqUI)
                    -> m (Either MError ReqUI)
composeIfLocalHuman :: forall (m :: * -> *).
MonadClientUI m =>
m (Either MError ReqUI)
-> m (Either MError ReqUI) -> m (Either MError ReqUI)
composeIfLocalHuman m (Either MError ReqUI)
c1 m (Either MError ReqUI)
c2 = do
  slideOrCmd1 <- m (Either MError ReqUI)
c1
  case slideOrCmd1 of
    Left MError
merr1 -> do
      slideOrCmd2 <- m (Either MError ReqUI)
c2
      case slideOrCmd2 of
        Left MError
merr2 -> Either MError ReqUI -> m (Either MError ReqUI)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either MError ReqUI -> m (Either MError ReqUI))
-> Either MError ReqUI -> m (Either MError ReqUI)
forall a b. (a -> b) -> a -> b
$ MError -> Either MError ReqUI
forall a b. a -> Either a b
Left (MError -> Either MError ReqUI) -> MError -> Either MError ReqUI
forall a b. (a -> b) -> a -> b
$ MError -> MError -> MError
mergeMError MError
merr1 MError
merr2
        Either MError ReqUI
_ -> Either MError ReqUI -> m (Either MError ReqUI)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Either MError ReqUI
slideOrCmd2
    Either MError ReqUI
_ -> Either MError ReqUI -> m (Either MError ReqUI)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Either MError ReqUI
slideOrCmd1

-- * ComposeUnlessError

composeUnlessErrorHuman :: MonadClientUI m
                        => m (Either MError ReqUI) -> m (Either MError ReqUI)
                        -> m (Either MError ReqUI)
composeUnlessErrorHuman :: forall (m :: * -> *).
MonadClientUI m =>
m (Either MError ReqUI)
-> m (Either MError ReqUI) -> m (Either MError ReqUI)
composeUnlessErrorHuman m (Either MError ReqUI)
c1 m (Either MError ReqUI)
c2 = do
  slideOrCmd1 <- m (Either MError ReqUI)
c1
  case slideOrCmd1 of
    Left MError
Nothing -> m (Either MError ReqUI)
c2
    Either MError ReqUI
_ -> Either MError ReqUI -> m (Either MError ReqUI)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Either MError ReqUI
slideOrCmd1

-- * Compose2ndLocal

compose2ndLocalHuman :: MonadClientUI m
                     => m (Either MError ReqUI) -> m (Either MError ReqUI)
                     -> m (Either MError ReqUI)
compose2ndLocalHuman :: forall (m :: * -> *).
MonadClientUI m =>
m (Either MError ReqUI)
-> m (Either MError ReqUI) -> m (Either MError ReqUI)
compose2ndLocalHuman m (Either MError ReqUI)
c1 m (Either MError ReqUI)
c2 = do
  slideOrCmd1 <- m (Either MError ReqUI)
c1
  case slideOrCmd1 of
    Left MError
merr1 -> do
      slideOrCmd2 <- m (Either MError ReqUI)
c2
      case slideOrCmd2 of
        Left MError
merr2 -> Either MError ReqUI -> m (Either MError ReqUI)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either MError ReqUI -> m (Either MError ReqUI))
-> Either MError ReqUI -> m (Either MError ReqUI)
forall a b. (a -> b) -> a -> b
$ MError -> Either MError ReqUI
forall a b. a -> Either a b
Left (MError -> Either MError ReqUI) -> MError -> Either MError ReqUI
forall a b. (a -> b) -> a -> b
$ MError -> MError -> MError
mergeMError MError
merr1 MError
merr2
        Either MError ReqUI
_ -> Either MError ReqUI -> m (Either MError ReqUI)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Either MError ReqUI
slideOrCmd1  -- ignore second request, keep effect
    Either MError ReqUI
req -> do
      m (Either MError ReqUI) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void m (Either MError ReqUI)
c2  -- ignore second request, keep effect
      Either MError ReqUI -> m (Either MError ReqUI)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Either MError ReqUI
req

-- * LoopOnNothing

loopOnNothingHuman :: MonadClientUI m
                   => m (Either MError ReqUI)
                   -> m (Either MError ReqUI)
loopOnNothingHuman :: forall (m :: * -> *).
MonadClientUI m =>
m (Either MError ReqUI) -> m (Either MError ReqUI)
loopOnNothingHuman m (Either MError ReqUI)
cmd = do
  res <- m (Either MError ReqUI)
cmd
  case res of
    Left MError
Nothing -> m (Either MError ReqUI) -> m (Either MError ReqUI)
forall (m :: * -> *).
MonadClientUI m =>
m (Either MError ReqUI) -> m (Either MError ReqUI)
loopOnNothingHuman m (Either MError ReqUI)
cmd
    Either MError ReqUI
_ -> Either MError ReqUI -> m (Either MError ReqUI)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Either MError ReqUI
res

-- * ExecuteIfClear

executeIfClearHuman :: MonadClientUI m
                    => m (Either MError ReqUI)
                    -> m (Either MError ReqUI)
executeIfClearHuman :: forall (m :: * -> *).
MonadClientUI m =>
m (Either MError ReqUI) -> m (Either MError ReqUI)
executeIfClearHuman m (Either MError ReqUI)
c1 = do
  sreportNull <- (SessionUI -> Bool) -> m Bool
forall a. (SessionUI -> a) -> m a
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> Bool
sreportNull
  sreqDelay <- getsSession sreqDelay
  -- When server query delay is handled, don't complicate things by clearing
  -- screen instead of running the command.
  if sreportNull || sreqDelay == ReqDelayHandled
  then c1
  else return $ Left Nothing

-- * Wait

-- | Leader waits a turn (and blocks, etc.).
waitHuman :: MonadClientUI m => ActorId -> m (FailOrCmd RequestTimed)
waitHuman :: forall (m :: * -> *).
MonadClientUI m =>
ActorId -> m (FailOrCmd RequestTimed)
waitHuman ActorId
leader = do
  actorCurAndMaxSk <- (State -> Skills) -> m Skills
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Skills) -> m Skills) -> (State -> Skills) -> m Skills
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Skills
getActorMaxSkills ActorId
leader
  if Ability.getSk Ability.SkWait actorCurAndMaxSk > 0 then do
    modifySession $ \SessionUI
sess -> SessionUI
sess {swaitTimes = abs (swaitTimes sess) + 1}
    return $ Right ReqWait
  else failSer WaitUnskilled

-- * Wait10

-- | Leader waits a 1/10th of a turn (and doesn't block, etc.).
waitHuman10 :: MonadClientUI m => ActorId -> m (FailOrCmd RequestTimed)
waitHuman10 :: forall (m :: * -> *).
MonadClientUI m =>
ActorId -> m (FailOrCmd RequestTimed)
waitHuman10 ActorId
leader = do
  actorCurAndMaxSk <- (State -> Skills) -> m Skills
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Skills) -> m Skills) -> (State -> Skills) -> m Skills
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Skills
getActorMaxSkills ActorId
leader
  if Ability.getSk Ability.SkWait actorCurAndMaxSk >= 4 then do
    modifySession $ \SessionUI
sess -> SessionUI
sess {swaitTimes = abs (swaitTimes sess) + 1}
    return $ Right ReqWait10
  else failSer WaitUnskilled

-- * Yell

-- | Leader yells or yawns, if sleeping.
yellHuman :: MonadClientUI m => ActorId -> m (FailOrCmd RequestTimed)
yellHuman :: forall (m :: * -> *).
MonadClientUI m =>
ActorId -> m (FailOrCmd RequestTimed)
yellHuman ActorId
leader = do
  actorCurAndMaxSk <- (State -> Skills) -> m Skills
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Skills) -> m Skills) -> (State -> Skills) -> m Skills
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Skills
getActorMaxSkills ActorId
leader
  if Ability.getSk Ability.SkWait actorCurAndMaxSk > 0
     -- If waiting drained and really, potentially, no other possible action,
     -- still allow yelling.
     || Ability.getSk Ability.SkMove actorCurAndMaxSk <= 0
     || Ability.getSk Ability.SkDisplace actorCurAndMaxSk <= 0
     || Ability.getSk Ability.SkMelee actorCurAndMaxSk <= 0
  then return $ Right ReqYell
  else failSer WaitUnskilled

-- * MoveDir and RunDir

moveRunHuman :: (MonadClient m, MonadClientUI m)
             => ActorId -> Bool -> Bool -> Bool -> Bool -> Vector
             -> m (FailOrCmd RequestTimed)
moveRunHuman :: forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
ActorId
-> Bool
-> Bool
-> Bool
-> Bool
-> Vector
-> m (FailOrCmd RequestTimed)
moveRunHuman ActorId
leader Bool
initialStep Bool
finalGoal Bool
run Bool
runAhead Vector
dir = do
  actorCurAndMaxSk <- (State -> Skills) -> m Skills
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Skills) -> m Skills) -> (State -> Skills) -> m Skills
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Skills
getActorMaxSkills ActorId
leader
  arena <- getArenaUI
  sb <- getsState $ getActorBody leader
  fact <- getsState $ (EM.! bfid sb) . sfactionD
  -- Start running in the given direction. The first turn of running
  -- succeeds much more often than subsequent turns, because we ignore
  -- most of the disturbances, since the player is mostly aware of them
  -- and still explicitly requests a run, knowing how it behaves.
  sel <- getsSession sselected
  let runMembers = if Bool
runAhead Bool -> Bool -> Bool
|| Faction -> Bool
noRunWithMulti Faction
fact
                   then [ActorId
leader]
                   else EnumSet ActorId -> [ActorId]
forall k. Enum k => EnumSet k -> [k]
ES.elems (ActorId -> EnumSet ActorId -> EnumSet ActorId
forall k. Enum k => k -> EnumSet k -> EnumSet k
ES.delete ActorId
leader EnumSet ActorId
sel) [ActorId] -> [ActorId] -> [ActorId]
forall a. [a] -> [a] -> [a]
++ [ActorId
leader]
      runParams = RunParams { runLeader :: ActorId
runLeader = ActorId
leader
                            , [ActorId]
runMembers :: [ActorId]
runMembers :: [ActorId]
runMembers
                            , runInitial :: Bool
runInitial = Bool
True
                            , runStopMsg :: Maybe Text
runStopMsg = Maybe Text
forall a. Maybe a
Nothing
                            , runWaiting :: Int
runWaiting = Int
0 }
      initRunning = Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
initialStep Bool -> Bool -> Bool
&& Bool
run) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        (SessionUI -> SessionUI) -> m ()
forall (m :: * -> *).
MonadClientUI m =>
(SessionUI -> SessionUI) -> m ()
modifySession ((SessionUI -> SessionUI) -> m ())
-> (SessionUI -> SessionUI) -> m ()
forall a b. (a -> b) -> a -> b
$ \SessionUI
sess ->
          SessionUI
sess {srunning = Just runParams}
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
runAhead (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ [String] -> m ()
forall (m :: * -> *). MonadClientUI m => [String] -> m ()
macroHuman [String]
macroRun25
  -- When running, the invisible actor is hit (not displaced!),
  -- so that running in the presence of roving invisible
  -- actors is equivalent to moving (with visible actors
  -- this is not a problem, since runnning stops early enough).
  let tpos = Actor -> Point
bpos Actor
sb Point -> Vector -> Point
`shift` Vector
dir
  -- We start by checking actors at the target position,
  -- which gives a partial information (actors can be invisible),
  -- as opposed to accessibility (and items) which are always accurate
  -- (tiles can't be invisible).
  tgts <- getsState $ posToAidAssocs tpos arena
  case tgts of
    [] -> do  -- move or search or alter
      runStopOrCmd <- ActorId -> Bool -> Vector -> m (FailOrCmd RequestTimed)
forall (m :: * -> *).
MonadClientUI m =>
ActorId -> Bool -> Vector -> m (FailOrCmd RequestTimed)
moveSearchAlter ActorId
leader Bool
run Vector
dir
      case runStopOrCmd of
        Left FailError
stopMsg -> FailOrCmd RequestTimed -> m (FailOrCmd RequestTimed)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FailOrCmd RequestTimed -> m (FailOrCmd RequestTimed))
-> FailOrCmd RequestTimed -> m (FailOrCmd RequestTimed)
forall a b. (a -> b) -> a -> b
$ FailError -> FailOrCmd RequestTimed
forall a b. a -> Either a b
Left FailError
stopMsg
        Right RequestTimed
runCmd -> do
          -- Don't check @initialStep@ and @finalGoal@
          -- and don't stop going to target: door opening is mundane enough.
          m ()
initRunning
          FailOrCmd RequestTimed -> m (FailOrCmd RequestTimed)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FailOrCmd RequestTimed -> m (FailOrCmd RequestTimed))
-> FailOrCmd RequestTimed -> m (FailOrCmd RequestTimed)
forall a b. (a -> b) -> a -> b
$ RequestTimed -> FailOrCmd RequestTimed
forall a b. b -> Either a b
Right RequestTimed
runCmd
    [(ActorId
target, Actor
_)] | Bool
run
                    Bool -> Bool -> Bool
&& Bool
initialStep
                    Bool -> Bool -> Bool
&& Skill -> Skills -> Int
Ability.getSk Skill
Ability.SkDisplace Skills
actorCurAndMaxSk Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 ->
      -- No @stopPlayBack@: initial displace is benign enough.
      -- Displacing requires accessibility, but it's checked later on.
      ActorId -> ActorId -> m (FailOrCmd RequestTimed)
forall (m :: * -> *).
MonadClientUI m =>
ActorId -> ActorId -> m (FailOrCmd RequestTimed)
displaceAid ActorId
leader ActorId
target
    (ActorId, Actor)
_ : (ActorId, Actor)
_ : [(ActorId, Actor)]
_ | Bool
run
                Bool -> Bool -> Bool
&& Bool
initialStep
                Bool -> Bool -> Bool
&& Skill -> Skills -> Int
Ability.getSk Skill
Ability.SkDisplace Skills
actorCurAndMaxSk Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 ->
      ReqFailure -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a.
MonadClientUI m =>
ReqFailure -> m (FailOrCmd a)
failSer ReqFailure
DisplaceMultiple
    (ActorId
target, Actor
tb) : [(ActorId, Actor)]
_ | Bool -> Bool
not Bool
run
                       Bool -> Bool -> Bool
&& Bool
initialStep Bool -> Bool -> Bool
&& Bool
finalGoal
                       Bool -> Bool -> Bool
&& Actor -> FactionId
bfid Actor
tb FactionId -> FactionId -> Bool
forall a. Eq a => a -> a -> Bool
== Actor -> FactionId
bfid Actor
sb Bool -> Bool -> Bool
&& Bool -> Bool
not (Actor -> Bool
bproj Actor
tb) -> do
      m ()
forall (m :: * -> *). MonadClientUI m => m ()
stopPlayBack  -- don't ever auto-repeat leader choice
      -- We always see actors from our own faction.
      -- Select one of adjacent actors by bumping into him. Takes no time.
      success <- Bool -> ActorId -> m Bool
forall (m :: * -> *). MonadClientUI m => Bool -> ActorId -> m Bool
pickLeader Bool
True ActorId
target
      let !_A = Bool -> () -> ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Bool
success Bool -> (String, (ActorId, ActorId, Actor)) -> Bool
forall v. Show v => Bool -> v -> Bool
`blame` String
"bump self"
                                String
-> (ActorId, ActorId, Actor) -> (String, (ActorId, ActorId, Actor))
forall v. String -> v -> (String, v)
`swith` (ActorId
leader, ActorId
target, Actor
tb)) ()
      failWith "the pointman switched by bumping"
    (ActorId
target, Actor
tb) : [(ActorId, Actor)]
_ | Bool -> Bool
not Bool
run
                       Bool -> Bool -> Bool
&& Bool
initialStep Bool -> Bool -> Bool
&& Bool
finalGoal
                       Bool -> Bool -> Bool
&& (Actor -> FactionId
bfid Actor
tb FactionId -> FactionId -> Bool
forall a. Eq a => a -> a -> Bool
/= Actor -> FactionId
bfid Actor
sb Bool -> Bool -> Bool
|| Actor -> Bool
bproj Actor
tb) -> do
      m ()
forall (m :: * -> *). MonadClientUI m => m ()
stopPlayBack  -- don't ever auto-repeat melee
      if Skill -> Skills -> Int
Ability.getSk Skill
Ability.SkMelee Skills
actorCurAndMaxSk Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
      then -- No problem if there are many projectiles at the spot. We just
           -- attack the first one.
           ActorId -> ActorId -> m (FailOrCmd RequestTimed)
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
ActorId -> ActorId -> m (FailOrCmd RequestTimed)
meleeAid ActorId
leader ActorId
target
      else ReqFailure -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a.
MonadClientUI m =>
ReqFailure -> m (FailOrCmd a)
failSer ReqFailure
MeleeUnskilled
    (ActorId, Actor)
_ : [(ActorId, Actor)]
_ -> Text -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith Text
"actor in the way"

-- | Actor attacks an enemy actor or his own projectile.
meleeAid :: (MonadClient m, MonadClientUI m)
         => ActorId -> ActorId -> m (FailOrCmd RequestTimed)
meleeAid :: forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
ActorId -> ActorId -> m (FailOrCmd RequestTimed)
meleeAid ActorId
leader ActorId
target = do
  side <- (StateClient -> FactionId) -> m FactionId
forall a. (StateClient -> a) -> m a
forall (m :: * -> *) a.
MonadClientRead m =>
(StateClient -> a) -> m a
getsClient StateClient -> FactionId
sside
  tb <- getsState $ getActorBody target
  sfact <- getsState $ (EM.! side) . sfactionD
  mel <- pickWeaponClient leader target
  case mel of
    Maybe RequestTimed
Nothing -> Text -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith Text
"nothing to melee with"
    Just RequestTimed
wp -> do
      let returnCmd :: m (FailOrCmd RequestTimed)
returnCmd = do
            -- Set personal target to enemy, so that AI, if it takes over
            -- the actor, is likely to continue the fight even if the foe flees.
            (StateClient -> StateClient) -> m ()
forall (m :: * -> *).
MonadClient m =>
(StateClient -> StateClient) -> m ()
modifyClient ((StateClient -> StateClient) -> m ())
-> (StateClient -> StateClient) -> m ()
forall a b. (a -> b) -> a -> b
$ ActorId
-> (Maybe Target -> Maybe Target) -> StateClient -> StateClient
updateTarget ActorId
leader ((Maybe Target -> Maybe Target) -> StateClient -> StateClient)
-> (Maybe Target -> Maybe Target) -> StateClient -> StateClient
forall a b. (a -> b) -> a -> b
$ Maybe Target -> Maybe Target -> Maybe Target
forall a b. a -> b -> a
const (Maybe Target -> Maybe Target -> Maybe Target)
-> Maybe Target -> Maybe Target -> Maybe Target
forall a b. (a -> b) -> a -> b
$ Target -> Maybe Target
forall a. a -> Maybe a
Just (Target -> Maybe Target) -> Target -> Maybe Target
forall a b. (a -> b) -> a -> b
$ ActorId -> Target
TEnemy ActorId
target
            -- Also set xhair to see the foe's HP, because it's automatically
            -- set to any new spotted actor, so it needs to be reset
            -- and also it's not useful as permanent ranged target anyway.
            (SessionUI -> SessionUI) -> m ()
forall (m :: * -> *).
MonadClientUI m =>
(SessionUI -> SessionUI) -> m ()
modifySession ((SessionUI -> SessionUI) -> m ())
-> (SessionUI -> SessionUI) -> m ()
forall a b. (a -> b) -> a -> b
$ \SessionUI
sess -> SessionUI
sess {sxhair = Just $ TEnemy target}
            FailOrCmd RequestTimed -> m (FailOrCmd RequestTimed)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FailOrCmd RequestTimed -> m (FailOrCmd RequestTimed))
-> FailOrCmd RequestTimed -> m (FailOrCmd RequestTimed)
forall a b. (a -> b) -> a -> b
$ RequestTimed -> FailOrCmd RequestTimed
forall a b. b -> Either a b
Right RequestTimed
wp
          res :: m (FailOrCmd RequestTimed)
res | Actor -> Bool
bproj Actor
tb Bool -> Bool -> Bool
|| FactionId -> Faction -> FactionId -> Bool
isFoe FactionId
side Faction
sfact (Actor -> FactionId
bfid Actor
tb) = m (FailOrCmd RequestTimed)
returnCmd
              | FactionId -> Faction -> FactionId -> Bool
isFriend FactionId
side Faction
sfact (Actor -> FactionId
bfid Actor
tb) = do
                let !_A :: ()
_A = Bool -> () -> ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (FactionId
side FactionId -> FactionId -> Bool
forall a. Eq a => a -> a -> Bool
/= Actor -> FactionId
bfid Actor
tb) ()
                go1 <- ColorMode -> Text -> m Bool
forall (m :: * -> *).
MonadClientUI m =>
ColorMode -> Text -> m Bool
displayYesNo ColorMode
ColorBW
                         Text
"You are bound by an alliance. Really attack?"
                if not go1 then failWith "attack canceled" else returnCmd
              | Bool
otherwise = do
                go2 <- ColorMode -> Text -> m Bool
forall (m :: * -> *).
MonadClientUI m =>
ColorMode -> Text -> m Bool
displayYesNo ColorMode
ColorBW
                         Text
"This attack will start a war. Are you sure?"
                if not go2 then failWith "attack canceled" else returnCmd
      m (FailOrCmd RequestTimed)
res
  -- Seeing the actor prevents altering a tile under it, but that
  -- does not limit the player, he just doesn't waste a turn
  -- on a failed altering.

-- | Actor swaps position with another.
displaceAid :: MonadClientUI m
            => ActorId -> ActorId -> m (FailOrCmd RequestTimed)
displaceAid :: forall (m :: * -> *).
MonadClientUI m =>
ActorId -> ActorId -> m (FailOrCmd RequestTimed)
displaceAid ActorId
leader ActorId
target = do
  COps{coTileSpeedup} <- (State -> COps) -> m COps
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  sb <- getsState $ getActorBody leader
  tb <- getsState $ getActorBody target
  tfact <- getsState $ (EM.! bfid tb) . sfactionD
  actorMaxSk <- getsState $ getActorMaxSkills target
  dEnemy <- getsState $ dispEnemy leader target actorMaxSk
  let immobile = Skill -> Skills -> Int
Ability.getSk Skill
Ability.SkMove Skills
actorMaxSk Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0
      tpos = Actor -> Point
bpos Actor
tb
      adj = Actor -> Actor -> Bool
checkAdjacent Actor
sb Actor
tb
      atWar = FactionId -> Faction -> FactionId -> Bool
isFoe (Actor -> FactionId
bfid Actor
tb) Faction
tfact (Actor -> FactionId
bfid Actor
sb)
  if | not adj -> failSer DisplaceDistant
     | not (bproj tb) && atWar
       && actorDying tb ->  -- checked separately for a better message
       failSer DisplaceDying
     | not (bproj tb) && atWar
       && actorWaits tb ->  -- checked separately for a better message
       failSer DisplaceBraced
     | not (bproj tb) && atWar
       && immobile ->  -- checked separately for a better message
       failSer DisplaceImmobile
     | not dEnemy && atWar ->
       failSer DisplaceSupported
     | otherwise -> do
       let lid = Actor -> LevelId
blid Actor
sb
       lvl <- getLevel lid
       -- Displacing requires full access.
       if Tile.isWalkable coTileSpeedup $ lvl `at` tpos then
         case posToAidsLvl tpos lvl of
           [] -> String -> m (FailOrCmd RequestTimed)
forall a. (?callStack::CallStack) => String -> a
error (String -> m (FailOrCmd RequestTimed))
-> String -> m (FailOrCmd RequestTimed)
forall a b. (a -> b) -> a -> b
$ String
"" String -> (ActorId, Actor, ActorId, Actor) -> String
forall v. Show v => String -> v -> String
`showFailure` (ActorId
leader, Actor
sb, ActorId
target, Actor
tb)
           [ActorId
_] -> FailOrCmd RequestTimed -> m (FailOrCmd RequestTimed)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FailOrCmd RequestTimed -> m (FailOrCmd RequestTimed))
-> FailOrCmd RequestTimed -> m (FailOrCmd RequestTimed)
forall a b. (a -> b) -> a -> b
$ RequestTimed -> FailOrCmd RequestTimed
forall a b. b -> Either a b
Right (RequestTimed -> FailOrCmd RequestTimed)
-> RequestTimed -> FailOrCmd RequestTimed
forall a b. (a -> b) -> a -> b
$ ActorId -> RequestTimed
ReqDisplace ActorId
target
           [ActorId]
_ -> ReqFailure -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a.
MonadClientUI m =>
ReqFailure -> m (FailOrCmd a)
failSer ReqFailure
DisplaceMultiple
       else failSer DisplaceAccess

-- | Leader moves or searches or alters. No visible actor at the position.
moveSearchAlter :: MonadClientUI m
                => ActorId -> Bool -> Vector -> m (FailOrCmd RequestTimed)
moveSearchAlter :: forall (m :: * -> *).
MonadClientUI m =>
ActorId -> Bool -> Vector -> m (FailOrCmd RequestTimed)
moveSearchAlter ActorId
leader Bool
run Vector
dir = do
  COps{coTileSpeedup} <- (State -> COps) -> m COps
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  actorCurAndMaxSk <- getsState $ getActorMaxSkills leader
  sb <- getsState $ getActorBody leader
  let moveSkill = Skill -> Skills -> Int
Ability.getSk Skill
Ability.SkMove Skills
actorCurAndMaxSk
      spos = Actor -> Point
bpos Actor
sb           -- source position
      tpos = Point
spos Point -> Vector -> Point
`shift` Vector
dir  -- target position
  alterable <- getsState $ tileAlterable (blid sb) tpos
  lvl <- getLevel $ blid sb
  let t = Level
lvl Level -> Point -> ContentId TileKind
`at` Point
tpos
  runStopOrCmd <-
    if Tile.isWalkable coTileSpeedup t then  -- Movement requires full access.
      if | moveSkill > 0 ->
             -- A potential invisible actor is hit. War started without asking.
             return $ Right $ ReqMove dir
         | bwatch sb == WSleep -> failSer MoveUnskilledAsleep
         | otherwise -> failSer MoveUnskilled
    else do  -- Not walkable, so search and/or alter the tile.
      let sxhair = Target -> Maybe Target
forall a. a -> Maybe a
Just (Target -> Maybe Target) -> Target -> Maybe Target
forall a b. (a -> b) -> a -> b
$ TGoal -> LevelId -> Point -> Target
TPoint TGoal
TUnknown (Actor -> LevelId
blid Actor
sb) Point
tpos
      -- Point xhair to see details with `~`.
      setXHairFromGUI sxhair
      if run then do
        -- Explicit request to examine the terrain.
        blurb <- lookAtPosition tpos (blid sb)
        mapM_ (uncurry msgAdd) blurb
        failWith $ "the terrain is" <+>
          if | Tile.isModifiable coTileSpeedup t -> "potentially modifiable"
             | alterable -> "potentially triggerable"
             | otherwise -> "completely inert"
      else alterCommon leader True tpos
  return $! runStopOrCmd

alterCommon :: MonadClientUI m
            => ActorId -> Bool -> Point -> m (FailOrCmd RequestTimed)
alterCommon :: forall (m :: * -> *).
MonadClientUI m =>
ActorId -> Bool -> Point -> m (FailOrCmd RequestTimed)
alterCommon ActorId
leader Bool
bumping Point
tpos = do
  CCUI{coscreen=ScreenContent{rwidth}} <- (SessionUI -> CCUI) -> m CCUI
forall a. (SessionUI -> a) -> m a
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> CCUI
sccui
  cops@COps{cotile, coTileSpeedup} <- getsState scops
  side <- getsClient sside
  factionD <- getsState sfactionD
  actorCurAndMaxSk <- getsState $ getActorMaxSkills leader
  sb <- getsState $ getActorBody leader
  let alterSkill = Skill -> Skills -> Int
Ability.getSk Skill
Ability.SkAlter Skills
actorCurAndMaxSk
      spos = Actor -> Point
bpos Actor
sb
  alterable <- getsState $ tileAlterable (blid sb) tpos
  lvl <- getLevel $ blid sb
  localTime <- getsState $ getLocalTime (blid sb)
  embeds <- getsState $ getEmbedBag (blid sb) tpos
  itemToF <- getsState $ flip itemToFull
  getKind <- getsState $ flip getIidKind
  let t = Level
lvl Level -> Point -> ContentId TileKind
`at` Point
tpos
      underFeet = Point
tpos Point -> Point -> Bool
forall a. Eq a => a -> a -> Bool
== Point
spos  -- if enter and alter, be more permissive
      modificationFailureHint = MsgClassShowAndSave -> Text -> m ()
forall (m :: * -> *) a.
(MonadClientUI m, MsgShared a) =>
a -> Text -> m ()
msgAdd MsgClassShowAndSave
MsgTutorialHint Text
"Some doors can be opened, stairs unbarred, treasures recovered, only if you find tools that increase your terrain modification ability and act as keys to the puzzle. To gather clues about the keys, listen to what's around you, examine items, inspect terrain, trigger, bump and harass. Once you uncover a likely tool, wield it, return and try to break through again."
  if | not alterable -> do
         let name = Text -> Part
MU.Text (Text -> Part) -> Text -> Part
forall a b. (a -> b) -> a -> b
$ TileKind -> Text
TK.tname (TileKind -> Text) -> TileKind -> Text
forall a b. (a -> b) -> a -> b
$ ContentData TileKind -> ContentId TileKind -> TileKind
forall a. ContentData a -> ContentId a -> a
okind ContentData TileKind
cotile ContentId TileKind
t
             itemLook (ItemId
iid, kit :: (Int, ItemTimers)
kit@(Int
k, ItemTimers
_)) =
               let itemFull :: ItemFull
itemFull = ItemId -> ItemFull
itemToF ItemId
iid
               in Int
-> FactionId
-> EnumMap FactionId Faction
-> Int
-> Time
-> ItemFull
-> (Int, ItemTimers)
-> Part
partItemWsShort Int
rwidth FactionId
side EnumMap FactionId Faction
factionD Int
k Time
localTime ItemFull
itemFull (Int, ItemTimers)
kit
             embedKindList =
               ((ItemId, (Int, ItemTimers))
 -> (ItemKind, (ItemId, (Int, ItemTimers))))
-> [(ItemId, (Int, ItemTimers))]
-> [(ItemKind, (ItemId, (Int, ItemTimers)))]
forall a b. (a -> b) -> [a] -> [b]
map (\(ItemId
iid, (Int, ItemTimers)
kit) -> (ItemId -> ItemKind
getKind ItemId
iid, (ItemId
iid, (Int, ItemTimers)
kit))) (ItemBag -> [(ItemId, (Int, ItemTimers))]
forall k a. Enum k => EnumMap k a -> [(k, a)]
EM.assocs ItemBag
embeds)
             ilooks = ((ItemId, (Int, ItemTimers)) -> Part)
-> [(ItemId, (Int, ItemTimers))] -> [Part]
forall a b. (a -> b) -> [a] -> [b]
map (ItemId, (Int, ItemTimers)) -> Part
itemLook ([(ItemId, (Int, ItemTimers))] -> [Part])
-> [(ItemId, (Int, ItemTimers))] -> [Part]
forall a b. (a -> b) -> a -> b
$ COps
-> ContentId TileKind
-> [(ItemKind, (ItemId, (Int, ItemTimers)))]
-> [(ItemId, (Int, ItemTimers))]
sortEmbeds COps
cops ContentId TileKind
t [(ItemKind, (ItemId, (Int, ItemTimers)))]
embedKindList
         failWith $ makePhrase $
           ["there is no way to activate or modify", MU.AW name]
           ++ if EM.null embeds
              then []
              else ["with", MU.WWandW ilooks]
           -- misclick? related to AlterNothing but no searching possible;
           -- this also rules out activating embeds that only cause
           -- raw damage, with no chance of altering the tile
     | Tile.isSuspect coTileSpeedup t
       && not underFeet
       && alterSkill <= 1 -> do
         modificationFailureHint
         failSer AlterUnskilled
     | not (Tile.isSuspect coTileSpeedup t)
       && not underFeet
       && alterSkill < Tile.alterMinSkill coTileSpeedup t -> do
         -- Rather rare (requires high skill), so describe the tile.
         blurb <- lookAtPosition tpos (blid sb)
         mapM_ (uncurry msgAdd) blurb
         modificationFailureHint
         failSer AlterUnwalked
     | chessDist tpos (bpos sb) > 1 ->
         -- Checked late to give useful info about distant tiles.
         failSer AlterDistant
     | not underFeet
       && (occupiedBigLvl tpos lvl || occupiedProjLvl tpos lvl) ->
         -- Don't mislead describing terrain, if other actor is to blame.
         failSer AlterBlockActor
     | otherwise -> do  -- promising
         verAlters <- verifyAlters leader bumping tpos
         case verAlters of
           Right () ->
             if Bool
bumping then
               FailOrCmd RequestTimed -> m (FailOrCmd RequestTimed)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FailOrCmd RequestTimed -> m (FailOrCmd RequestTimed))
-> FailOrCmd RequestTimed -> m (FailOrCmd RequestTimed)
forall a b. (a -> b) -> a -> b
$ RequestTimed -> FailOrCmd RequestTimed
forall a b. b -> Either a b
Right (RequestTimed -> FailOrCmd RequestTimed)
-> RequestTimed -> FailOrCmd RequestTimed
forall a b. (a -> b) -> a -> b
$ Vector -> RequestTimed
ReqMove (Vector -> RequestTimed) -> Vector -> RequestTimed
forall a b. (a -> b) -> a -> b
$ Point -> Point -> Vector
vectorToFrom Point
tpos Point
spos
             else do
               Bool -> ActorId -> Point -> Text -> m ()
forall (m :: * -> *).
MonadClientUI m =>
Bool -> ActorId -> Point -> Text -> m ()
msgAddDone Bool
False ActorId
leader Point
tpos Text
"modify"
               FailOrCmd RequestTimed -> m (FailOrCmd RequestTimed)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FailOrCmd RequestTimed -> m (FailOrCmd RequestTimed))
-> FailOrCmd RequestTimed -> m (FailOrCmd RequestTimed)
forall a b. (a -> b) -> a -> b
$ RequestTimed -> FailOrCmd RequestTimed
forall a b. b -> Either a b
Right (RequestTimed -> FailOrCmd RequestTimed)
-> RequestTimed -> FailOrCmd RequestTimed
forall a b. (a -> b) -> a -> b
$ Point -> RequestTimed
ReqAlter Point
tpos
           Left FailError
err -> FailOrCmd RequestTimed -> m (FailOrCmd RequestTimed)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FailOrCmd RequestTimed -> m (FailOrCmd RequestTimed))
-> FailOrCmd RequestTimed -> m (FailOrCmd RequestTimed)
forall a b. (a -> b) -> a -> b
$ FailError -> FailOrCmd RequestTimed
forall a b. a -> Either a b
Left FailError
err
         -- Even when bumping, we don't use ReqMove, because we don't want
         -- to hit invisible actors, e.g., hidden in a wall.
         -- If server performed an attack for free
         -- on the invisible actor anyway, the player (or AI)
         -- would be tempted to repeatedly hit random walls
         -- in hopes of killing a monster residing within.
         -- If the action had a cost, misclicks would incur the cost, too.
         -- Right now the player may repeatedly alter tiles trying to learn
         -- about invisible pass-wall actors, but when an actor detected,
         -- it costs a turn and does not harm the invisible actors,
         -- so it's not so tempting.

-- * RunOnceAhead

runOnceAheadHuman :: MonadClientUI m
                  => ActorId -> m (Either MError RequestTimed)
runOnceAheadHuman :: forall (m :: * -> *).
MonadClientUI m =>
ActorId -> m (Either MError RequestTimed)
runOnceAheadHuman ActorId
leader = do
  side <- (StateClient -> FactionId) -> m FactionId
forall a. (StateClient -> a) -> m a
forall (m :: * -> *) a.
MonadClientRead m =>
(StateClient -> a) -> m a
getsClient StateClient -> FactionId
sside
  fact <- getsState $ (EM.! side) . sfactionD
  keyPressed <- anyKeyPressed
  srunning <- getsSession srunning
  -- When running, stop if disturbed. If not running, stop at once.
  case srunning of
    Maybe RunParams
Nothing -> do
      MsgClassIgnore -> Text -> m ()
forall (m :: * -> *) a.
(MonadClientUI m, MsgShared a) =>
a -> Text -> m ()
msgAdd MsgClassIgnore
MsgRunStopReason Text
"run stop: nothing to do"
      Either MError RequestTimed -> m (Either MError RequestTimed)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either MError RequestTimed -> m (Either MError RequestTimed))
-> Either MError RequestTimed -> m (Either MError RequestTimed)
forall a b. (a -> b) -> a -> b
$ MError -> Either MError RequestTimed
forall a b. a -> Either a b
Left MError
forall a. Maybe a
Nothing
    Just RunParams{[ActorId]
runMembers :: RunParams -> [ActorId]
runMembers :: [ActorId]
runMembers}
      | Faction -> Bool
noRunWithMulti Faction
fact Bool -> Bool -> Bool
&& [ActorId]
runMembers [ActorId] -> [ActorId] -> Bool
forall a. Eq a => a -> a -> Bool
/= [ActorId
leader] -> do
      MsgClassIgnore -> Text -> m ()
forall (m :: * -> *) a.
(MonadClientUI m, MsgShared a) =>
a -> Text -> m ()
msgAdd MsgClassIgnore
MsgRunStopReason Text
"run stop: automatic pointman change"
      Either MError RequestTimed -> m (Either MError RequestTimed)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either MError RequestTimed -> m (Either MError RequestTimed))
-> Either MError RequestTimed -> m (Either MError RequestTimed)
forall a b. (a -> b) -> a -> b
$ MError -> Either MError RequestTimed
forall a b. a -> Either a b
Left MError
forall a. Maybe a
Nothing
    Just RunParams
_runParams | Bool
keyPressed -> do
      m ()
forall (m :: * -> *). MonadClientUI m => m ()
discardPressedKey
      MsgClassIgnore -> Text -> m ()
forall (m :: * -> *) a.
(MonadClientUI m, MsgShared a) =>
a -> Text -> m ()
msgAdd MsgClassIgnore
MsgRunStopReason Text
"run stop: key pressed"
      FailOrCmd RequestTimed -> Either MError RequestTimed
forall a. FailOrCmd a -> Either MError a
weaveJust (FailOrCmd RequestTimed -> Either MError RequestTimed)
-> m (FailOrCmd RequestTimed) -> m (Either MError RequestTimed)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith Text
"interrupted"
    Just RunParams
runParams -> do
      arena <- m LevelId
forall (m :: * -> *). MonadClientUI m => m LevelId
getArenaUI
      runOutcome <- continueRun arena runParams
      case runOutcome of
        Left Text
stopMsg -> do
          MsgClassIgnore -> Text -> m ()
forall (m :: * -> *) a.
(MonadClientUI m, MsgShared a) =>
a -> Text -> m ()
msgAdd MsgClassIgnore
MsgRunStopReason (Text
"run stop:" Text -> Text -> Text
<+> Text
stopMsg)
          Either MError RequestTimed -> m (Either MError RequestTimed)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either MError RequestTimed -> m (Either MError RequestTimed))
-> Either MError RequestTimed -> m (Either MError RequestTimed)
forall a b. (a -> b) -> a -> b
$ MError -> Either MError RequestTimed
forall a b. a -> Either a b
Left MError
forall a. Maybe a
Nothing
        Right RequestTimed
runCmd ->
          Either MError RequestTimed -> m (Either MError RequestTimed)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either MError RequestTimed -> m (Either MError RequestTimed))
-> Either MError RequestTimed -> m (Either MError RequestTimed)
forall a b. (a -> b) -> a -> b
$ RequestTimed -> Either MError RequestTimed
forall a b. b -> Either a b
Right RequestTimed
runCmd

-- * MoveOnceToXhair

moveOnceToXhairHuman :: (MonadClient m, MonadClientUI m)
                     => ActorId -> m (FailOrCmd RequestTimed)
moveOnceToXhairHuman :: forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
ActorId -> m (FailOrCmd RequestTimed)
moveOnceToXhairHuman ActorId
leader = ActorId -> Bool -> Bool -> m (FailOrCmd RequestTimed)
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
ActorId -> Bool -> Bool -> m (FailOrCmd RequestTimed)
goToXhair ActorId
leader Bool
True Bool
False

goToXhair :: (MonadClient m, MonadClientUI m)
          => ActorId -> Bool -> Bool -> m (FailOrCmd RequestTimed)
goToXhair :: forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
ActorId -> Bool -> Bool -> m (FailOrCmd RequestTimed)
goToXhair ActorId
leader Bool
initialStep Bool
run = do
  aimMode <- (SessionUI -> Maybe AimMode) -> m (Maybe AimMode)
forall a. (SessionUI -> a) -> m a
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> Maybe AimMode
saimMode
  -- Movement is legal only outside aiming mode.
  if isJust aimMode
  then failWith "cannot move in aiming mode"
  else goToXhairExplorationMode leader initialStep run

goToXhairExplorationMode :: (MonadClient m, MonadClientUI m)
                         => ActorId -> Bool -> Bool
                         -> m (FailOrCmd RequestTimed)
goToXhairExplorationMode :: forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
ActorId -> Bool -> Bool -> m (FailOrCmd RequestTimed)
goToXhairExplorationMode ActorId
leader Bool
initialStep Bool
run = do
  actorCurAndMaxSk <- (State -> Skills) -> m Skills
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Skills) -> m Skills) -> (State -> Skills) -> m Skills
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Skills
getActorMaxSkills ActorId
leader
  sb <- getsState $ getActorBody leader
  let moveSkill = Skill -> Skills -> Int
Ability.getSk Skill
Ability.SkMove Skills
actorCurAndMaxSk
  -- If skill is too low, no path in @Bfs@ is going to be found,
  -- but we check the skill (and sleep) to give a more accurate message.
  if | moveSkill > 0 -> do
       xhair <- getsSession sxhair
       xhairGoTo <- getsSession sxhairGoTo
       mfail <-
         if isJust xhairGoTo && xhairGoTo /= xhair
         then failWith "crosshair position changed"
         else do
           when (isNothing xhairGoTo) $  -- set it up for next steps
             modifySession $ \SessionUI
sess -> SessionUI
sess {sxhairGoTo = xhair}
           goToXhairGoTo leader initialStep run
       when (isLeft mfail) $
         modifySession $ \SessionUI
sess -> SessionUI
sess {sxhairGoTo = Nothing}
       return mfail
     | bwatch sb == WSleep -> failSer MoveUnskilledAsleep
     | otherwise -> failSer MoveUnskilled

goToXhairGoTo :: (MonadClient m, MonadClientUI m)
              => ActorId -> Bool -> Bool -> m (FailOrCmd RequestTimed)
goToXhairGoTo :: forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
ActorId -> Bool -> Bool -> m (FailOrCmd RequestTimed)
goToXhairGoTo ActorId
leader Bool
initialStep Bool
run = do
  b <- (State -> Actor) -> m Actor
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
leader
  mxhairPos <- mxhairToPos
  case mxhairPos of
    Maybe Point
Nothing -> Text -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith Text
"crosshair position invalid"
    Just Point
c -> do
      running <- (SessionUI -> Maybe RunParams) -> m (Maybe RunParams)
forall a. (SessionUI -> a) -> m a
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> Maybe RunParams
srunning
      case running of
        -- Don't use running params from previous run or goto-xhair.
        Just RunParams
paramOld | Bool -> Bool
not Bool
initialStep -> do
          arena <- m LevelId
forall (m :: * -> *). MonadClientUI m => m LevelId
getArenaUI
          runOutcome <- multiActorGoTo arena c paramOld
          case runOutcome of
            Left FailError
stopMsg -> FailOrCmd RequestTimed -> m (FailOrCmd RequestTimed)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FailOrCmd RequestTimed -> m (FailOrCmd RequestTimed))
-> FailOrCmd RequestTimed -> m (FailOrCmd RequestTimed)
forall a b. (a -> b) -> a -> b
$ FailError -> FailOrCmd RequestTimed
forall a b. a -> Either a b
Left FailError
stopMsg
            Right (Bool
finalGoal, Vector
dir) ->
              ActorId
-> Bool
-> Bool
-> Bool
-> Bool
-> Vector
-> m (FailOrCmd RequestTimed)
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
ActorId
-> Bool
-> Bool
-> Bool
-> Bool
-> Vector
-> m (FailOrCmd RequestTimed)
moveRunHuman ActorId
leader Bool
initialStep Bool
finalGoal Bool
run Bool
False Vector
dir
        Maybe RunParams
_ | Point
c Point -> Point -> Bool
forall a. Eq a => a -> a -> Bool
== Actor -> Point
bpos Actor
b -> Text -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith Text
"position reached"
        Maybe RunParams
_ -> do
          let !_A :: ()
_A = Bool -> () -> ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Bool
initialStep Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
run) ()
          (bfs, mpath) <- ActorId -> Point -> m (Array BfsDistance, Maybe AndPath)
forall (m :: * -> *).
MonadClient m =>
ActorId -> Point -> m (Array BfsDistance, Maybe AndPath)
getCacheBfsAndPath ActorId
leader Point
c
          xhairMoused <- getsSession sxhairMoused
          case mpath of
            Maybe AndPath
_ | Bool
xhairMoused Bool -> Bool -> Bool
&& Maybe Int -> Bool
forall a. Maybe a -> Bool
isNothing (Array BfsDistance -> Point -> Maybe Int
accessBfs Array BfsDistance
bfs Point
c) ->
              Text -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith
                Text
"no route to crosshair (press again to go there anyway)"
            Maybe AndPath
_ | Bool
initialStep Bool -> Bool -> Bool
&& Point -> Point -> Bool
adjacent (Actor -> Point
bpos Actor
b) Point
c -> do
              let dir :: Vector
dir = Point -> Point -> Vector
towards (Actor -> Point
bpos Actor
b) Point
c
              ActorId
-> Bool
-> Bool
-> Bool
-> Bool
-> Vector
-> m (FailOrCmd RequestTimed)
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
ActorId
-> Bool
-> Bool
-> Bool
-> Bool
-> Vector
-> m (FailOrCmd RequestTimed)
moveRunHuman ActorId
leader Bool
initialStep Bool
True Bool
run Bool
False Vector
dir
            Maybe AndPath
Nothing -> Text -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith Text
"no route to crosshair"
            Just AndPath{pathList :: AndPath -> [Point]
pathList=[]} -> Text -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith Text
"almost there"
            Just AndPath{pathList :: AndPath -> [Point]
pathList = Point
p1 : [Point]
_} -> do
              let finalGoal :: Bool
finalGoal = Point
p1 Point -> Point -> Bool
forall a. Eq a => a -> a -> Bool
== Point
c
                  dir :: Vector
dir = Point -> Point -> Vector
towards (Actor -> Point
bpos Actor
b) Point
p1
              ActorId
-> Bool
-> Bool
-> Bool
-> Bool
-> Vector
-> m (FailOrCmd RequestTimed)
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
ActorId
-> Bool
-> Bool
-> Bool
-> Bool
-> Vector
-> m (FailOrCmd RequestTimed)
moveRunHuman ActorId
leader Bool
initialStep Bool
finalGoal Bool
run Bool
False Vector
dir

multiActorGoTo :: (MonadClient m, MonadClientUI m)
               => LevelId -> Point -> RunParams -> m (FailOrCmd (Bool, Vector))
multiActorGoTo :: forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
LevelId -> Point -> RunParams -> m (FailOrCmd (Bool, Vector))
multiActorGoTo LevelId
arena Point
c RunParams
paramOld =
  case RunParams
paramOld of
    RunParams{runMembers :: RunParams -> [ActorId]
runMembers = []} -> Text -> m (FailOrCmd (Bool, Vector))
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith Text
"selected actors no longer there"
    RunParams{runMembers :: RunParams -> [ActorId]
runMembers = ActorId
r : [ActorId]
rs, Int
runWaiting :: RunParams -> Int
runWaiting :: Int
runWaiting} -> do
      onLevel <- (State -> Bool) -> m Bool
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Bool) -> m Bool) -> (State -> Bool) -> m Bool
forall a b. (a -> b) -> a -> b
$ ActorId -> LevelId -> State -> Bool
memActor ActorId
r LevelId
arena
      b <- getsState $ getActorBody r
      mxhairPos <- mxhairToPos
      if not onLevel || mxhairPos == Just (bpos b) then do
        let paramNew = RunParams
paramOld {runMembers = rs}
        multiActorGoTo arena c paramNew
      else do
        sL <- getState
        modifyClient $ updateLeader r sL
        let runMembersNew = [ActorId]
rs [ActorId] -> [ActorId] -> [ActorId]
forall a. [a] -> [a] -> [a]
++ [ActorId
r]
            paramNew = RunParams
paramOld { runMembers = runMembersNew
                                , runWaiting = 0}
        (bfs, mpath) <- getCacheBfsAndPath r c
        xhairMoused <- getsSession sxhairMoused
        case mpath of
          Maybe AndPath
_ | Bool
xhairMoused Bool -> Bool -> Bool
&& Maybe Int -> Bool
forall a. Maybe a -> Bool
isNothing (Array BfsDistance -> Point -> Maybe Int
accessBfs Array BfsDistance
bfs Point
c) ->
            Text -> m (FailOrCmd (Bool, Vector))
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith Text
"no route to crosshair (press again to go there anyway)"
          Maybe AndPath
Nothing -> Text -> m (FailOrCmd (Bool, Vector))
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith Text
"no route to crosshair"
          Just AndPath{pathList :: AndPath -> [Point]
pathList=[]} -> Text -> m (FailOrCmd (Bool, Vector))
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith Text
"almost there"
          Just AndPath{pathList :: AndPath -> [Point]
pathList = Point
p1 : [Point]
_} -> do
            let finalGoal :: Bool
finalGoal = Point
p1 Point -> Point -> Bool
forall a. Eq a => a -> a -> Bool
== Point
c
                dir :: Vector
dir = Point -> Point -> Vector
towards (Actor -> Point
bpos Actor
b) Point
p1
            tgts <- (State -> [ActorId]) -> m [ActorId]
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> [ActorId]) -> m [ActorId])
-> (State -> [ActorId]) -> m [ActorId]
forall a b. (a -> b) -> a -> b
$ Point -> LevelId -> State -> [ActorId]
posToAids Point
p1 LevelId
arena
            case tgts of
              [] -> do
                (SessionUI -> SessionUI) -> m ()
forall (m :: * -> *).
MonadClientUI m =>
(SessionUI -> SessionUI) -> m ()
modifySession ((SessionUI -> SessionUI) -> m ())
-> (SessionUI -> SessionUI) -> m ()
forall a b. (a -> b) -> a -> b
$ \SessionUI
sess -> SessionUI
sess {srunning = Just paramNew}
                FailOrCmd (Bool, Vector) -> m (FailOrCmd (Bool, Vector))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FailOrCmd (Bool, Vector) -> m (FailOrCmd (Bool, Vector)))
-> FailOrCmd (Bool, Vector) -> m (FailOrCmd (Bool, Vector))
forall a b. (a -> b) -> a -> b
$ (Bool, Vector) -> FailOrCmd (Bool, Vector)
forall a b. b -> Either a b
Right (Bool
finalGoal, Vector
dir)
              [ActorId
target] | ActorId
target ActorId -> [ActorId] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ActorId]
rs Bool -> Bool -> Bool
|| Int
runWaiting Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= [ActorId] -> Int
forall a. [a] -> Int
length [ActorId]
rs ->
                -- Let r wait until all others move. Mark it in runWaiting
                -- to avoid cycles. When all wait for each other, fail.
                LevelId -> Point -> RunParams -> m (FailOrCmd (Bool, Vector))
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
LevelId -> Point -> RunParams -> m (FailOrCmd (Bool, Vector))
multiActorGoTo LevelId
arena Point
c RunParams
paramNew{runWaiting=runWaiting + 1}
              [ActorId]
_ ->
                Text -> m (FailOrCmd (Bool, Vector))
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith Text
"collective running finished"  -- usually OK

-- * RunOnceToXhair

runOnceToXhairHuman :: (MonadClient m, MonadClientUI m)
                    => ActorId -> m (FailOrCmd RequestTimed)
runOnceToXhairHuman :: forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
ActorId -> m (FailOrCmd RequestTimed)
runOnceToXhairHuman ActorId
leader = ActorId -> Bool -> Bool -> m (FailOrCmd RequestTimed)
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
ActorId -> Bool -> Bool -> m (FailOrCmd RequestTimed)
goToXhair ActorId
leader Bool
True Bool
True

-- * ContinueToXhair

continueToXhairHuman :: (MonadClient m, MonadClientUI m)
                     => ActorId -> m (FailOrCmd RequestTimed)
continueToXhairHuman :: forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
ActorId -> m (FailOrCmd RequestTimed)
continueToXhairHuman ActorId
leader = ActorId -> Bool -> Bool -> m (FailOrCmd RequestTimed)
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
ActorId -> Bool -> Bool -> m (FailOrCmd RequestTimed)
goToXhair ActorId
leader Bool
False Bool
False{-irrelevant-}

-- * MoveItem

moveItemHuman :: forall m. MonadClientUI m
              => ActorId -> [CStore] -> CStore -> Maybe Text -> Bool
              -> m (FailOrCmd RequestTimed)
moveItemHuman :: forall (m :: * -> *).
MonadClientUI m =>
ActorId
-> [CStore]
-> CStore
-> Maybe Text
-> Bool
-> m (FailOrCmd RequestTimed)
moveItemHuman ActorId
leader [CStore]
stores CStore
destCStore Maybe Text
mverb Bool
auto = do
  let !_A :: ()
_A = Bool -> () -> ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (CStore
destCStore CStore -> [CStore] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [CStore]
stores) ()
  actorCurAndMaxSk <- (State -> Skills) -> m Skills
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Skills) -> m Skills) -> (State -> Skills) -> m Skills
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Skills
getActorMaxSkills ActorId
leader
  if Ability.getSk Ability.SkMoveItem actorCurAndMaxSk > 0
  then moveOrSelectItem leader stores destCStore mverb auto
  else failSer MoveItemUnskilled

-- This cannot be structured as projecting or applying, with @ByItemMode@
-- and @ChooseItemToMove@, because at least in case of grabbing items,
-- more than one item is chosen, which doesn't fit @sitemSel@. Separating
-- grabbing of multiple items as a distinct command is too high a price.
moveOrSelectItem :: forall m. MonadClientUI m
                 => ActorId -> [CStore] -> CStore -> Maybe Text -> Bool
                 -> m (FailOrCmd RequestTimed)
moveOrSelectItem :: forall (m :: * -> *).
MonadClientUI m =>
ActorId
-> [CStore]
-> CStore
-> Maybe Text
-> Bool
-> m (FailOrCmd RequestTimed)
moveOrSelectItem ActorId
leader [CStore]
storesRaw CStore
destCStore Maybe Text
mverb Bool
auto = do
  b <- (State -> Actor) -> m Actor
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
leader
  actorCurAndMaxSk <- getsState $ getActorMaxSkills leader
  mstash <- getsState $ \State
s -> Faction -> Maybe (LevelId, Point)
gstash (Faction -> Maybe (LevelId, Point))
-> Faction -> Maybe (LevelId, Point)
forall a b. (a -> b) -> a -> b
$ State -> EnumMap FactionId Faction
sfactionD State
s EnumMap FactionId Faction -> FactionId -> Faction
forall k a. Enum k => EnumMap k a -> k -> a
EM.! Actor -> FactionId
bfid Actor
b
  let calmE = Actor -> Skills -> Bool
calmEnough Actor
b Skills
actorCurAndMaxSk
      overStash = Maybe (LevelId, Point)
mstash Maybe (LevelId, Point) -> Maybe (LevelId, Point) -> Bool
forall a. Eq a => a -> a -> Bool
== (LevelId, Point) -> Maybe (LevelId, Point)
forall a. a -> Maybe a
Just (Actor -> LevelId
blid Actor
b, Actor -> Point
bpos Actor
b)
      stores = case [CStore]
storesRaw of
        CStore
CEqp : rest :: [CStore]
rest@(CStore
_ : [CStore]
_) | Bool -> Bool
not Bool
calmE -> [CStore]
rest [CStore] -> [CStore] -> [CStore]
forall a. [a] -> [a] -> [a]
++ [CStore
CEqp]
        CStore
CGround : rest :: [CStore]
rest@(CStore
_ : [CStore]
_) | Bool
overStash -> [CStore]
rest [CStore] -> [CStore] -> [CStore]
forall a. [a] -> [a] -> [a]
++ [CStore
CGround]
        [CStore]
_ -> [CStore]
storesRaw
  itemSel <- getsSession sitemSel
  modifySession $ \SessionUI
sess -> SessionUI
sess {sitemSel = Nothing}  -- prevent surprise
  case itemSel of
    Maybe (ItemId, CStore, Bool)
_ | [CStore]
stores [CStore] -> [CStore] -> Bool
forall a. Eq a => a -> a -> Bool
== [CStore
CGround] Bool -> Bool -> Bool
&& Bool
overStash ->
      Text -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith Text
"you can't loot items from your own stash"
    Just (ItemId
_, fromCStore :: CStore
fromCStore@CStore
CEqp, Bool
_) | CStore
fromCStore CStore -> CStore -> Bool
forall a. Eq a => a -> a -> Bool
/= CStore
destCStore
                                   Bool -> Bool -> Bool
&& CStore
fromCStore CStore -> [CStore] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CStore]
stores
                                   Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
calmE ->
      Text -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith Text
"neither the selected item nor any other can be unequipped"
    Just (ItemId
_, fromCStore :: CStore
fromCStore@CStore
CGround, Bool
_) | CStore
fromCStore CStore -> CStore -> Bool
forall a. Eq a => a -> a -> Bool
/= CStore
destCStore
                                      Bool -> Bool -> Bool
&& CStore
fromCStore CStore -> [CStore] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CStore]
stores
                                      Bool -> Bool -> Bool
&& Bool
overStash ->
      Text -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith Text
"you vainly paw through your own hoard"
    Just (ItemId
iid, CStore
fromCStore, Bool
_) | CStore
fromCStore CStore -> CStore -> Bool
forall a. Eq a => a -> a -> Bool
/= CStore
destCStore
                                Bool -> Bool -> Bool
&& CStore
fromCStore CStore -> [CStore] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CStore]
stores -> do
      bag <- (State -> ItemBag) -> m ItemBag
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> ItemBag) -> m ItemBag)
-> (State -> ItemBag) -> m ItemBag
forall a b. (a -> b) -> a -> b
$ Actor -> CStore -> State -> ItemBag
getBodyStoreBag Actor
b CStore
fromCStore
      case iid `EM.lookup` bag of
        Maybe (Int, ItemTimers)
Nothing ->  -- the case of old selection or selection from another actor
          ActorId
-> [CStore]
-> CStore
-> Maybe Text
-> Bool
-> m (FailOrCmd RequestTimed)
forall (m :: * -> *).
MonadClientUI m =>
ActorId
-> [CStore]
-> CStore
-> Maybe Text
-> Bool
-> m (FailOrCmd RequestTimed)
moveOrSelectItem ActorId
leader [CStore]
stores CStore
destCStore Maybe Text
mverb Bool
auto
        Just (Int
k, ItemTimers
it) -> Bool -> m (FailOrCmd RequestTimed) -> m (FailOrCmd RequestTimed)
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (m (FailOrCmd RequestTimed) -> m (FailOrCmd RequestTimed))
-> m (FailOrCmd RequestTimed) -> m (FailOrCmd RequestTimed)
forall a b. (a -> b) -> a -> b
$ do
          let eqpFree :: Int
eqpFree = Actor -> Int
eqpFreeN Actor
b
              kToPick :: Int
kToPick | CStore
destCStore CStore -> CStore -> Bool
forall a. Eq a => a -> a -> Bool
== CStore
CEqp = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
eqpFree Int
k
                      | Bool
otherwise = Int
k
          if | CStore
destCStore CStore -> CStore -> Bool
forall a. Eq a => a -> a -> Bool
== CStore
CEqp Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
calmE -> ReqFailure -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a.
MonadClientUI m =>
ReqFailure -> m (FailOrCmd a)
failSer ReqFailure
ItemNotCalm
             | CStore
destCStore CStore -> CStore -> Bool
forall a. Eq a => a -> a -> Bool
== CStore
CGround Bool -> Bool -> Bool
&& Bool
overStash -> ReqFailure -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a.
MonadClientUI m =>
ReqFailure -> m (FailOrCmd a)
failSer ReqFailure
ItemOverStash
             | Int
kToPick Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 -> Text -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith Text
"no more items can be equipped"
             | Bool
otherwise -> do
               socK <- Bool -> Int -> m (Either MError Int)
forall (m :: * -> *).
MonadClientUI m =>
Bool -> Int -> m (Either MError Int)
pickNumber (Bool -> Bool
not Bool
auto) Int
kToPick
               case socK of
                 Left MError
Nothing ->
                   ActorId
-> [CStore]
-> CStore
-> Maybe Text
-> Bool
-> m (FailOrCmd RequestTimed)
forall (m :: * -> *).
MonadClientUI m =>
ActorId
-> [CStore]
-> CStore
-> Maybe Text
-> Bool
-> m (FailOrCmd RequestTimed)
moveOrSelectItem ActorId
leader [CStore]
stores CStore
destCStore Maybe Text
mverb Bool
auto
                 Left (Just FailError
err) -> FailOrCmd RequestTimed -> m (FailOrCmd RequestTimed)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FailOrCmd RequestTimed -> m (FailOrCmd RequestTimed))
-> FailOrCmd RequestTimed -> m (FailOrCmd RequestTimed)
forall a b. (a -> b) -> a -> b
$ FailError -> FailOrCmd RequestTimed
forall a b. a -> Either a b
Left FailError
err
                 Right Int
kChosen ->
                   let is :: (CStore, [(ItemId, (Int, ItemTimers))])
is = (CStore
fromCStore, [(ItemId
iid, (Int
kChosen, Int -> ItemTimers -> ItemTimers
forall a. Int -> [a] -> [a]
take Int
kChosen ItemTimers
it))])
                   in RequestTimed -> FailOrCmd RequestTimed
forall a b. b -> Either a b
Right (RequestTimed -> FailOrCmd RequestTimed)
-> m RequestTimed -> m (FailOrCmd RequestTimed)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ActorId
-> [CStore]
-> (CStore, [(ItemId, (Int, ItemTimers))])
-> CStore
-> m RequestTimed
forall (m :: * -> *).
MonadClientUI m =>
ActorId
-> [CStore]
-> (CStore, [(ItemId, (Int, ItemTimers))])
-> CStore
-> m RequestTimed
moveItems ActorId
leader [CStore]
stores (CStore, [(ItemId, (Int, ItemTimers))])
is CStore
destCStore
    Maybe (ItemId, CStore, Bool)
_ -> do
      mis <- ActorId
-> [CStore]
-> CStore
-> Maybe Text
-> Bool
-> m (FailOrCmd (CStore, [(ItemId, (Int, ItemTimers))]))
forall (m :: * -> *).
MonadClientUI m =>
ActorId
-> [CStore]
-> CStore
-> Maybe Text
-> Bool
-> m (FailOrCmd (CStore, [(ItemId, (Int, ItemTimers))]))
selectItemsToMove ActorId
leader [CStore]
stores CStore
destCStore Maybe Text
mverb Bool
auto
      case mis of
        Left FailError
err -> FailOrCmd RequestTimed -> m (FailOrCmd RequestTimed)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FailOrCmd RequestTimed -> m (FailOrCmd RequestTimed))
-> FailOrCmd RequestTimed -> m (FailOrCmd RequestTimed)
forall a b. (a -> b) -> a -> b
$ FailError -> FailOrCmd RequestTimed
forall a b. a -> Either a b
Left FailError
err
        Right (CStore
fromCStore, [(ItemId
iid, (Int, ItemTimers)
_)]) | [CStore]
stores [CStore] -> [CStore] -> Bool
forall a. Eq a => a -> a -> Bool
/= [CStore
CGround] -> do
          (SessionUI -> SessionUI) -> m ()
forall (m :: * -> *).
MonadClientUI m =>
(SessionUI -> SessionUI) -> m ()
modifySession ((SessionUI -> SessionUI) -> m ())
-> (SessionUI -> SessionUI) -> m ()
forall a b. (a -> b) -> a -> b
$ \SessionUI
sess ->
            SessionUI
sess {sitemSel = Just (iid, fromCStore, False)}
          ActorId
-> [CStore]
-> CStore
-> Maybe Text
-> Bool
-> m (FailOrCmd RequestTimed)
forall (m :: * -> *).
MonadClientUI m =>
ActorId
-> [CStore]
-> CStore
-> Maybe Text
-> Bool
-> m (FailOrCmd RequestTimed)
moveOrSelectItem ActorId
leader [CStore]
stores CStore
destCStore Maybe Text
mverb Bool
auto
        Right is :: (CStore, [(ItemId, (Int, ItemTimers))])
is@(CStore
fromCStore, [(ItemId, (Int, ItemTimers))]
_) ->
          if | CStore
fromCStore CStore -> CStore -> Bool
forall a. Eq a => a -> a -> Bool
== CStore
CEqp Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
calmE -> ReqFailure -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a.
MonadClientUI m =>
ReqFailure -> m (FailOrCmd a)
failSer ReqFailure
ItemNotCalm
             | CStore
fromCStore CStore -> CStore -> Bool
forall a. Eq a => a -> a -> Bool
== CStore
CGround Bool -> Bool -> Bool
&& Bool
overStash -> ReqFailure -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a.
MonadClientUI m =>
ReqFailure -> m (FailOrCmd a)
failSer ReqFailure
ItemOverStash
             | Bool
otherwise -> RequestTimed -> FailOrCmd RequestTimed
forall a b. b -> Either a b
Right (RequestTimed -> FailOrCmd RequestTimed)
-> m RequestTimed -> m (FailOrCmd RequestTimed)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ActorId
-> [CStore]
-> (CStore, [(ItemId, (Int, ItemTimers))])
-> CStore
-> m RequestTimed
forall (m :: * -> *).
MonadClientUI m =>
ActorId
-> [CStore]
-> (CStore, [(ItemId, (Int, ItemTimers))])
-> CStore
-> m RequestTimed
moveItems ActorId
leader [CStore]
stores (CStore, [(ItemId, (Int, ItemTimers))])
is CStore
destCStore

selectItemsToMove :: forall m. MonadClientUI m
                  => ActorId -> [CStore] -> CStore -> Maybe Text -> Bool
                  -> m (FailOrCmd (CStore, [(ItemId, ItemQuant)]))
selectItemsToMove :: forall (m :: * -> *).
MonadClientUI m =>
ActorId
-> [CStore]
-> CStore
-> Maybe Text
-> Bool
-> m (FailOrCmd (CStore, [(ItemId, (Int, ItemTimers))]))
selectItemsToMove ActorId
leader [CStore]
stores CStore
destCStore Maybe Text
mverb Bool
auto = do
  let verb :: Text
verb = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe (CStore -> Text
verbCStore CStore
destCStore) Maybe Text
mverb
  actorCurAndMaxSk <- (State -> Skills) -> m Skills
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Skills) -> m Skills) -> (State -> Skills) -> m Skills
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Skills
getActorMaxSkills ActorId
leader
  b <- getsState $ getActorBody leader
  mstash <- getsState $ \State
s -> Faction -> Maybe (LevelId, Point)
gstash (Faction -> Maybe (LevelId, Point))
-> Faction -> Maybe (LevelId, Point)
forall a b. (a -> b) -> a -> b
$ State -> EnumMap FactionId Faction
sfactionD State
s EnumMap FactionId Faction -> FactionId -> Faction
forall k a. Enum k => EnumMap k a -> k -> a
EM.! Actor -> FactionId
bfid Actor
b
  lastItemMove <- getsSession slastItemMove
  -- This calmE is outdated when one of the items increases max Calm
  -- (e.g., in pickup, which handles many items at once), but this is OK,
  -- the server accepts item movement based on calm at the start, not end
  -- or in the middle.
  -- The calmE is inaccurate also if an item not IDed, but that's intended
  -- and the server will ignore and warn (and content may avoid that,
  -- e.g., making all rings identified)
  let calmE = Actor -> Skills -> Bool
calmEnough Actor
b Skills
actorCurAndMaxSk
      overStash = Maybe (LevelId, Point)
mstash Maybe (LevelId, Point) -> Maybe (LevelId, Point) -> Bool
forall a. Eq a => a -> a -> Bool
== (LevelId, Point) -> Maybe (LevelId, Point)
forall a. a -> Maybe a
Just (Actor -> LevelId
blid Actor
b, Actor -> Point
bpos Actor
b)
  if | destCStore == CEqp && not calmE -> failSer ItemNotCalm
     | destCStore == CGround && overStash -> failSer ItemOverStash
     | destCStore == CEqp && eqpOverfull b 1 -> failSer EqpOverfull
     | otherwise -> do
       let storesLast = case Maybe (CStore, CStore)
lastItemMove of
             Just (CStore
lastFrom, CStore
lastDest) | CStore
lastDest CStore -> CStore -> Bool
forall a. Eq a => a -> a -> Bool
== CStore
destCStore
                                         Bool -> Bool -> Bool
&& CStore
lastFrom CStore -> [CStore] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CStore]
stores ->
               CStore
lastFrom CStore -> [CStore] -> [CStore]
forall a. a -> [a] -> [a]
: CStore -> [CStore] -> [CStore]
forall a. Eq a => a -> [a] -> [a]
delete CStore
lastFrom [CStore]
stores
             Maybe (CStore, CStore)
_ -> [CStore]
stores
           prompt = Text
"What to"
           promptEqp = Text
"What consumable to"
           eqpItemsN Actor
body =
             let n :: Int
n = [Int] -> Int
forall a. Num a => [a] -> a
sum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ ((Int, ItemTimers) -> Int) -> [(Int, ItemTimers)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, ItemTimers) -> Int
forall a b. (a, b) -> a
fst ([(Int, ItemTimers)] -> [Int]) -> [(Int, ItemTimers)] -> [Int]
forall a b. (a -> b) -> a -> b
$ ItemBag -> [(Int, ItemTimers)]
forall k a. EnumMap k a -> [a]
EM.elems (ItemBag -> [(Int, ItemTimers)]) -> ItemBag -> [(Int, ItemTimers)]
forall a b. (a -> b) -> a -> b
$ Actor -> ItemBag
beqp Actor
body
             in Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Part] -> Text
makePhrase [Int -> Part -> Part
MU.CarWs Int
n Part
"item"]
           ppItemDialogBody Actor
body Skills
actorSk ItemDialogMode
cCur = case ItemDialogMode
cCur of
             MStore CStore
CEqp | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Actor -> Skills -> Bool
calmEnough Actor
body Skills
actorSk ->
               Text
"distractedly paw at" Text -> Text -> Text
<+> ItemDialogMode -> Text
ppItemDialogModeIn ItemDialogMode
cCur
             MStore CStore
CGround | Maybe (LevelId, Point)
mstash Maybe (LevelId, Point) -> Maybe (LevelId, Point) -> Bool
forall a. Eq a => a -> a -> Bool
== (LevelId, Point) -> Maybe (LevelId, Point)
forall a. a -> Maybe a
Just (Actor -> LevelId
blid Actor
body, Actor -> Point
bpos Actor
body) ->
               Text
"greedily fondle" Text -> Text -> Text
<+> ItemDialogMode -> Text
ppItemDialogModeIn ItemDialogMode
cCur
             ItemDialogMode
_ -> case CStore
destCStore of
               CStore
CEqp | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Actor -> Skills -> Bool
calmEnough Actor
body Skills
actorSk ->
                 Text
"distractedly attempt to" Text -> Text -> Text
<+> Text
verb
                 Text -> Text -> Text
<+> ItemDialogMode -> Text
ppItemDialogModeFrom ItemDialogMode
cCur
               CStore
CEqp | Actor -> Int -> Bool
eqpOverfull Actor
body Int
1 ->
                 Text
"attempt to fit into equipment" Text -> Text -> Text
<+> ItemDialogMode -> Text
ppItemDialogModeFrom ItemDialogMode
cCur
               CStore
CGround | Maybe (LevelId, Point)
mstash Maybe (LevelId, Point) -> Maybe (LevelId, Point) -> Bool
forall a. Eq a => a -> a -> Bool
== (LevelId, Point) -> Maybe (LevelId, Point)
forall a. a -> Maybe a
Just (Actor -> LevelId
blid Actor
body, Actor -> Point
bpos Actor
body) ->
                 Text
"greedily attempt to" Text -> Text -> Text
<+> Text
verb Text -> Text -> Text
<+> ItemDialogMode -> Text
ppItemDialogModeFrom ItemDialogMode
cCur
               CStore
CEqp -> Text
verb
                       Text -> Text -> Text
<+> Actor -> Text
eqpItemsN Actor
body Text -> Text -> Text
<+> Text
"so far)"
                       Text -> Text -> Text
<+> ItemDialogMode -> Text
ppItemDialogModeFrom ItemDialogMode
cCur
               CStore
_ -> Text
verb Text -> Text -> Text
<+> ItemDialogMode -> Text
ppItemDialogModeFrom ItemDialogMode
cCur
                    Text -> Text -> Text
<+> if ItemDialogMode
cCur ItemDialogMode -> ItemDialogMode -> Bool
forall a. Eq a => a -> a -> Bool
== CStore -> ItemDialogMode
MStore CStore
CEqp
                        then Actor -> Text
eqpItemsN Actor
body Text -> Text -> Text
<+> Text
"now)"
                        else Text
""
           (promptGeneric, psuit) =
             -- We prune item list only for eqp, because other stores don't have
             -- so clear cut heuristics. So when picking up a stash, either grab
             -- it to auto-store things, or equip first using the pruning
             -- and then stash the rest selectively or en masse.
             if destCStore == CEqp
             then (promptEqp, return $ SuitsSomething $ \Maybe CStore
_ ItemFull
itemFull (Int, ItemTimers)
_kit ->
                    AspectRecord -> Bool
IA.goesIntoEqp (AspectRecord -> Bool) -> AspectRecord -> Bool
forall a b. (a -> b) -> a -> b
$ ItemFull -> AspectRecord
aspectRecordFull ItemFull
itemFull)
             else (prompt, return SuitsEverything)
       ggi <-
         getFull leader psuit
                 (\Actor
body ActorUI
_ Skills
actorSk ItemDialogMode
cCur State
_ ->
                    Text
prompt Text -> Text -> Text
<+> Actor -> Skills -> ItemDialogMode -> Text
ppItemDialogBody Actor
body Skills
actorSk ItemDialogMode
cCur)
                 (\Actor
body ActorUI
_ Skills
actorSk ItemDialogMode
cCur State
_ ->
                    Text
promptGeneric Text -> Text -> Text
<+> Actor -> Skills -> ItemDialogMode -> Text
ppItemDialogBody Actor
body Skills
actorSk ItemDialogMode
cCur)
                 storesLast (not auto) True
       case ggi of
         Right (CStore
fromCStore, [(ItemId, (Int, ItemTimers))]
l) -> do
           (SessionUI -> SessionUI) -> m ()
forall (m :: * -> *).
MonadClientUI m =>
(SessionUI -> SessionUI) -> m ()
modifySession ((SessionUI -> SessionUI) -> m ())
-> (SessionUI -> SessionUI) -> m ()
forall a b. (a -> b) -> a -> b
$ \SessionUI
sess ->
             SessionUI
sess {slastItemMove = Just (fromCStore, destCStore)}
           FailOrCmd (CStore, [(ItemId, (Int, ItemTimers))])
-> m (FailOrCmd (CStore, [(ItemId, (Int, ItemTimers))]))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FailOrCmd (CStore, [(ItemId, (Int, ItemTimers))])
 -> m (FailOrCmd (CStore, [(ItemId, (Int, ItemTimers))])))
-> FailOrCmd (CStore, [(ItemId, (Int, ItemTimers))])
-> m (FailOrCmd (CStore, [(ItemId, (Int, ItemTimers))]))
forall a b. (a -> b) -> a -> b
$ (CStore, [(ItemId, (Int, ItemTimers))])
-> FailOrCmd (CStore, [(ItemId, (Int, ItemTimers))])
forall a b. b -> Either a b
Right (CStore
fromCStore, [(ItemId, (Int, ItemTimers))]
l)
         Left Text
err -> Text -> m (FailOrCmd (CStore, [(ItemId, (Int, ItemTimers))]))
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith Text
err

moveItems :: forall m. MonadClientUI m
          => ActorId -> [CStore] -> (CStore, [(ItemId, ItemQuant)]) -> CStore
          -> m RequestTimed
moveItems :: forall (m :: * -> *).
MonadClientUI m =>
ActorId
-> [CStore]
-> (CStore, [(ItemId, (Int, ItemTimers))])
-> CStore
-> m RequestTimed
moveItems ActorId
leader [CStore]
stores (CStore
fromCStore, [(ItemId, (Int, ItemTimers))]
l) CStore
destCStore = do
  let !_A :: ()
_A = Bool -> () -> ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (CStore
fromCStore CStore -> CStore -> Bool
forall a. Eq a => a -> a -> Bool
/= CStore
destCStore Bool -> Bool -> Bool
&& CStore
fromCStore CStore -> [CStore] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CStore]
stores) ()
  actorCurAndMaxSk <- (State -> Skills) -> m Skills
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Skills) -> m Skills) -> (State -> Skills) -> m Skills
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Skills
getActorMaxSkills ActorId
leader
  b <- getsState $ getActorBody leader
  discoBenefit <- getsClient sdiscoBenefit
  let calmE = Actor -> Skills -> Bool
calmEnough Actor
b Skills
actorCurAndMaxSk
      ret4 :: [(ItemId, ItemQuant)] -> Int -> m [(ItemId, Int, CStore, CStore)]
      ret4 [] Int
_ = [(ItemId, Int, CStore, CStore)]
-> m [(ItemId, Int, CStore, CStore)]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
      ret4 ((ItemId
iid, (Int
k, ItemTimers
_)) : [(ItemId, (Int, ItemTimers))]
rest) Int
oldN = do
        let !_A :: ()
_A = Bool -> () -> ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) ()
            retRec :: CStore -> m [(ItemId, Int, CStore, CStore)]
retRec CStore
toCStore = do
              let n :: Int
n = Int
oldN Int -> Int -> Int
forall a. Num a => a -> a -> a
+ if CStore
toCStore CStore -> CStore -> Bool
forall a. Eq a => a -> a -> Bool
== CStore
CEqp then Int
k else Int
0
              l4 <- [(ItemId, (Int, ItemTimers))]
-> Int -> m [(ItemId, Int, CStore, CStore)]
ret4 [(ItemId, (Int, ItemTimers))]
rest Int
n
              return $ (iid, k, fromCStore, toCStore) : l4
        if [CStore]
stores [CStore] -> [CStore] -> Bool
forall a. Eq a => a -> a -> Bool
== [CStore
CGround] Bool -> Bool -> Bool
&& CStore
destCStore CStore -> CStore -> Bool
forall a. Eq a => a -> a -> Bool
== CStore
CStash  -- normal pickup
        then -- @CStash@ is the implicit default; refine:
             if | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Benefit -> Bool
benInEqp (Benefit -> Bool) -> Benefit -> Bool
forall a b. (a -> b) -> a -> b
$ DiscoveryBenefit
discoBenefit DiscoveryBenefit -> ItemId -> Benefit
forall k a. Enum k => EnumMap k a -> k -> a
EM.! ItemId
iid -> CStore -> m [(ItemId, Int, CStore, CStore)]
retRec CStore
CStash
                | Actor -> Int -> Bool
eqpOverfull Actor
b (Int
oldN Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) -> do
                  -- Action goes through, but changed, so keep in history.
                  MsgClassShowAndSave -> Text -> m ()
forall (m :: * -> *) a.
(MonadClientUI m, MsgShared a) =>
a -> Text -> m ()
msgAdd MsgClassShowAndSave
MsgActionWarning (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
                    Text
"Warning:" Text -> Text -> Text
<+> ReqFailure -> Text
showReqFailure ReqFailure
EqpOverfull Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"."
                  CStore -> m [(ItemId, Int, CStore, CStore)]
retRec CStore
CStash
                | Actor -> Int -> Bool
eqpOverfull Actor
b (Int
oldN Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
k) -> do
                  -- If this stack doesn't fit, we don't equip any part of it,
                  -- but we may equip a smaller stack later of other items
                  -- in the same pickup.
                  MsgClassShowAndSave -> Text -> m ()
forall (m :: * -> *) a.
(MonadClientUI m, MsgShared a) =>
a -> Text -> m ()
msgAdd MsgClassShowAndSave
MsgActionWarning (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
                    Text
"Warning:" Text -> Text -> Text
<+> ReqFailure -> Text
showReqFailure ReqFailure
EqpStackFull Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"."
                  CStore -> m [(ItemId, Int, CStore, CStore)]
retRec CStore
CStash
                | Bool -> Bool
not Bool
calmE -> do
                  MsgClassShowAndSave -> Text -> m ()
forall (m :: * -> *) a.
(MonadClientUI m, MsgShared a) =>
a -> Text -> m ()
msgAdd MsgClassShowAndSave
MsgActionWarning (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
                    Text
"Warning:" Text -> Text -> Text
<+> ReqFailure -> Text
showReqFailure ReqFailure
ItemNotCalm Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"."
                  CStore -> m [(ItemId, Int, CStore, CStore)]
retRec CStore
CStash
                | Bool
otherwise ->
                  -- Prefer @CEqp@ if all conditions hold:
                  CStore -> m [(ItemId, Int, CStore, CStore)]
retRec CStore
CEqp
        else case CStore
destCStore of  -- player forces store, so @benInEqp@ ignored
          CStore
CEqp | Actor -> Int -> Bool
eqpOverfull Actor
b (Int
oldN Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) -> do
            -- Action aborted, so different colour and not in history.
            MsgClassShow -> Text -> m ()
forall (m :: * -> *) a.
(MonadClientUI m, MsgShared a) =>
a -> Text -> m ()
msgAdd MsgClassShow
MsgPromptItems (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
              Text
"Failure:" Text -> Text -> Text
<+> ReqFailure -> Text
showReqFailure ReqFailure
EqpOverfull Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"."
            -- No recursive call here, we exit item manipulation,
            -- but something is moved or else outer functions would not call us.
            [(ItemId, Int, CStore, CStore)]
-> m [(ItemId, Int, CStore, CStore)]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
          CStore
CEqp | Actor -> Int -> Bool
eqpOverfull Actor
b (Int
oldN Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
k) -> do
            MsgClassShow -> Text -> m ()
forall (m :: * -> *) a.
(MonadClientUI m, MsgShared a) =>
a -> Text -> m ()
msgAdd MsgClassShow
MsgPromptItems (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
              Text
"Failure:" Text -> Text -> Text
<+> ReqFailure -> Text
showReqFailure ReqFailure
EqpStackFull Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"."
            [(ItemId, Int, CStore, CStore)]
-> m [(ItemId, Int, CStore, CStore)]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
          CStore
_ -> CStore -> m [(ItemId, Int, CStore, CStore)]
retRec CStore
destCStore
  l4 <- ret4 l 0
  if null l4
  then error $ "" `showFailure` (stores, fromCStore, l, destCStore)
  else return $! ReqMoveItems l4

-- * Project

projectHuman :: (MonadClient m, MonadClientUI m)
             => ActorId -> m (FailOrCmd RequestTimed)
projectHuman :: forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
ActorId -> m (FailOrCmd RequestTimed)
projectHuman ActorId
leader = do
  curChal <- (StateClient -> Challenge) -> m Challenge
forall a. (StateClient -> a) -> m a
forall (m :: * -> *) a.
MonadClientRead m =>
(StateClient -> a) -> m a
getsClient StateClient -> Challenge
scurChal
  actorCurAndMaxSk <- getsState $ getActorMaxSkills leader
  if | ckeeper curChal ->
       failSer ProjectFinderKeeper
     | Ability.getSk Ability.SkProject actorCurAndMaxSk <= 0 ->
       -- Detailed are check later.
       failSer ProjectUnskilled
     | otherwise -> do
       itemSel <- getsSession sitemSel
       case itemSel of
         Just (ItemId
_, CStore
COrgan, Bool
_) -> Text -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith Text
"can't fling an organ"
         Just (ItemId
iid, CStore
fromCStore, Bool
_) -> do
           b <- (State -> Actor) -> m Actor
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
leader
           bag <- getsState $ getBodyStoreBag b fromCStore
           case iid `EM.lookup` bag of
             Maybe (Int, ItemTimers)
Nothing -> Text -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith Text
"no item to fling"
             Just (Int, ItemTimers)
_kit -> do
               itemFull <- (State -> ItemFull) -> m ItemFull
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> ItemFull) -> m ItemFull)
-> (State -> ItemFull) -> m ItemFull
forall a b. (a -> b) -> a -> b
$ ItemId -> State -> ItemFull
itemToFull ItemId
iid
               let i = (CStore
fromCStore, (ItemId
iid, ItemFull
itemFull))
               projectItem leader i
         Maybe (ItemId, CStore, Bool)
Nothing -> Text -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith Text
"no item to fling"

projectItem :: (MonadClient m, MonadClientUI m)
            => ActorId -> (CStore, (ItemId, ItemFull))
            -> m (FailOrCmd RequestTimed)
projectItem :: forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
ActorId
-> (CStore, (ItemId, ItemFull)) -> m (FailOrCmd RequestTimed)
projectItem ActorId
leader (CStore
fromCStore, (ItemId
iid, ItemFull
itemFull)) = do
  actorCurAndMaxSk <- (State -> Skills) -> m Skills
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Skills) -> m Skills) -> (State -> Skills) -> m Skills
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Skills
getActorMaxSkills ActorId
leader
  b <- getsState $ getActorBody leader
  let calmE = Actor -> Skills -> Bool
calmEnough Actor
b Skills
actorCurAndMaxSk
  if fromCStore == CEqp && not calmE then failSer ItemNotCalm
  else do
    mpsuitReq <- psuitReq leader
    case mpsuitReq of
      Left Text
err -> Text -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith Text
err
      Right ItemFull -> Either ReqFailure (Point, Bool)
psuitReqFun ->
        case ItemFull -> Either ReqFailure (Point, Bool)
psuitReqFun ItemFull
itemFull of
          Left ReqFailure
reqFail -> ReqFailure -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a.
MonadClientUI m =>
ReqFailure -> m (FailOrCmd a)
failSer ReqFailure
reqFail
          Right (Point
pos, Bool
_) -> do
            Benefit{benFling} <- (StateClient -> Benefit) -> m Benefit
forall a. (StateClient -> a) -> m a
forall (m :: * -> *) a.
MonadClientRead m =>
(StateClient -> a) -> m a
getsClient ((StateClient -> Benefit) -> m Benefit)
-> (StateClient -> Benefit) -> m Benefit
forall a b. (a -> b) -> a -> b
$ (DiscoveryBenefit -> ItemId -> Benefit
forall k a. Enum k => EnumMap k a -> k -> a
EM.! ItemId
iid) (DiscoveryBenefit -> Benefit)
-> (StateClient -> DiscoveryBenefit) -> StateClient -> Benefit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateClient -> DiscoveryBenefit
sdiscoBenefit
            go <- if benFling >= 0
                  then displayYesNo ColorFull
                         "The item may be beneficial. Do you really want to fling it?"
                  else return True
            if go then do
              -- Set personal target to enemy, so that AI, if it takes over
              -- the actor, is likely to continue the fight even if the foe
              -- flees. Similarly if the crosshair points at position, etc.
              sxhair <- getsSession sxhair
              modifyClient $ updateTarget leader (const sxhair)
              -- Project.
              eps <- getsClient seps
              return $ Right $ ReqProject pos eps iid fromCStore
            else do
              modifySession $ \SessionUI
sess -> SessionUI
sess {sitemSel = Nothing}
              failWith "never mind"

-- * Apply

applyHuman :: MonadClientUI m => ActorId -> m (FailOrCmd RequestTimed)
applyHuman :: forall (m :: * -> *).
MonadClientUI m =>
ActorId -> m (FailOrCmd RequestTimed)
applyHuman ActorId
leader = do
  actorCurAndMaxSk <- (State -> Skills) -> m Skills
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Skills) -> m Skills) -> (State -> Skills) -> m Skills
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Skills
getActorMaxSkills ActorId
leader
  if Ability.getSk Ability.SkApply
                   actorCurAndMaxSk <= 0 then  -- detailed check later
    failSer ApplyUnskilled
  else do
    itemSel <- getsSession sitemSel
    case itemSel of
      Just (ItemId
iid, CStore
fromCStore, Bool
_) -> do
        b <- (State -> Actor) -> m Actor
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
leader
        bag <- getsState $ getBodyStoreBag b fromCStore
        case iid `EM.lookup` bag of
          Maybe (Int, ItemTimers)
Nothing -> Text -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith Text
"no item to trigger"
          Just (Int, ItemTimers)
kit -> do
            itemFull <- (State -> ItemFull) -> m ItemFull
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> ItemFull) -> m ItemFull)
-> (State -> ItemFull) -> m ItemFull
forall a b. (a -> b) -> a -> b
$ ItemId -> State -> ItemFull
itemToFull ItemId
iid
            applyItem leader (fromCStore, (iid, (itemFull, kit)))
      Maybe (ItemId, CStore, Bool)
Nothing -> Text -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith Text
"no item to trigger"

applyItem :: MonadClientUI m
          => ActorId -> (CStore, (ItemId, ItemFullKit))
          -> m (FailOrCmd RequestTimed)
applyItem :: forall (m :: * -> *).
MonadClientUI m =>
ActorId
-> (CStore, (ItemId, ItemFullKit)) -> m (FailOrCmd RequestTimed)
applyItem ActorId
leader (CStore
fromCStore, (ItemId
iid, (ItemFull
itemFull, (Int, ItemTimers)
kit))) = do
  COps{corule} <- (State -> COps) -> m COps
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  actorCurAndMaxSk <- getsState $ getActorMaxSkills leader
  b <- getsState $ getActorBody leader
  localTime <- getsState $ getLocalTime (blid b)
  let skill = Skill -> Skills -> Int
Ability.getSk Skill
Ability.SkApply Skills
actorCurAndMaxSk
      calmE = Actor -> Skills -> Bool
calmEnough Actor
b Skills
actorCurAndMaxSk
      arItem = ItemFull -> AspectRecord
aspectRecordFull ItemFull
itemFull
  if fromCStore == CEqp && not calmE then failSer ItemNotCalm
  else case permittedApply corule localTime skill calmE (Just fromCStore)
                           itemFull kit of
    Left ReqFailure
reqFail -> ReqFailure -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a.
MonadClientUI m =>
ReqFailure -> m (FailOrCmd a)
failSer ReqFailure
reqFail
    Right Bool
_ -> do
      Benefit{benApply} <- (StateClient -> Benefit) -> m Benefit
forall a. (StateClient -> a) -> m a
forall (m :: * -> *) a.
MonadClientRead m =>
(StateClient -> a) -> m a
getsClient ((StateClient -> Benefit) -> m Benefit)
-> (StateClient -> Benefit) -> m Benefit
forall a b. (a -> b) -> a -> b
$ (DiscoveryBenefit -> ItemId -> Benefit
forall k a. Enum k => EnumMap k a -> k -> a
EM.! ItemId
iid) (DiscoveryBenefit -> Benefit)
-> (StateClient -> DiscoveryBenefit) -> StateClient -> Benefit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateClient -> DiscoveryBenefit
sdiscoBenefit
      go <-
        if | IA.checkFlag Ability.Periodic arItem
             && not (IA.checkFlag Ability.Durable arItem) ->
             -- No warning if item durable, because activation weak,
             -- but price low, due to no destruction.
             displayYesNo ColorFull
                          "Triggering this periodic item may not produce all its effects (check item description) and moreover, because it's not durable, will destroy it. Are you sure?"
           | benApply < 0 ->
             displayYesNo ColorFull
                          "The item appears harmful. Do you really want to trigger it?"
           | otherwise -> return True
      if go
      then return $ Right $ ReqApply iid fromCStore
      else do
        modifySession $ \SessionUI
sess -> SessionUI
sess {sitemSel = Nothing}
        failWith "never mind"

-- * AlterDir

-- | Ask for a direction and alter a tile, if possible.
alterDirHuman :: MonadClientUI m => ActorId -> m (FailOrCmd RequestTimed)
alterDirHuman :: forall (m :: * -> *).
MonadClientUI m =>
ActorId -> m (FailOrCmd RequestTimed)
alterDirHuman ActorId
leader = ActorId -> Text -> m (Maybe Point)
forall (m :: * -> *).
MonadClientUI m =>
ActorId -> Text -> m (Maybe Point)
pickPoint ActorId
leader Text
"modify" m (Maybe Point)
-> (Maybe Point -> m (FailOrCmd RequestTimed))
-> m (FailOrCmd RequestTimed)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Just Point
p -> ActorId -> Point -> m (FailOrCmd RequestTimed)
forall (m :: * -> *).
MonadClientUI m =>
ActorId -> Point -> m (FailOrCmd RequestTimed)
alterTileAtPos ActorId
leader Point
p
  Maybe Point
Nothing -> Text -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith Text
"never mind"

-- | Try to alter a tile using a feature at the given position.
--
-- We don't check if the tile is interesting, e.g., if any embedded
-- item can be triggered, because the player explicitely requested
-- the action. Consequently, even if all embedded items are recharching,
-- the time will be wasted and the server will describe the failure in detail.
alterTileAtPos :: MonadClientUI m
               => ActorId -> Point -> m (FailOrCmd RequestTimed)
alterTileAtPos :: forall (m :: * -> *).
MonadClientUI m =>
ActorId -> Point -> m (FailOrCmd RequestTimed)
alterTileAtPos ActorId
leader Point
pos = do
  sb <- (State -> Actor) -> m Actor
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
leader
  let sxhair = Target -> Maybe Target
forall a. a -> Maybe a
Just (Target -> Maybe Target) -> Target -> Maybe Target
forall a b. (a -> b) -> a -> b
$ TGoal -> LevelId -> Point -> Target
TPoint TGoal
TUnknown (Actor -> LevelId
blid Actor
sb) Point
pos
  -- Point xhair to see details with `~`.
  setXHairFromGUI sxhair
  alterCommon leader False pos

-- | Verify that the tile can be transformed or any embedded item effect
-- triggered and the player is aware if the effect is dangerous or grave,
-- such as ending the game.
verifyAlters :: forall m. MonadClientUI m
             => ActorId -> Bool -> Point -> m (FailOrCmd ())
verifyAlters :: forall (m :: * -> *).
MonadClientUI m =>
ActorId -> Bool -> Point -> m (FailOrCmd ())
verifyAlters ActorId
leader Bool
bumping Point
tpos = do
  COps{cotile, coTileSpeedup} <- (State -> COps) -> m COps
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  sb <- getsState $ getActorBody leader
  arItem <- getsState $ aspectRecordFromIid $ btrunk sb
  embeds <- getsState $ getEmbedBag (blid sb) tpos
  lvl <- getLevel $ blid sb
  getKind <- getsState $ flip getIidKind
  let embedKindList =
        if Flag -> AspectRecord -> Bool
IA.checkFlag Flag
Ability.Blast AspectRecord
arItem
        then []  -- prevent embeds triggering each other in a loop
        else ((ItemId, (Int, ItemTimers))
 -> (ItemKind, (ItemId, (Int, ItemTimers))))
-> [(ItemId, (Int, ItemTimers))]
-> [(ItemKind, (ItemId, (Int, ItemTimers)))]
forall a b. (a -> b) -> [a] -> [b]
map (\(ItemId
iid, (Int, ItemTimers)
kit) -> (ItemId -> ItemKind
getKind ItemId
iid, (ItemId
iid, (Int, ItemTimers)
kit))) (ItemBag -> [(ItemId, (Int, ItemTimers))]
forall k a. Enum k => EnumMap k a -> [(k, a)]
EM.assocs ItemBag
embeds)
      underFeet = Point
tpos Point -> Point -> Bool
forall a. Eq a => a -> a -> Bool
== Actor -> Point
bpos Actor
sb  -- if enter and alter, be more permissive
      blockedByItem = Point -> EnumMap Point ItemBag -> Bool
forall k a. Enum k => k -> EnumMap k a -> Bool
EM.member Point
tpos (Level -> EnumMap Point ItemBag
lfloor Level
lvl)
      tile = Level
lvl Level -> Point -> ContentId TileKind
`at` Point
tpos
      feats = TileKind -> [Feature]
TK.tfeature (TileKind -> [Feature]) -> TileKind -> [Feature]
forall a b. (a -> b) -> a -> b
$ ContentData TileKind -> ContentId TileKind -> TileKind
forall a. ContentData a -> ContentId a -> a
okind ContentData TileKind
cotile ContentId TileKind
tile
      tileActions =
        (Feature -> Maybe TileAction) -> [Feature] -> [TileAction]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Bool
-> Bool
-> [(ItemKind, (ItemId, (Int, ItemTimers)))]
-> Feature
-> Maybe TileAction
parseTileAction
                    (Actor -> Bool
bproj Actor
sb)
                    (Bool
underFeet Bool -> Bool -> Bool
|| Bool
blockedByItem)  -- avoids AlterBlockItem
                    [(ItemKind, (ItemId, (Int, ItemTimers)))]
embedKindList)
                 [Feature]
feats
  if null tileActions
     && blockedByItem
     && not underFeet
     && Tile.isModifiable coTileSpeedup tile
  then failSer AlterBlockItem
  else processTileActions leader bumping tpos tileActions

processTileActions :: forall m. MonadClientUI m
                   => ActorId -> Bool -> Point -> [TileAction]
                   -> m (FailOrCmd ())
processTileActions :: forall (m :: * -> *).
MonadClientUI m =>
ActorId -> Bool -> Point -> [TileAction] -> m (FailOrCmd ())
processTileActions ActorId
leader Bool
bumping Point
tpos [TileAction]
tas = do
  COps{coTileSpeedup} <- (State -> COps) -> m COps
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  getKind <- getsState $ flip getIidKind
  sb <- getsState $ getActorBody leader
  lvl <- getLevel $ blid sb
  sar <- getsState $ aspectRecordFromIid $ btrunk sb
  let leaderIsMist = Flag -> AspectRecord -> Bool
IA.checkFlag Flag
Ability.Blast AspectRecord
sar
                     Bool -> Bool -> Bool
&& Dice -> Int
Dice.infDice (ItemKind -> Dice
IK.idamage (ItemKind -> Dice) -> ItemKind -> Dice
forall a b. (a -> b) -> a -> b
$ ItemId -> ItemKind
getKind (ItemId -> ItemKind) -> ItemId -> ItemKind
forall a b. (a -> b) -> a -> b
$ Actor -> ItemId
btrunk Actor
sb) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0
      tileMinSkill = TileSpeedup -> ContentId TileKind -> Int
Tile.alterMinSkill TileSpeedup
coTileSpeedup (ContentId TileKind -> Int) -> ContentId TileKind -> Int
forall a b. (a -> b) -> a -> b
$ Level
lvl Level -> Point -> ContentId TileKind
`at` Point
tpos
      processTA :: Maybe Bool -> [TileAction] -> Bool
                -> m (FailOrCmd (Maybe (Bool, Bool)))
      processTA Maybe Bool
museResult [] Bool
bumpFailed = do
        let useResult :: Bool
useResult = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False Maybe Bool
museResult
        -- No warning will be generated if during explicit modification
        -- an embed is activated but there is not enough tools
        -- for a subsequent transformation. This is fine. Bumping would
        -- produce the warning and S-dir also displays the tool info.
        -- We can't rule out the embed is the main feature and the tool
        -- transformation is not important despite following it.
        -- We don't want spam in such a case.
        FailOrCmd (Maybe (Bool, Bool))
-> m (FailOrCmd (Maybe (Bool, Bool)))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FailOrCmd (Maybe (Bool, Bool))
 -> m (FailOrCmd (Maybe (Bool, Bool))))
-> FailOrCmd (Maybe (Bool, Bool))
-> m (FailOrCmd (Maybe (Bool, Bool)))
forall a b. (a -> b) -> a -> b
$ Maybe (Bool, Bool) -> FailOrCmd (Maybe (Bool, Bool))
forall a b. b -> Either a b
Right (Maybe (Bool, Bool) -> FailOrCmd (Maybe (Bool, Bool)))
-> Maybe (Bool, Bool) -> FailOrCmd (Maybe (Bool, Bool))
forall a b. (a -> b) -> a -> b
$ if TileSpeedup -> ContentId TileKind -> Bool
Tile.isSuspect TileSpeedup
coTileSpeedup (Level
lvl Level -> Point -> ContentId TileKind
`at` Point
tpos)
                            Bool -> Bool -> Bool
|| Bool
useResult Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
bumpFailed
                         then Maybe (Bool, Bool)
forall a. Maybe a
Nothing  -- success of some kind
                         else (Bool, Bool) -> Maybe (Bool, Bool)
forall a. a -> Maybe a
Just (Bool
useResult, Bool
bumpFailed)  -- not quite
      processTA Maybe Bool
museResult (TileAction
ta : [TileAction]
rest) Bool
bumpFailed = case TileAction
ta of
        EmbedAction (ItemId
iid, (Int, ItemTimers)
_) -> do
          -- Embeds are activated in the order in tile definition
          -- and never after the tile is changed.
          -- We assume the item would trigger and we let the player
          -- take the risk of wasted turn to verify the assumption.
          -- If the item recharges, the wasted turns let the player wait.
          let useResult :: Bool
useResult = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False Maybe Bool
museResult
          if | Bool
leaderIsMist
               Bool -> Bool -> Bool
|| Actor -> Bool
bproj Actor
sb Bool -> Bool -> Bool
&& Int
tileMinSkill Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 ->  -- local skill check
               Maybe Bool
-> [TileAction] -> Bool -> m (FailOrCmd (Maybe (Bool, Bool)))
processTA (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
useResult) [TileAction]
rest Bool
bumpFailed
                 -- embed won't fire; try others
             | (Bool -> Bool
not (Bool -> Bool) -> ([Effect] -> Bool) -> [Effect] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Effect -> Bool) -> [Effect] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Effect -> Bool
IK.isEffEscape) (ItemKind -> [Effect]
IK.ieffects (ItemKind -> [Effect]) -> ItemKind -> [Effect]
forall a b. (a -> b) -> a -> b
$ ItemId -> ItemKind
getKind ItemId
iid) ->
               Maybe Bool
-> [TileAction] -> Bool -> m (FailOrCmd (Maybe (Bool, Bool)))
processTA (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True) [TileAction]
rest Bool
False
                 -- no escape checking needed, effect found;
                 -- also bumpFailed reset, because must have been
                 -- marginal if an embed was following it
             | Bool
otherwise -> do
               mfail <- m (FailOrCmd ())
forall (m :: * -> *). MonadClientUI m => m (FailOrCmd ())
verifyEscape
               case mfail of
                 Left FailError
err -> FailOrCmd (Maybe (Bool, Bool))
-> m (FailOrCmd (Maybe (Bool, Bool)))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FailOrCmd (Maybe (Bool, Bool))
 -> m (FailOrCmd (Maybe (Bool, Bool))))
-> FailOrCmd (Maybe (Bool, Bool))
-> m (FailOrCmd (Maybe (Bool, Bool)))
forall a b. (a -> b) -> a -> b
$ FailError -> FailOrCmd (Maybe (Bool, Bool))
forall a b. a -> Either a b
Left FailError
err
                 Right () -> Maybe Bool
-> [TileAction] -> Bool -> m (FailOrCmd (Maybe (Bool, Bool)))
processTA (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True) [TileAction]
rest Bool
False
                   -- effect found, bumpFailed reset
        ToAction{} ->
          if Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
True Maybe Bool
museResult
             Bool -> Bool -> Bool
&& Bool -> Bool
not (Actor -> Bool
bproj Actor
sb Bool -> Bool -> Bool
&& Int
tileMinSkill Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0)  -- local skill check
          then FailOrCmd (Maybe (Bool, Bool))
-> m (FailOrCmd (Maybe (Bool, Bool)))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FailOrCmd (Maybe (Bool, Bool))
 -> m (FailOrCmd (Maybe (Bool, Bool))))
-> FailOrCmd (Maybe (Bool, Bool))
-> m (FailOrCmd (Maybe (Bool, Bool)))
forall a b. (a -> b) -> a -> b
$ Maybe (Bool, Bool) -> FailOrCmd (Maybe (Bool, Bool))
forall a b. b -> Either a b
Right Maybe (Bool, Bool)
forall a. Maybe a
Nothing  -- tile changed, no more activations
          else Maybe Bool
-> [TileAction] -> Bool -> m (FailOrCmd (Maybe (Bool, Bool)))
processTA Maybe Bool
museResult [TileAction]
rest Bool
bumpFailed
                 -- failed, but not due to bumping
        WithAction [(Int, GroupName ItemKind)]
tools0 GroupName TileKind
_ ->
          if Bool -> Bool
not Bool
bumping Bool -> Bool -> Bool
|| [(Int, GroupName ItemKind)] -> Bool
forall a. [a] -> Bool
null [(Int, GroupName ItemKind)]
tools0 then
            if Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
True Maybe Bool
museResult then do
              -- UI requested, so this is voluntary, so item loss is fine.
              kitAssG <- (State -> [(ItemId, ItemFullKit)]) -> m [(ItemId, ItemFullKit)]
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> [(ItemId, ItemFullKit)]) -> m [(ItemId, ItemFullKit)])
-> (State -> [(ItemId, ItemFullKit)]) -> m [(ItemId, ItemFullKit)]
forall a b. (a -> b) -> a -> b
$ ActorId -> [CStore] -> State -> [(ItemId, ItemFullKit)]
kitAssocs ActorId
leader [CStore
CGround]
              kitAssE <- getsState $ kitAssocs leader [CEqp]
              let kitAss = [(ItemId, ItemFullKit)]
-> [(ItemId, ItemFullKit)]
-> [((CStore, Bool), (ItemId, ItemFullKit))]
listToolsToConsume [(ItemId, ItemFullKit)]
kitAssG [(ItemId, ItemFullKit)]
kitAssE
                  grps0 = ((Int, GroupName ItemKind) -> (Bool, Int, GroupName ItemKind))
-> [(Int, GroupName ItemKind)] -> [(Bool, Int, GroupName ItemKind)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
x, GroupName ItemKind
y) -> (Bool
False, Int
x, GroupName ItemKind
y)) [(Int, GroupName ItemKind)]
tools0
                    -- apply if durable
                  (_, iidsToApply, grps) =
                    foldl' subtractIidfromGrps (EM.empty, [], grps0) kitAss
              if null grps then do
                let hasEffectOrDmg (a
_, (a
_, ItemFull{ItemKind
itemKind :: ItemKind
itemKind :: ItemFull -> ItemKind
itemKind})) =
                      ItemKind -> Dice
IK.idamage ItemKind
itemKind Dice -> Dice -> Bool
forall a. Eq a => a -> a -> Bool
/= Dice
0
                      Bool -> Bool -> Bool
|| (Effect -> Bool) -> [Effect] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Effect -> Bool
IK.forApplyEffect (ItemKind -> [Effect]
IK.ieffects ItemKind
itemKind)
                mfail <- case filter hasEffectOrDmg iidsToApply of
                  [] -> FailOrCmd () -> m (FailOrCmd ())
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FailOrCmd () -> m (FailOrCmd ()))
-> FailOrCmd () -> m (FailOrCmd ())
forall a b. (a -> b) -> a -> b
$ () -> FailOrCmd ()
forall a b. b -> Either a b
Right ()
                  (CStore
store, (ItemId
_, ItemFull
itemFull)) : [(CStore, (ItemId, ItemFull))]
_ ->
                    LevelId -> CStore -> ItemFull -> m (FailOrCmd ())
forall (m :: * -> *).
MonadClientUI m =>
LevelId -> CStore -> ItemFull -> m (FailOrCmd ())
verifyToolEffect (Actor -> LevelId
blid Actor
sb) CStore
store ItemFull
itemFull
                case mfail of
                  Left FailError
err -> FailOrCmd (Maybe (Bool, Bool))
-> m (FailOrCmd (Maybe (Bool, Bool)))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FailOrCmd (Maybe (Bool, Bool))
 -> m (FailOrCmd (Maybe (Bool, Bool))))
-> FailOrCmd (Maybe (Bool, Bool))
-> m (FailOrCmd (Maybe (Bool, Bool)))
forall a b. (a -> b) -> a -> b
$ FailError -> FailOrCmd (Maybe (Bool, Bool))
forall a b. a -> Either a b
Left FailError
err
                  Right () -> FailOrCmd (Maybe (Bool, Bool))
-> m (FailOrCmd (Maybe (Bool, Bool)))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FailOrCmd (Maybe (Bool, Bool))
 -> m (FailOrCmd (Maybe (Bool, Bool))))
-> FailOrCmd (Maybe (Bool, Bool))
-> m (FailOrCmd (Maybe (Bool, Bool)))
forall a b. (a -> b) -> a -> b
$ Maybe (Bool, Bool) -> FailOrCmd (Maybe (Bool, Bool))
forall a b. b -> Either a b
Right Maybe (Bool, Bool)
forall a. Maybe a
Nothing  -- tile changed, done
              else processTA museResult rest bumpFailed  -- not enough tools
            else Maybe Bool
-> [TileAction] -> Bool -> m (FailOrCmd (Maybe (Bool, Bool)))
processTA Maybe Bool
museResult [TileAction]
rest Bool
bumpFailed  -- embeds failed
          else Maybe Bool
-> [TileAction] -> Bool -> m (FailOrCmd (Maybe (Bool, Bool)))
processTA Maybe Bool
museResult [TileAction]
rest Bool
True  -- failed due to bumping
  mfail <- processTA Nothing tas False
  case mfail of
    Left FailError
err -> FailOrCmd () -> m (FailOrCmd ())
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FailOrCmd () -> m (FailOrCmd ()))
-> FailOrCmd () -> m (FailOrCmd ())
forall a b. (a -> b) -> a -> b
$ FailError -> FailOrCmd ()
forall a b. a -> Either a b
Left FailError
err
    Right Maybe (Bool, Bool)
Nothing -> FailOrCmd () -> m (FailOrCmd ())
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FailOrCmd () -> m (FailOrCmd ()))
-> FailOrCmd () -> m (FailOrCmd ())
forall a b. (a -> b) -> a -> b
$ () -> FailOrCmd ()
forall a b. b -> Either a b
Right ()
    Right (Just (Bool
useResult, Bool
bumpFailed)) -> do
      let !_A :: ()
_A = Bool -> () -> ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Bool -> Bool
not Bool
useResult Bool -> Bool -> Bool
|| Bool
bumpFailed) ()
      blurb <- Point -> LevelId -> m [(MsgClassShow, Text)]
forall (m :: * -> *).
MonadClientUI m =>
Point -> LevelId -> m [(MsgClassShow, Text)]
lookAtPosition Point
tpos (Actor -> LevelId
blid Actor
sb)
      mapM_ (uncurry msgAdd) blurb
      if bumpFailed then do
        revCmd <- revCmdMap
        let km = HumanCmd -> KM
revCmd HumanCmd
AlterDir
            msg = Text
"bumping is not enough to transform this terrain; modify with the '"
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (KM -> String
K.showKM KM
km)
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' command instead"
        if useResult then do
          merr <- failMsg msg
          msgAdd MsgPromptAction $ showFailError $ fromJust merr
          return $ Right ()  -- effect the embed activation, though
        else failWith msg
      else failWith "unable to activate nor modify at this time"
        -- related to, among others, @SfxNoItemsForTile@ on the server

verifyEscape :: MonadClientUI m => m (FailOrCmd ())
verifyEscape :: forall (m :: * -> *). MonadClientUI m => m (FailOrCmd ())
verifyEscape = do
  side <- (StateClient -> FactionId) -> m FactionId
forall a. (StateClient -> a) -> m a
forall (m :: * -> *) a.
MonadClientRead m =>
(StateClient -> a) -> m a
getsClient StateClient -> FactionId
sside
  fact <- getsState $ (EM.! side) . sfactionD
  if not (FK.fcanEscape $ gkind fact)
  then failWith
         "This is the way out, but where would you go in this alien world?"
           -- exceptionally a full sentence, because a real question
  else do
    (_, total) <- getsState $ calculateTotal side
    dungeonTotal <- getsState sgold
    let prompt | Int
dungeonTotal Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 =
                 Text
"You finally reached your goal. Really leave now?"
               | Int
total Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 =
                 Text
"Afraid of the challenge? Leaving so soon and without any treasure? Are you sure?"
               | Int
total Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
dungeonTotal =
                 Text
"You've finally found the way out, but you didn't gather all valuables rumoured to be laying around. Really leave already?"
               | Bool
otherwise =
                 Text
"This is the way out and you collected all treasure there is to find. Really leave now?"
    -- The player can back off, but we never insist,
    -- because possibly the score formula doesn't reward treasure
    -- or he is focused on winning only.
    go <- displayYesNo ColorBW prompt
    if not go
    then failWith "here's your chance"
    else return $ Right ()

verifyToolEffect :: MonadClientUI m
                 => LevelId -> CStore -> ItemFull -> m (FailOrCmd ())
verifyToolEffect :: forall (m :: * -> *).
MonadClientUI m =>
LevelId -> CStore -> ItemFull -> m (FailOrCmd ())
verifyToolEffect LevelId
lid CStore
store ItemFull
itemFull = do
  CCUI{coscreen=ScreenContent{rwidth}} <- (SessionUI -> CCUI) -> m CCUI
forall a. (SessionUI -> a) -> m a
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> CCUI
sccui
  side <- getsClient sside
  localTime <- getsState $ getLocalTime lid
  factionD <- getsState sfactionD
  let (name1, powers) = partItemShort rwidth side factionD localTime
                                      itemFull quantSingle
      objectA = [Part] -> Text
makePhrase [Part -> Part
MU.AW Part
name1, Part
powers]
      -- "Potentially", because an unidentified items on the ground can take
      -- precedence (perhaps placed there in order to get identified!).
      prompt = Text
"Do you really want to transform the terrain potentially using"
               Text -> Text -> Text
<+> Text
objectA Text -> Text -> Text
<+> CStore -> Text
ppCStoreIn CStore
store
               Text -> Text -> Text
<+> Text
"that may cause substantial side-effects?"
      objectThe = [Part] -> Text
makePhrase [Part
"the", Part
name1]
  go <- displayYesNo ColorBW prompt
  if not go
  then failWith $ "replace" <+> objectThe <+> "and try again"
         -- question capitalized and ended with a dot, answer neither
  else return $ Right ()

-- * AlterWithPointer

-- | Try to alter a tile using a feature under the pointer.
alterWithPointerHuman :: MonadClientUI m
                      => ActorId -> m (FailOrCmd RequestTimed)
alterWithPointerHuman :: forall (m :: * -> *).
MonadClientUI m =>
ActorId -> m (FailOrCmd RequestTimed)
alterWithPointerHuman ActorId
leader = do
  COps{corule=RuleContent{rWidthMax, rHeightMax}} <- (State -> COps) -> m COps
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  pUI <- getsSession spointer
  let p = PointSquare -> Point
squareToMap (PointSquare -> Point) -> PointSquare -> Point
forall a b. (a -> b) -> a -> b
$ PointUI -> PointSquare
uiToSquare PointUI
pUI
  if insideP (0, 0, rWidthMax - 1, rHeightMax - 1) p
  then alterTileAtPos leader p
  else failWith "never mind"

-- * CloseDir

-- | Close nearby open tile; ask for direction, if there is more than one.
closeDirHuman :: MonadClientUI m
              => ActorId -> m (FailOrCmd RequestTimed)
closeDirHuman :: forall (m :: * -> *).
MonadClientUI m =>
ActorId -> m (FailOrCmd RequestTimed)
closeDirHuman ActorId
leader = do
  COps{coTileSpeedup} <- (State -> COps) -> m COps
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  b <- getsState $ getActorBody leader
  lvl <- getLevel $ blid b
  let vPts = Point -> [Point]
vicinityUnsafe (Point -> [Point]) -> Point -> [Point]
forall a b. (a -> b) -> a -> b
$ Actor -> Point
bpos Actor
b
      openPts = (Point -> Bool) -> [Point] -> [Point]
forall a. (a -> Bool) -> [a] -> [a]
filter (TileSpeedup -> ContentId TileKind -> Bool
Tile.isClosable TileSpeedup
coTileSpeedup (ContentId TileKind -> Bool)
-> (Point -> ContentId TileKind) -> Point -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Level -> Point -> ContentId TileKind
at Level
lvl) [Point]
vPts
  case openPts of
    []  -> ReqFailure -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a.
MonadClientUI m =>
ReqFailure -> m (FailOrCmd a)
failSer ReqFailure
CloseNothing
    [Point
o] -> ActorId -> Point -> m (FailOrCmd RequestTimed)
forall (m :: * -> *).
MonadClientUI m =>
ActorId -> Point -> m (FailOrCmd RequestTimed)
closeTileAtPos ActorId
leader Point
o
    [Point]
_   -> ActorId -> Text -> m (Maybe Point)
forall (m :: * -> *).
MonadClientUI m =>
ActorId -> Text -> m (Maybe Point)
pickPoint ActorId
leader Text
"close" m (Maybe Point)
-> (Maybe Point -> m (FailOrCmd RequestTimed))
-> m (FailOrCmd RequestTimed)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe Point
Nothing -> Text -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith Text
"never mind"
      Just Point
p -> ActorId -> Point -> m (FailOrCmd RequestTimed)
forall (m :: * -> *).
MonadClientUI m =>
ActorId -> Point -> m (FailOrCmd RequestTimed)
closeTileAtPos ActorId
leader Point
p

-- | Close tile at given position.
closeTileAtPos :: MonadClientUI m
               => ActorId -> Point -> m (FailOrCmd RequestTimed)
closeTileAtPos :: forall (m :: * -> *).
MonadClientUI m =>
ActorId -> Point -> m (FailOrCmd RequestTimed)
closeTileAtPos ActorId
leader Point
tpos = do
  COps{coTileSpeedup} <- (State -> COps) -> m COps
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  actorCurAndMaxSk <- getsState $ getActorMaxSkills leader
  b <- getsState $ getActorBody leader
  alterable <- getsState $ tileAlterable (blid b) tpos
  lvl <- getLevel $ blid b
  let alterSkill = Skill -> Skills -> Int
Ability.getSk Skill
Ability.SkAlter Skills
actorCurAndMaxSk
      t = Level
lvl Level -> Point -> ContentId TileKind
`at` Point
tpos
      isOpen = TileSpeedup -> ContentId TileKind -> Bool
Tile.isClosable TileSpeedup
coTileSpeedup ContentId TileKind
t
      isClosed = TileSpeedup -> ContentId TileKind -> Bool
Tile.isOpenable TileSpeedup
coTileSpeedup ContentId TileKind
t
  case (alterable, isClosed, isOpen) of
    (Bool
False, Bool
_, Bool
_) -> ReqFailure -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a.
MonadClientUI m =>
ReqFailure -> m (FailOrCmd a)
failSer ReqFailure
CloseNothing
    (Bool
True, Bool
False, Bool
False) -> ReqFailure -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a.
MonadClientUI m =>
ReqFailure -> m (FailOrCmd a)
failSer ReqFailure
CloseNonClosable
    (Bool
True, Bool
True,  Bool
False) -> ReqFailure -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a.
MonadClientUI m =>
ReqFailure -> m (FailOrCmd a)
failSer ReqFailure
CloseClosed
    (Bool
True, Bool
True,  Bool
True) -> String -> m (FailOrCmd RequestTimed)
forall a. (?callStack::CallStack) => String -> a
error String
"TileKind content validation"
    (Bool
True, Bool
False, Bool
True) ->
      if | Point
tpos Point -> Point -> Int
`chessDist` Actor -> Point
bpos Actor
b Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
          -> ReqFailure -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a.
MonadClientUI m =>
ReqFailure -> m (FailOrCmd a)
failSer ReqFailure
CloseDistant
         | Int
alterSkill Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1
          -> ReqFailure -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a.
MonadClientUI m =>
ReqFailure -> m (FailOrCmd a)
failSer ReqFailure
AlterUnskilled
         | Point -> EnumMap Point ItemBag -> Bool
forall k a. Enum k => k -> EnumMap k a -> Bool
EM.member Point
tpos (EnumMap Point ItemBag -> Bool) -> EnumMap Point ItemBag -> Bool
forall a b. (a -> b) -> a -> b
$ Level -> EnumMap Point ItemBag
lfloor Level
lvl
          -> ReqFailure -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a.
MonadClientUI m =>
ReqFailure -> m (FailOrCmd a)
failSer ReqFailure
AlterBlockItem
         | Point -> Level -> Bool
occupiedBigLvl Point
tpos Level
lvl Bool -> Bool -> Bool
|| Point -> Level -> Bool
occupiedProjLvl Point
tpos Level
lvl
          -> ReqFailure -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a.
MonadClientUI m =>
ReqFailure -> m (FailOrCmd a)
failSer ReqFailure
AlterBlockActor
         | Bool
otherwise
          -> do
             Bool -> ActorId -> Point -> Text -> m ()
forall (m :: * -> *).
MonadClientUI m =>
Bool -> ActorId -> Point -> Text -> m ()
msgAddDone Bool
True ActorId
leader Point
tpos Text
"close"
             FailOrCmd RequestTimed -> m (FailOrCmd RequestTimed)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FailOrCmd RequestTimed -> m (FailOrCmd RequestTimed))
-> FailOrCmd RequestTimed -> m (FailOrCmd RequestTimed)
forall a b. (a -> b) -> a -> b
$ RequestTimed -> FailOrCmd RequestTimed
forall a b. b -> Either a b
Right (Point -> RequestTimed
ReqAlter Point
tpos)

-- | Adds message with proper names.
msgAddDone :: MonadClientUI m => Bool -> ActorId -> Point -> Text -> m ()
msgAddDone :: forall (m :: * -> *).
MonadClientUI m =>
Bool -> ActorId -> Point -> Text -> m ()
msgAddDone Bool
mentionTile ActorId
leader Point
p Text
verb = do
  COps{cotile} <- (State -> COps) -> m COps
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  b <- getsState $ getActorBody leader
  lvl <- getLevel $ blid b
  let tname = TileKind -> Text
TK.tname (TileKind -> Text) -> TileKind -> Text
forall a b. (a -> b) -> a -> b
$ ContentData TileKind -> ContentId TileKind -> TileKind
forall a. ContentData a -> ContentId a -> a
okind ContentData TileKind
cotile (ContentId TileKind -> TileKind) -> ContentId TileKind -> TileKind
forall a b. (a -> b) -> a -> b
$ Level
lvl Level -> Point -> ContentId TileKind
`at` Point
p
      s = case Text -> [Text]
T.words Text
tname of
            [] -> Text
"thing"
            (Text
"open" : [Text]
xs) -> [Text] -> Text
T.unwords [Text]
xs
            [Text]
_ -> Text
tname
      object | Bool
mentionTile = Text
"the" Text -> Text -> Text
<+> Text
s
             | Bool
otherwise = Text
""
      v = Point
p Point -> Point -> Vector
`vectorToFrom` Actor -> Point
bpos Actor
b
      dir | Vector
v Vector -> Vector -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> Int -> Vector
Vector Int
0 Int
0 = Text
"underneath"
          | Bool
otherwise = Vector -> Text
compassText Vector
v
  msgAdd MsgActionComplete $ "You" <+> verb <+> object <+> dir <> "."

-- | Prompts user to pick a point.
pickPoint :: MonadClientUI m => ActorId -> Text -> m (Maybe Point)
pickPoint :: forall (m :: * -> *).
MonadClientUI m =>
ActorId -> Text -> m (Maybe Point)
pickPoint ActorId
leader Text
verb = do
  b <- (State -> Actor) -> m Actor
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
leader
  UIOptions{uVi, uLeftHand} <- getsSession sUIOptions
  let dirKeys = Bool -> Bool -> [Key]
K.dirAllKey Bool
uVi Bool
uLeftHand
      keys = KM
K.escKM
           KM -> [KM] -> [KM]
forall a. a -> [a] -> [a]
: KM
K.leftButtonReleaseKM
           KM -> [KM] -> [KM]
forall a. a -> [a] -> [a]
: (Key -> KM) -> [Key] -> [KM]
forall a b. (a -> b) -> [a] -> [b]
map (Modifier -> Key -> KM
K.KM Modifier
K.NoModifier) [Key]
dirKeys
  msgAdd MsgPromptGeneric $ "Where to" <+> verb <> "? [movement key] [pointer]"
  slides <- reportToSlideshow [K.escKM]
  km <- getConfirms ColorFull keys slides
  case K.key km of
    Key
K.LeftButtonRelease -> do
      pUI <- (SessionUI -> PointUI) -> m PointUI
forall a. (SessionUI -> a) -> m a
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> PointUI
spointer
      let p = PointSquare -> Point
squareToMap (PointSquare -> Point) -> PointSquare -> Point
forall a b. (a -> b) -> a -> b
$ PointUI -> PointSquare
uiToSquare PointUI
pUI
      return $ Just p
    Key
_ -> Maybe Point -> m (Maybe Point)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Point -> m (Maybe Point)) -> Maybe Point -> m (Maybe Point)
forall a b. (a -> b) -> a -> b
$ Point -> Vector -> Point
shift (Actor -> Point
bpos Actor
b) (Vector -> Point) -> Maybe Vector -> Maybe Point
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Key] -> KM -> Maybe Vector
K.handleDir [Key]
dirKeys KM
km

-- * Help

-- | Display command help.
helpHuman :: MonadClientUI m
          => (K.KM -> HumanCmd -> m (Either MError ReqUI))
          -> m (Either MError ReqUI)
helpHuman :: forall (m :: * -> *).
MonadClientUI m =>
(KM -> HumanCmd -> m (Either MError ReqUI))
-> m (Either MError ReqUI)
helpHuman KM -> HumanCmd -> m (Either MError ReqUI)
cmdSemInCxtOfKM = do
  ccui@CCUI{coinput, coscreen=ScreenContent{rwidth, rheight, rintroScreen}}
    <- (SessionUI -> CCUI) -> m CCUI
forall a. (SessionUI -> a) -> m a
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> CCUI
sccui
  fontSetup@FontSetup{..} <- getFontSetup
  gameModeId <- getsState sgameModeId
  modeOv <- describeMode True gameModeId
  curTutorial <- getsSession scurTutorial
  overrideTut <- getsSession soverrideTut
  let displayTutorialHints = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
curTutorial Maybe Bool
overrideTut
      modeH = ( Text
"Press SPACE or PGDN to advance or ESC to see the map again."
              , (EnumMap DisplayFont Overlay
modeOv, []) )
      keyH = CCUI -> FontSetup -> [(Text, (EnumMap DisplayFont Overlay, [KYX]))]
keyHelp CCUI
ccui FontSetup
fontSetup
      -- This takes a list of paragraphs and returns a list of screens.
      -- Both paragraph and screen is a list of lines.
      --
      -- This would be faster, but less clear, if paragraphs were stored
      -- reversed in content. Not worth it, until we have huge manuals
      -- or run on weak mobiles. Even then, precomputation during
      -- compilation may be better.
      --
      -- Empty lines may appear at the end of pages, but it's fine,
      -- it means there is a new section on the next page.
      packIntoScreens :: [[String]] -> [[String]] -> Int -> [[String]]
      packIntoScreens [] [[String]]
acc Int
_ = [[String] -> [[String]] -> [String]
forall a. [a] -> [[a]] -> [a]
intercalate [String
""] ([[String]] -> [[String]]
forall a. [a] -> [a]
reverse [[String]]
acc)]
      packIntoScreens ([] : [[String]]
ls) [] Int
_  =
        -- Ignore empty paragraphs at the start of screen.
        [[String]] -> [[String]] -> Int -> [[String]]
packIntoScreens [[String]]
ls [] Int
0
      packIntoScreens ([String]
l : [[String]]
ls) [] Int
h = Bool -> [[String]] -> [[String]]
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Int
h Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) ([[String]] -> [[String]]) -> [[String]] -> [[String]]
forall a b. (a -> b) -> a -> b
$
        -- If a paragraph, even alone, is longer than screen height, it's split.
        if [String] -> Int
forall a. [a] -> Int
length [String]
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
rheight Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
3
        then [[String]] -> [[String]] -> Int -> [[String]]
packIntoScreens [[String]]
ls [[String]
l] ([String] -> Int
forall a. [a] -> Int
length [String]
l)
        else let ([String]
screen, [String]
rest) = Int -> [String] -> ([String], [String])
forall a. Int -> [a] -> ([a], [a])
splitAt (Int
rheight Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
3) [String]
l
             in [String]
screen [String] -> [[String]] -> [[String]]
forall a. a -> [a] -> [a]
: [[String]] -> [[String]] -> Int -> [[String]]
packIntoScreens ([String]
rest [String] -> [[String]] -> [[String]]
forall a. a -> [a] -> [a]
: [[String]]
ls) [] Int
0
      packIntoScreens ([String]
l : [[String]]
ls) [[String]]
acc Int
h =
        -- The extra @+ 1@ comes from the empty line separating paragraphs,
        -- as added in @intercalate@.
        if [String] -> Int
forall a. [a] -> Int
length [String]
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
h Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
rheight Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
3
        then [[String]] -> [[String]] -> Int -> [[String]]
packIntoScreens [[String]]
ls ([String]
l [String] -> [[String]] -> [[String]]
forall a. a -> [a] -> [a]
: [[String]]
acc) ([String] -> Int
forall a. [a] -> Int
length [String]
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
h)
        else [String] -> [[String]] -> [String]
forall a. [a] -> [[a]] -> [a]
intercalate [String
""] ([[String]] -> [[String]]
forall a. [a] -> [a]
reverse [[String]]
acc) [String] -> [[String]] -> [[String]]
forall a. a -> [a] -> [a]
: [[String]] -> [[String]] -> Int -> [[String]]
packIntoScreens ([String]
l [String] -> [[String]] -> [[String]]
forall a. a -> [a] -> [a]
: [[String]]
ls) [] Int
0
      manualScreens = [[String]] -> [[String]] -> Int -> [[String]]
packIntoScreens (([String], [[String]]) -> [[String]]
forall a b. (a, b) -> b
snd ([String], [[String]])
rintroScreen) [] Int
0
      sideBySide =
        if DisplayFont -> Bool
isSquareFont DisplayFont
monoFont
        then \([AttrLine]
screen1, [AttrLine]
screen2) ->  -- single column, two screens
          ([AttrLine] -> Overlay) -> [[AttrLine]] -> [Overlay]
forall a b. (a -> b) -> [a] -> [b]
map [AttrLine] -> Overlay
offsetOverlay ([[AttrLine]] -> [Overlay]) -> [[AttrLine]] -> [Overlay]
forall a b. (a -> b) -> a -> b
$ ([AttrLine] -> Bool) -> [[AttrLine]] -> [[AttrLine]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ([AttrLine] -> Bool) -> [AttrLine] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [AttrLine] -> Bool
forall a. [a] -> Bool
null) [[AttrLine]
screen1, [AttrLine]
screen2]
        else \([AttrLine]
screen1, [AttrLine]
screen2) ->  -- two columns, single screen
          [[AttrLine] -> Overlay
offsetOverlay [AttrLine]
screen1
           Overlay -> Overlay -> Overlay
forall a. [a] -> [a] -> [a]
++ Int -> Overlay -> Overlay
xtranslateOverlay Int
rwidth ([AttrLine] -> Overlay
offsetOverlay [AttrLine]
screen2)]
      listPairs ([a]
a : [a]
b : [[a]]
rest) = ([a]
a, [a]
b) ([a], [a]) -> [([a], [a])] -> [([a], [a])]
forall a. a -> [a] -> [a]
: [[a]] -> [([a], [a])]
listPairs [[a]]
rest
      listPairs [[a]
a] = [([a]
a, [])]
      listPairs [] = []
      -- Each screen begins with an empty line, to separate the header.
      manualOvs = (Overlay -> EnumMap DisplayFont Overlay)
-> [Overlay] -> [EnumMap DisplayFont Overlay]
forall a b. (a -> b) -> [a] -> [b]
map (DisplayFont -> Overlay -> EnumMap DisplayFont Overlay
forall k a. Enum k => k -> a -> EnumMap k a
EM.singleton DisplayFont
monoFont)
                  ([Overlay] -> [EnumMap DisplayFont Overlay])
-> [Overlay] -> [EnumMap DisplayFont Overlay]
forall a b. (a -> b) -> a -> b
$ (([AttrLine], [AttrLine]) -> [Overlay])
-> [([AttrLine], [AttrLine])] -> [Overlay]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([AttrLine], [AttrLine]) -> [Overlay]
sideBySide ([([AttrLine], [AttrLine])] -> [Overlay])
-> [([AttrLine], [AttrLine])] -> [Overlay]
forall a b. (a -> b) -> a -> b
$ [[AttrLine]] -> [([AttrLine], [AttrLine])]
forall {a}. [[a]] -> [([a], [a])]
listPairs
                  ([[AttrLine]] -> [([AttrLine], [AttrLine])])
-> [[AttrLine]] -> [([AttrLine], [AttrLine])]
forall a b. (a -> b) -> a -> b
$ ([String] -> [AttrLine]) -> [[String]] -> [[AttrLine]]
forall a b. (a -> b) -> [a] -> [b]
map ((AttrLine
emptyAttrLine AttrLine -> [AttrLine] -> [AttrLine]
forall a. a -> [a] -> [a]
:) ([AttrLine] -> [AttrLine])
-> ([String] -> [AttrLine]) -> [String] -> [AttrLine]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> AttrLine) -> [String] -> [AttrLine]
forall a b. (a -> b) -> [a] -> [b]
map String -> AttrLine
stringToAL) [[String]]
manualScreens
      addMnualHeader a
ov =
        ( a
"Showing PLAYING.md (best viewed in the browser)."
        , (a
ov, []) )
      manualH = (EnumMap DisplayFont Overlay
 -> (Text, (EnumMap DisplayFont Overlay, [KYX])))
-> [EnumMap DisplayFont Overlay]
-> [(Text, (EnumMap DisplayFont Overlay, [KYX]))]
forall a b. (a -> b) -> [a] -> [b]
map EnumMap DisplayFont Overlay
-> (Text, (EnumMap DisplayFont Overlay, [KYX]))
forall {a} {a} {a}. IsString a => a -> (a, (a, [a]))
addMnualHeader [EnumMap DisplayFont Overlay]
manualOvs
      splitHelp (Text
t, (EnumMap DisplayFont Overlay, [KYX])
okx) =
        FontSetup
-> Bool
-> Int
-> Int
-> Int
-> AttrString
-> [KM]
-> (EnumMap DisplayFont Overlay, [KYX])
-> [(EnumMap DisplayFont Overlay, [KYX])]
splitOKX FontSetup
fontSetup Bool
True Int
rwidth Int
rheight Int
rwidth (Text -> AttrString
textToAS Text
t)
                 [KM
K.spaceKM, KM
K.returnKM, KM
K.escKM] (EnumMap DisplayFont Overlay, [KYX])
okx
      sli = FontSetup
-> Bool -> [(EnumMap DisplayFont Overlay, [KYX])] -> Slideshow
toSlideshow FontSetup
fontSetup Bool
displayTutorialHints
            ([(EnumMap DisplayFont Overlay, [KYX])] -> Slideshow)
-> [(EnumMap DisplayFont Overlay, [KYX])] -> Slideshow
forall a b. (a -> b) -> a -> b
$ ((Text, (EnumMap DisplayFont Overlay, [KYX]))
 -> [(EnumMap DisplayFont Overlay, [KYX])])
-> [(Text, (EnumMap DisplayFont Overlay, [KYX]))]
-> [(EnumMap DisplayFont Overlay, [KYX])]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Text, (EnumMap DisplayFont Overlay, [KYX]))
-> [(EnumMap DisplayFont Overlay, [KYX])]
splitHelp ([(Text, (EnumMap DisplayFont Overlay, [KYX]))]
 -> [(EnumMap DisplayFont Overlay, [KYX])])
-> [(Text, (EnumMap DisplayFont Overlay, [KYX]))]
-> [(EnumMap DisplayFont Overlay, [KYX])]
forall a b. (a -> b) -> a -> b
$ (Text, (EnumMap DisplayFont Overlay, [KYX]))
modeH (Text, (EnumMap DisplayFont Overlay, [KYX]))
-> [(Text, (EnumMap DisplayFont Overlay, [KYX]))]
-> [(Text, (EnumMap DisplayFont Overlay, [KYX]))]
forall a. a -> [a] -> [a]
: [(Text, (EnumMap DisplayFont Overlay, [KYX]))]
keyH [(Text, (EnumMap DisplayFont Overlay, [KYX]))]
-> [(Text, (EnumMap DisplayFont Overlay, [KYX]))]
-> [(Text, (EnumMap DisplayFont Overlay, [KYX]))]
forall a. [a] -> [a] -> [a]
++ [(Text, (EnumMap DisplayFont Overlay, [KYX]))]
manualH
  -- Thus, the whole help menu corresponds to a single menu of item or lore,
  -- e.g., shared stash menu. This is especially clear when the shared stash
  -- menu contains many pages.
  ekm <- displayChoiceScreen "help" ColorFull True sli
                             [K.spaceKM, K.returnKM, K.escKM]
  case ekm of
    Left KM
km | KM
km KM -> [KM] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KM
K.escKM, KM
K.spaceKM] -> Either MError ReqUI -> m (Either MError ReqUI)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either MError ReqUI -> m (Either MError ReqUI))
-> Either MError ReqUI -> m (Either MError ReqUI)
forall a b. (a -> b) -> a -> b
$ MError -> Either MError ReqUI
forall a b. a -> Either a b
Left MError
forall a. Maybe a
Nothing
    Left KM
km | KM
km KM -> KM -> Bool
forall a. Eq a => a -> a -> Bool
== KM
K.returnKM -> do
      MsgClassShow -> Text -> m ()
forall (m :: * -> *) a.
(MonadClientUI m, MsgShared a) =>
a -> Text -> m ()
msgAdd MsgClassShow
MsgPromptGeneric Text
"Press RET when a command help text is selected to invoke the command."
      Either MError ReqUI -> m (Either MError ReqUI)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either MError ReqUI -> m (Either MError ReqUI))
-> Either MError ReqUI -> m (Either MError ReqUI)
forall a b. (a -> b) -> a -> b
$ MError -> Either MError ReqUI
forall a b. a -> Either a b
Left MError
forall a. Maybe a
Nothing
    Left KM
km -> case KM
km KM -> Map KM CmdTriple -> Maybe CmdTriple
forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` InputContent -> Map KM CmdTriple
bcmdMap InputContent
coinput of
      Just ([CmdCategory]
_desc, Text
_cats, HumanCmd
cmd) -> KM -> HumanCmd -> m (Either MError ReqUI)
cmdSemInCxtOfKM KM
km HumanCmd
cmd
      Maybe CmdTriple
Nothing -> FailOrCmd ReqUI -> Either MError ReqUI
forall a. FailOrCmd a -> Either MError a
weaveJust (FailOrCmd ReqUI -> Either MError ReqUI)
-> m (FailOrCmd ReqUI) -> m (Either MError ReqUI)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> m (FailOrCmd ReqUI)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith Text
"never mind"
    Right MenuSlot
_slot -> String -> m (Either MError ReqUI)
forall a. (?callStack::CallStack) => String -> a
error (String -> m (Either MError ReqUI))
-> String -> m (Either MError ReqUI)
forall a b. (a -> b) -> a -> b
$ String
"" String -> KeyOrSlot -> String
forall v. Show v => String -> v -> String
`showFailure` KeyOrSlot
ekm

-- * Hint

-- | Display hint or, if already displayed, display help.
hintHuman :: MonadClientUI m
          => (K.KM -> HumanCmd -> m (Either MError ReqUI))
          -> m (Either MError ReqUI)
hintHuman :: forall (m :: * -> *).
MonadClientUI m =>
(KM -> HumanCmd -> m (Either MError ReqUI))
-> m (Either MError ReqUI)
hintHuman KM -> HumanCmd -> m (Either MError ReqUI)
cmdSemInCxtOfKM = do
  sreportNull <- (SessionUI -> Bool) -> m Bool
forall a. (SessionUI -> a) -> m a
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> Bool
sreportNull
  if sreportNull then do
    promptMainKeys
    return $ Left Nothing
  else
    helpHuman cmdSemInCxtOfKM

-- * Dashboard

-- | Display the dashboard.
dashboardHuman :: MonadClientUI m
               => (K.KM -> HumanCmd -> m (Either MError ReqUI))
               -> m (Either MError ReqUI)
dashboardHuman :: forall (m :: * -> *).
MonadClientUI m =>
(KM -> HumanCmd -> m (Either MError ReqUI))
-> m (Either MError ReqUI)
dashboardHuman KM -> HumanCmd -> m (Either MError ReqUI)
cmdSemInCxtOfKM = do
  CCUI{coinput, coscreen=ScreenContent{rwidth, rheight}} <- (SessionUI -> CCUI) -> m CCUI
forall a. (SessionUI -> a) -> m a
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> CCUI
sccui
  fontSetup@FontSetup{..} <- getFontSetup
  curTutorial <- getsSession scurTutorial
  overrideTut <- getsSession soverrideTut
  let displayTutorialHints = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
curTutorial Maybe Bool
overrideTut
      offsetCol2 = Int
3
      (ov0, kxs0) = okxsN coinput monoFont propFont offsetCol2 (const False)
                          False CmdDashboard ([], [], []) ([], [])
      al1 = Text -> AttrString
textToAS Text
"Dashboard"
      splitHelp (AttrString
al, (EnumMap DisplayFont Overlay, [KYX])
okx) = FontSetup
-> Bool
-> Int
-> Int
-> Int
-> AttrString
-> [KM]
-> (EnumMap DisplayFont Overlay, [KYX])
-> [(EnumMap DisplayFont Overlay, [KYX])]
splitOKX FontSetup
fontSetup Bool
False Int
rwidth (Int
rheight Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2) Int
rwidth
                                     AttrString
al [KM
K.returnKM, KM
K.escKM] (EnumMap DisplayFont Overlay, [KYX])
okx
      sli = FontSetup
-> Bool -> [(EnumMap DisplayFont Overlay, [KYX])] -> Slideshow
toSlideshow FontSetup
fontSetup Bool
displayTutorialHints
            ([(EnumMap DisplayFont Overlay, [KYX])] -> Slideshow)
-> [(EnumMap DisplayFont Overlay, [KYX])] -> Slideshow
forall a b. (a -> b) -> a -> b
$ (AttrString, (EnumMap DisplayFont Overlay, [KYX]))
-> [(EnumMap DisplayFont Overlay, [KYX])]
splitHelp (AttrString
al1, (EnumMap DisplayFont Overlay
ov0, [KYX]
kxs0))
      extraKeys = [KM
K.returnKM, KM
K.escKM]
  ekm <- displayChoiceScreen "dashboard" ColorFull False sli extraKeys
  case ekm of
    Left KM
km -> case KM
km KM -> Map KM CmdTriple -> Maybe CmdTriple
forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` InputContent -> Map KM CmdTriple
bcmdMap InputContent
coinput of
      Maybe CmdTriple
_ | KM
km KM -> KM -> Bool
forall a. Eq a => a -> a -> Bool
== KM
K.escKM -> FailOrCmd ReqUI -> Either MError ReqUI
forall a. FailOrCmd a -> Either MError a
weaveJust (FailOrCmd ReqUI -> Either MError ReqUI)
-> m (FailOrCmd ReqUI) -> m (Either MError ReqUI)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> m (FailOrCmd ReqUI)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith Text
"never mind"
      Maybe CmdTriple
_ | KM
km KM -> KM -> Bool
forall a. Eq a => a -> a -> Bool
== KM
K.returnKM -> do
        MsgClassShow -> Text -> m ()
forall (m :: * -> *) a.
(MonadClientUI m, MsgShared a) =>
a -> Text -> m ()
msgAdd MsgClassShow
MsgPromptGeneric Text
"Press RET when a menu name is selected to browse the menu."
        Either MError ReqUI -> m (Either MError ReqUI)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either MError ReqUI -> m (Either MError ReqUI))
-> Either MError ReqUI -> m (Either MError ReqUI)
forall a b. (a -> b) -> a -> b
$ MError -> Either MError ReqUI
forall a b. a -> Either a b
Left MError
forall a. Maybe a
Nothing
      Just ([CmdCategory]
_desc, Text
_cats, HumanCmd
cmd) -> KM -> HumanCmd -> m (Either MError ReqUI)
cmdSemInCxtOfKM KM
km HumanCmd
cmd
      Maybe CmdTriple
Nothing -> FailOrCmd ReqUI -> Either MError ReqUI
forall a. FailOrCmd a -> Either MError a
weaveJust (FailOrCmd ReqUI -> Either MError ReqUI)
-> m (FailOrCmd ReqUI) -> m (Either MError ReqUI)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> m (FailOrCmd ReqUI)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith Text
"never mind"
    Right MenuSlot
_slot -> String -> m (Either MError ReqUI)
forall a. (?callStack::CallStack) => String -> a
error (String -> m (Either MError ReqUI))
-> String -> m (Either MError ReqUI)
forall a b. (a -> b) -> a -> b
$ String
"" String -> KeyOrSlot -> String
forall v. Show v => String -> v -> String
`showFailure` KeyOrSlot
ekm

-- * ItemMenu

itemMenuHuman :: MonadClientUI m
              => ActorId
              -> (K.KM -> HumanCmd -> m (Either MError ReqUI))
              -> m (Either MError ReqUI)
itemMenuHuman :: forall (m :: * -> *).
MonadClientUI m =>
ActorId
-> (KM -> HumanCmd -> m (Either MError ReqUI))
-> m (Either MError ReqUI)
itemMenuHuman ActorId
leader KM -> HumanCmd -> m (Either MError ReqUI)
cmdSemInCxtOfKM = do
  COps{corule} <- (State -> COps) -> m COps
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  itemSel <- getsSession sitemSel
  fontSetup@FontSetup{..} <- getFontSetup
  case itemSel of
    Just (ItemId
iid, CStore
fromCStore, Bool
_) -> do
      side <- (StateClient -> FactionId) -> m FactionId
forall a. (StateClient -> a) -> m a
forall (m :: * -> *) a.
MonadClientRead m =>
(StateClient -> a) -> m a
getsClient StateClient -> FactionId
sside
      b <- getsState $ getActorBody leader
      bUI <- getsSession $ getActorUI leader
      bag <- getsState $ getBodyStoreBag b fromCStore
      case iid `EM.lookup` bag of
        Maybe (Int, ItemTimers)
Nothing -> FailOrCmd ReqUI -> Either MError ReqUI
forall a. FailOrCmd a -> Either MError a
weaveJust (FailOrCmd ReqUI -> Either MError ReqUI)
-> m (FailOrCmd ReqUI) -> m (Either MError ReqUI)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> m (FailOrCmd ReqUI)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith Text
"no item to open item menu for"
        Just (Int, ItemTimers)
kit -> do
          CCUI{coscreen=ScreenContent{rwidth, rheight}} <- (SessionUI -> CCUI) -> m CCUI
forall a. (SessionUI -> a) -> m a
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> CCUI
sccui
          actorCurAndMaxSk <- getsState $ getActorMaxSkills leader
          itemFull <- getsState $ itemToFull iid
          localTime <- getsState $ getLocalTime (blid b)
          found <- getsState $ findIid leader side iid
          let !_A = Bool -> () -> ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Bool -> Bool
not ([(ActorId, (Actor, CStore))] -> Bool
forall a. [a] -> Bool
null [(ActorId, (Actor, CStore))]
found) Bool -> Bool -> Bool
|| CStore
fromCStore CStore -> CStore -> Bool
forall a. Eq a => a -> a -> Bool
== CStore
CGround
                            Bool -> (ItemId, ActorId) -> Bool
forall v. Show v => Bool -> v -> Bool
`blame` (ItemId
iid, ActorId
leader)) ()
              fAlt (ActorId
aid, (Actor
_, CStore
store)) = ActorId
aid ActorId -> ActorId -> Bool
forall a. Eq a => a -> a -> Bool
/= ActorId
leader Bool -> Bool -> Bool
|| CStore
store CStore -> CStore -> Bool
forall a. Eq a => a -> a -> Bool
/= CStore
fromCStore
              foundAlt = ((ActorId, (Actor, CStore)) -> Bool)
-> [(ActorId, (Actor, CStore))] -> [(ActorId, (Actor, CStore))]
forall a. (a -> Bool) -> [a] -> [a]
filter (ActorId, (Actor, CStore)) -> Bool
fAlt [(ActorId, (Actor, CStore))]
found
              markParagraphs = Int
rheight Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
45
              meleeSkill = Skill -> Skills -> Int
Ability.getSk Skill
Ability.SkHurtMelee Skills
actorCurAndMaxSk
              partRawActor ActorId
aid = (SessionUI -> Part) -> m Part
forall a. (SessionUI -> a) -> m a
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession (ActorUI -> Part
partActor (ActorUI -> Part) -> (SessionUI -> ActorUI) -> SessionUI -> Part
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ActorId -> SessionUI -> ActorUI
getActorUI ActorId
aid)
              ppLoc ActorId
aid CStore
store = do
                parts <- (ActorId -> m Part) -> Bool -> Container -> m [Part]
forall (m :: * -> *).
MonadClientUI m =>
(ActorId -> m Part) -> Bool -> Container -> m [Part]
ppContainerWownW ActorId -> m Part
forall {m :: * -> *}. MonadClientUI m => ActorId -> m Part
partRawActor
                                          Bool
False
                                          (ActorId -> CStore -> Container
CActor ActorId
aid CStore
store)
                return $! "[" ++ T.unpack (makePhrase parts) ++ "]"
              dmode = CStore -> ItemDialogMode
MStore CStore
fromCStore
          foundTexts <- mapM (\(ActorId
aid, (Actor
_, CStore
store)) -> ActorId -> CStore -> m String
forall {m :: * -> *}.
MonadClientUI m =>
ActorId -> CStore -> m String
ppLoc ActorId
aid CStore
store) foundAlt
          (ovLab, ovDesc) <-
            itemDescOverlays markParagraphs meleeSkill dmode iid kit
                             itemFull rwidth
          let foundPrefix = Text -> AttrString
textToAS (Text -> AttrString) -> Text -> AttrString
forall a b. (a -> b) -> a -> b
$
                if [String] -> Bool
forall a. [a] -> Bool
null [String]
foundTexts then Text
"" else Text
"The item is also in:"
              ovPrefix = Int -> Overlay -> Overlay
ytranslateOverlay (Overlay -> Int
forall a. [a] -> Int
length Overlay
ovDesc)
                         (Overlay -> Overlay) -> Overlay -> Overlay
forall a b. (a -> b) -> a -> b
$ [AttrLine] -> Overlay
offsetOverlay
                         ([AttrLine] -> Overlay) -> [AttrLine] -> Overlay
forall a b. (a -> b) -> a -> b
$ Int -> Int -> AttrString -> [AttrLine]
splitAttrString Int
rwidth Int
rwidth AttrString
foundPrefix
              ystart = Overlay -> Int
forall a. [a] -> Int
length Overlay
ovDesc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Overlay -> Int
forall a. [a] -> Int
length Overlay
ovPrefix Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
              xstart = DisplayFont -> AttrString -> Int
forall a. DisplayFont -> [a] -> Int
textSize DisplayFont
monoFont (AttrCharW32
Color.spaceAttrW32
                                          AttrCharW32 -> AttrString -> AttrString
forall a. a -> [a] -> [a]
: AttrLine -> AttrString
attrLine ((PointUI, AttrLine) -> AttrLine
forall a b. (a, b) -> b
snd ((PointUI, AttrLine) -> AttrLine)
-> (PointUI, AttrLine) -> AttrLine
forall a b. (a -> b) -> a -> b
$ Overlay -> (PointUI, AttrLine)
forall a. (?callStack::CallStack) => [a] -> a
last Overlay
ovPrefix))
              foundKeys = (Int -> KM) -> [Int] -> [KM]
forall a b. (a -> b) -> [a] -> [b]
map (Modifier -> Key -> KM
K.KM Modifier
K.NoModifier (Key -> KM) -> (Int -> Key) -> Int -> KM
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Key
K.Fun)
                              [Int
1 .. [(ActorId, (Actor, CStore))] -> Int
forall a. [a] -> Int
length [(ActorId, (Actor, CStore))]
foundAlt]  -- starting from 1!
          let ks = [KM] -> [String] -> [(KM, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [KM]
foundKeys [String]
foundTexts
              width = if DisplayFont -> Bool
isSquareFont DisplayFont
monoFont then Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
rwidth else Int
rwidth
              (ovFoundRaw, kxsFound) = wrapOKX monoFont ystart xstart width ks
              ovFound = Overlay
ovPrefix Overlay -> Overlay -> Overlay
forall a. [a] -> [a] -> [a]
++ Overlay
ovFoundRaw
          report <- getReportUI True
          CCUI{coinput} <- getsSession sccui
          mstash <- getsState $ \State
s -> Faction -> Maybe (LevelId, Point)
gstash (Faction -> Maybe (LevelId, Point))
-> Faction -> Maybe (LevelId, Point)
forall a b. (a -> b) -> a -> b
$ State -> EnumMap FactionId Faction
sfactionD State
s EnumMap FactionId Faction -> FactionId -> Faction
forall k a. Enum k => EnumMap k a -> k -> a
EM.! FactionId
side
          curTutorial <- getsSession scurTutorial
          overrideTut <- getsSession soverrideTut
          let displayTutorialHints = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
curTutorial Maybe Bool
overrideTut
              calmE = Actor -> Skills -> Bool
calmEnough Actor
b Skills
actorCurAndMaxSk
              greyedOut HumanCmd
cmd = Bool -> Bool
not Bool
calmE Bool -> Bool -> Bool
&& CStore
fromCStore CStore -> CStore -> Bool
forall a. Eq a => a -> a -> Bool
== CStore
CEqp
                              Bool -> Bool -> Bool
|| Maybe (LevelId, Point)
mstash Maybe (LevelId, Point) -> Maybe (LevelId, Point) -> Bool
forall a. Eq a => a -> a -> Bool
== (LevelId, Point) -> Maybe (LevelId, Point)
forall a. a -> Maybe a
Just (Actor -> LevelId
blid Actor
b, Actor -> Point
bpos Actor
b)
                                 Bool -> Bool -> Bool
&& CStore
fromCStore CStore -> CStore -> Bool
forall a. Eq a => a -> a -> Bool
== CStore
CGround
                              Bool -> Bool -> Bool
|| case HumanCmd
cmd of
                ByAimMode AimModeCmd{HumanCmd
exploration :: HumanCmd
aiming :: HumanCmd
aiming :: AimModeCmd -> HumanCmd
exploration :: AimModeCmd -> HumanCmd
..} ->
                  HumanCmd -> Bool
greyedOut HumanCmd
exploration Bool -> Bool -> Bool
|| HumanCmd -> Bool
greyedOut HumanCmd
aiming
                ComposeIfLocal HumanCmd
cmd1 HumanCmd
cmd2 -> HumanCmd -> Bool
greyedOut HumanCmd
cmd1 Bool -> Bool -> Bool
|| HumanCmd -> Bool
greyedOut HumanCmd
cmd2
                ComposeUnlessError HumanCmd
cmd1 HumanCmd
cmd2 -> HumanCmd -> Bool
greyedOut HumanCmd
cmd1 Bool -> Bool -> Bool
|| HumanCmd -> Bool
greyedOut HumanCmd
cmd2
                Compose2ndLocal HumanCmd
cmd1 HumanCmd
cmd2 -> HumanCmd -> Bool
greyedOut HumanCmd
cmd1 Bool -> Bool -> Bool
|| HumanCmd -> Bool
greyedOut HumanCmd
cmd2
                MoveItem [CStore]
stores CStore
destCStore Maybe Text
_ Bool
_ ->
                  CStore
fromCStore CStore -> [CStore] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [CStore]
stores
                  Bool -> Bool -> Bool
|| CStore
destCStore CStore -> CStore -> Bool
forall a. Eq a => a -> a -> Bool
== CStore
CEqp Bool -> Bool -> Bool
&& (Bool -> Bool
not Bool
calmE Bool -> Bool -> Bool
|| Actor -> Int -> Bool
eqpOverfull Actor
b Int
1)
                  Bool -> Bool -> Bool
|| CStore
destCStore CStore -> CStore -> Bool
forall a. Eq a => a -> a -> Bool
== CStore
CGround Bool -> Bool -> Bool
&& Maybe (LevelId, Point)
mstash Maybe (LevelId, Point) -> Maybe (LevelId, Point) -> Bool
forall a. Eq a => a -> a -> Bool
== (LevelId, Point) -> Maybe (LevelId, Point)
forall a. a -> Maybe a
Just (Actor -> LevelId
blid Actor
b, Actor -> Point
bpos Actor
b)
                Apply{} ->
                  let skill :: Int
skill = Skill -> Skills -> Int
Ability.getSk Skill
Ability.SkApply Skills
actorCurAndMaxSk
                  in Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Either ReqFailure Bool -> Bool
forall b a. b -> Either a b -> b
fromRight Bool
False
                         (Either ReqFailure Bool -> Bool) -> Either ReqFailure Bool -> Bool
forall a b. (a -> b) -> a -> b
$ RuleContent
-> Time
-> Int
-> Bool
-> Maybe CStore
-> ItemFull
-> (Int, ItemTimers)
-> Either ReqFailure Bool
permittedApply RuleContent
corule Time
localTime Int
skill Bool
calmE
                                          (CStore -> Maybe CStore
forall a. a -> Maybe a
Just CStore
fromCStore) ItemFull
itemFull (Int, ItemTimers)
kit
                Project{} ->
                  let skill :: Int
skill = Skill -> Skills -> Int
Ability.getSk Skill
Ability.SkProject Skills
actorCurAndMaxSk
                  in Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Either ReqFailure Bool -> Bool
forall b a. b -> Either a b -> b
fromRight Bool
False
                         (Either ReqFailure Bool -> Bool) -> Either ReqFailure Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Int -> Bool -> ItemFull -> Either ReqFailure Bool
permittedProject Bool
False Int
skill Bool
calmE ItemFull
itemFull
                HumanCmd
_ -> Bool
False
              fmt Int
n Text
k Text
h = Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Char -> Text -> Text
T.justifyLeft Int
n Char
' ' Text
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
h
              offsetCol2 = Int
11
              keyCaption = Int -> Text -> Text -> Text
fmt Int
offsetCol2 Text
"keys" Text
"command"
              offset = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Overlay -> Int
maxYofOverlay (Overlay
ovDesc Overlay -> Overlay -> Overlay
forall a. [a] -> [a] -> [a]
++ Overlay
ovFound)
              (ov0, kxs0) = xytranslateOKX 0 offset $
                 okxsN coinput monoFont propFont offsetCol2 greyedOut
                       True CmdItemMenu ([], [], ["", keyCaption]) ([], [])
              t0 = [Part] -> Text
makeSentence [ Part -> Part -> Part
MU.SubjectVerbSg (ActorUI -> Part
partActor ActorUI
bUI) Part
"choose"
                                , Part
"an item", Text -> Part
MU.Text (Text -> Part) -> Text -> Part
forall a b. (a -> b) -> a -> b
$ CStore -> Text
ppCStoreIn CStore
fromCStore ]
              alRep = (AttrString -> AttrString -> AttrString)
-> AttrString -> [AttrString] -> AttrString
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr AttrString -> AttrString -> AttrString
(<+:>) [] ([AttrString] -> AttrString) -> [AttrString] -> AttrString
forall a b. (a -> b) -> a -> b
$ Bool -> Report -> [AttrString]
renderReport Bool
True Report
report
              al1 | AttrString -> Bool
forall a. [a] -> Bool
null AttrString
alRep = Text -> AttrString
textToAS Text
t0
                  | Bool
otherwise = AttrString
alRep AttrString -> AttrString -> AttrString
forall a. [a] -> [a] -> [a]
++ String -> AttrString
stringToAS String
"\n" AttrString -> AttrString -> AttrString
forall a. [a] -> [a] -> [a]
++ Text -> AttrString
textToAS Text
t0
              splitHelp (AttrString
al, (EnumMap DisplayFont Overlay, [KYX])
okx) =
                FontSetup
-> Bool
-> Int
-> Int
-> Int
-> AttrString
-> [KM]
-> (EnumMap DisplayFont Overlay, [KYX])
-> [(EnumMap DisplayFont Overlay, [KYX])]
splitOKX FontSetup
fontSetup Bool
False Int
rwidth (Int
rheight Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2) Int
rwidth AttrString
al
                         [KM
K.spaceKM, KM
K.escKM] (EnumMap DisplayFont Overlay, [KYX])
okx
              sli = FontSetup
-> Bool -> [(EnumMap DisplayFont Overlay, [KYX])] -> Slideshow
toSlideshow FontSetup
fontSetup Bool
displayTutorialHints
                    ([(EnumMap DisplayFont Overlay, [KYX])] -> Slideshow)
-> [(EnumMap DisplayFont Overlay, [KYX])] -> Slideshow
forall a b. (a -> b) -> a -> b
$ (AttrString, (EnumMap DisplayFont Overlay, [KYX]))
-> [(EnumMap DisplayFont Overlay, [KYX])]
splitHelp ( AttrString
al1
                                , ( (Overlay -> Overlay -> Overlay)
-> DisplayFont
-> Overlay
-> EnumMap DisplayFont Overlay
-> EnumMap DisplayFont Overlay
forall k a.
Enum k =>
(a -> a -> a) -> k -> a -> EnumMap k a -> EnumMap k a
EM.insertWith Overlay -> Overlay -> Overlay
forall a. [a] -> [a] -> [a]
(++) DisplayFont
squareFont Overlay
ovLab
                                    (EnumMap DisplayFont Overlay -> EnumMap DisplayFont Overlay)
-> EnumMap DisplayFont Overlay -> EnumMap DisplayFont Overlay
forall a b. (a -> b) -> a -> b
$ (Overlay -> Overlay -> Overlay)
-> DisplayFont
-> Overlay
-> EnumMap DisplayFont Overlay
-> EnumMap DisplayFont Overlay
forall k a.
Enum k =>
(a -> a -> a) -> k -> a -> EnumMap k a -> EnumMap k a
EM.insertWith Overlay -> Overlay -> Overlay
forall a. [a] -> [a] -> [a]
(++) DisplayFont
propFont Overlay
ovDesc
                                    (EnumMap DisplayFont Overlay -> EnumMap DisplayFont Overlay)
-> EnumMap DisplayFont Overlay -> EnumMap DisplayFont Overlay
forall a b. (a -> b) -> a -> b
$ (Overlay -> Overlay -> Overlay)
-> DisplayFont
-> Overlay
-> EnumMap DisplayFont Overlay
-> EnumMap DisplayFont Overlay
forall k a.
Enum k =>
(a -> a -> a) -> k -> a -> EnumMap k a -> EnumMap k a
EM.insertWith Overlay -> Overlay -> Overlay
forall a. [a] -> [a] -> [a]
(++) DisplayFont
monoFont Overlay
ovFound EnumMap DisplayFont Overlay
ov0
                                        -- mono font, because there are buttons
                                  , [KYX]
kxsFound [KYX] -> [KYX] -> [KYX]
forall a. [a] -> [a] -> [a]
++ [KYX]
kxs0 ))
              extraKeys = [KM
K.spaceKM, KM
K.escKM] [KM] -> [KM] -> [KM]
forall a. [a] -> [a] -> [a]
++ [KM]
foundKeys
          recordHistory  -- report shown (e.g., leader switch), save to history
          ekm <- displayChoiceScreen "item menu" ColorFull False sli extraKeys
          case ekm of
            Left KM
km -> case KM
km KM -> Map KM CmdTriple -> Maybe CmdTriple
forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` InputContent -> Map KM CmdTriple
bcmdMap InputContent
coinput of
              Maybe CmdTriple
_ | KM
km KM -> KM -> Bool
forall a. Eq a => a -> a -> Bool
== KM
K.escKM -> FailOrCmd ReqUI -> Either MError ReqUI
forall a. FailOrCmd a -> Either MError a
weaveJust (FailOrCmd ReqUI -> Either MError ReqUI)
-> m (FailOrCmd ReqUI) -> m (Either MError ReqUI)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> m (FailOrCmd ReqUI)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith Text
"never mind"
              Maybe CmdTriple
_ | KM
km KM -> KM -> Bool
forall a. Eq a => a -> a -> Bool
== KM
K.spaceKM ->
                ActorId
-> (KM -> HumanCmd -> m (Either MError ReqUI))
-> ItemDialogMode
-> m (Either MError ReqUI)
forall (m :: * -> *).
MonadClientUI m =>
ActorId
-> (KM -> HumanCmd -> m (Either MError ReqUI))
-> ItemDialogMode
-> m (Either MError ReqUI)
chooseItemMenuHuman ActorId
leader KM -> HumanCmd -> m (Either MError ReqUI)
cmdSemInCxtOfKM ItemDialogMode
dmode
              Maybe CmdTriple
_ | KM
km KM -> [KM] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KM]
foundKeys -> case KM
km of
                K.KM{key :: KM -> Key
key=K.Fun Int
n} -> do
                  let (ActorId
newAid, (Actor
bNew, CStore
newCStore)) = [(ActorId, (Actor, CStore))]
foundAlt [(ActorId, (Actor, CStore))] -> Int -> (ActorId, (Actor, CStore))
forall a. (?callStack::CallStack) => [a] -> Int -> a
!! (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
                  fact <- (State -> Faction) -> m Faction
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Faction) -> m Faction)
-> (State -> Faction) -> m Faction
forall a b. (a -> b) -> a -> b
$ (EnumMap FactionId Faction -> FactionId -> Faction
forall k a. Enum k => EnumMap k a -> k -> a
EM.! FactionId
side) (EnumMap FactionId Faction -> Faction)
-> (State -> EnumMap FactionId Faction) -> State -> Faction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> EnumMap FactionId Faction
sfactionD
                  let banned = Faction -> Bool
bannedPointmanSwitchBetweenLevels Faction
fact
                  if blid bNew /= blid b && banned
                  then weaveJust <$> failSer NoChangeDunLeader
                  else do
                    -- Verbosity not necessary to notice the switch
                    -- and it's explicitly requested, so no surprise.
                    void $ pickLeader False newAid
                    modifySession $ \SessionUI
sess ->
                      SessionUI
sess {sitemSel = Just (iid, newCStore, False)}
                    itemMenuHuman newAid cmdSemInCxtOfKM
                KM
_ -> String -> m (Either MError ReqUI)
forall a. (?callStack::CallStack) => String -> a
error (String -> m (Either MError ReqUI))
-> String -> m (Either MError ReqUI)
forall a b. (a -> b) -> a -> b
$ String
"" String -> KM -> String
forall v. Show v => String -> v -> String
`showFailure` KM
km
              Just ([CmdCategory]
_desc, Text
_cats, HumanCmd
cmd) -> do
                (SessionUI -> SessionUI) -> m ()
forall (m :: * -> *).
MonadClientUI m =>
(SessionUI -> SessionUI) -> m ()
modifySession ((SessionUI -> SessionUI) -> m ())
-> (SessionUI -> SessionUI) -> m ()
forall a b. (a -> b) -> a -> b
$ \SessionUI
sess ->
                  SessionUI
sess {sitemSel = Just (iid, fromCStore, True)}
                KM -> HumanCmd -> m (Either MError ReqUI)
cmdSemInCxtOfKM KM
km HumanCmd
cmd
              Maybe CmdTriple
Nothing -> FailOrCmd ReqUI -> Either MError ReqUI
forall a. FailOrCmd a -> Either MError a
weaveJust (FailOrCmd ReqUI -> Either MError ReqUI)
-> m (FailOrCmd ReqUI) -> m (Either MError ReqUI)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> m (FailOrCmd ReqUI)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith Text
"never mind"
            Right MenuSlot
_slot -> String -> m (Either MError ReqUI)
forall a. (?callStack::CallStack) => String -> a
error (String -> m (Either MError ReqUI))
-> String -> m (Either MError ReqUI)
forall a b. (a -> b) -> a -> b
$ String
"" String -> KeyOrSlot -> String
forall v. Show v => String -> v -> String
`showFailure` KeyOrSlot
ekm
    Maybe (ItemId, CStore, Bool)
Nothing -> FailOrCmd ReqUI -> Either MError ReqUI
forall a. FailOrCmd a -> Either MError a
weaveJust (FailOrCmd ReqUI -> Either MError ReqUI)
-> m (FailOrCmd ReqUI) -> m (Either MError ReqUI)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> m (FailOrCmd ReqUI)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith Text
"no item to open item menu for"

-- * ChooseItemMenu

chooseItemMenuHuman :: MonadClientUI m
                    => ActorId
                    -> (K.KM -> HumanCmd -> m (Either MError ReqUI))
                    -> ItemDialogMode
                    -> m (Either MError ReqUI)
chooseItemMenuHuman :: forall (m :: * -> *).
MonadClientUI m =>
ActorId
-> (KM -> HumanCmd -> m (Either MError ReqUI))
-> ItemDialogMode
-> m (Either MError ReqUI)
chooseItemMenuHuman ActorId
leader1 KM -> HumanCmd -> m (Either MError ReqUI)
cmdSemInCxtOfKM ItemDialogMode
c1 = do
  res2 <- ActorId -> Bool -> ItemDialogMode -> m (FailOrCmd ActorId)
forall (m :: * -> *).
MonadClientUI m =>
ActorId -> Bool -> ItemDialogMode -> m (FailOrCmd ActorId)
chooseItemDialogMode ActorId
leader1 Bool
True ItemDialogMode
c1
  case res2 of
    Right ActorId
leader2 -> ActorId
-> (KM -> HumanCmd -> m (Either MError ReqUI))
-> m (Either MError ReqUI)
forall (m :: * -> *).
MonadClientUI m =>
ActorId
-> (KM -> HumanCmd -> m (Either MError ReqUI))
-> m (Either MError ReqUI)
itemMenuHuman ActorId
leader2 KM -> HumanCmd -> m (Either MError ReqUI)
cmdSemInCxtOfKM
    Left FailError
err -> Either MError ReqUI -> m (Either MError ReqUI)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either MError ReqUI -> m (Either MError ReqUI))
-> Either MError ReqUI -> m (Either MError ReqUI)
forall a b. (a -> b) -> a -> b
$ MError -> Either MError ReqUI
forall a b. a -> Either a b
Left (MError -> Either MError ReqUI) -> MError -> Either MError ReqUI
forall a b. (a -> b) -> a -> b
$ FailError -> MError
forall a. a -> Maybe a
Just FailError
err

-- * MainMenu

generateMenu :: MonadClientUI m
             => (K.KM -> HumanCmd -> m (Either MError ReqUI))
             -> FontOverlayMap
             -> [(Text, HumanCmd, Maybe HumanCmd, Maybe FontOverlayMap)]
             -> [String]
             -> String
             -> m (Either MError ReqUI)
generateMenu :: forall (m :: * -> *).
MonadClientUI m =>
(KM -> HumanCmd -> m (Either MError ReqUI))
-> EnumMap DisplayFont Overlay
-> [(Text, HumanCmd, Maybe HumanCmd,
     Maybe (EnumMap DisplayFont Overlay))]
-> [String]
-> String
-> m (Either MError ReqUI)
generateMenu KM -> HumanCmd -> m (Either MError ReqUI)
cmdSemInCxtOfKM EnumMap DisplayFont Overlay
blurb [(Text, HumanCmd, Maybe HumanCmd,
  Maybe (EnumMap DisplayFont Overlay))]
kdsRaw [String]
gameInfo String
menuName = do
  COps{corule} <- (State -> COps) -> m COps
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  CCUI{ coinput=InputContent{brevMap}
      , coscreen=ScreenContent{rheight, rwebAddress} } <- getsSession sccui
  FontSetup{..} <- getFontSetup
  let matchKM MenuSlot
slot kd :: (Text, HumanCmd, Maybe HumanCmd,
 Maybe (EnumMap DisplayFont Overlay))
kd@(Text
_, HumanCmd
cmd, Maybe HumanCmd
_, Maybe (EnumMap DisplayFont Overlay)
_) = case HumanCmd -> Map HumanCmd [KM] -> Maybe [KM]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup HumanCmd
cmd Map HumanCmd [KM]
brevMap of
        Just (KM
km : [KM]
_) -> (KM -> KeyOrSlot
forall a b. a -> Either a b
Left KM
km, (Text, HumanCmd, Maybe HumanCmd,
 Maybe (EnumMap DisplayFont Overlay))
kd)
        Maybe [KM]
_ -> (MenuSlot -> KeyOrSlot
forall a b. b -> Either a b
Right MenuSlot
slot, (Text, HumanCmd, Maybe HumanCmd,
 Maybe (EnumMap DisplayFont Overlay))
kd)
      kds = (MenuSlot
 -> (Text, HumanCmd, Maybe HumanCmd,
     Maybe (EnumMap DisplayFont Overlay))
 -> (KeyOrSlot,
     (Text, HumanCmd, Maybe HumanCmd,
      Maybe (EnumMap DisplayFont Overlay))))
-> [MenuSlot]
-> [(Text, HumanCmd, Maybe HumanCmd,
     Maybe (EnumMap DisplayFont Overlay))]
-> [(KeyOrSlot,
     (Text, HumanCmd, Maybe HumanCmd,
      Maybe (EnumMap DisplayFont Overlay)))]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith MenuSlot
-> (Text, HumanCmd, Maybe HumanCmd,
    Maybe (EnumMap DisplayFont Overlay))
-> (KeyOrSlot,
    (Text, HumanCmd, Maybe HumanCmd,
     Maybe (EnumMap DisplayFont Overlay)))
matchKM [MenuSlot]
natSlots [(Text, HumanCmd, Maybe HumanCmd,
  Maybe (EnumMap DisplayFont Overlay))]
kdsRaw
      bindings =  -- key bindings to display
        let attrCursor :: Attr
attrCursor = Attr
Color.defAttr {Color.bg = Color.HighlightNoneCursor}
            highAttr :: AttrChar -> AttrChar
highAttr AttrChar
ac = AttrChar
ac {Color.acAttr = attrCursor}
            highW32 :: AttrCharW32 -> AttrCharW32
highW32 = AttrChar -> AttrCharW32
Color.attrCharToW32 (AttrChar -> AttrCharW32)
-> (AttrCharW32 -> AttrChar) -> AttrCharW32 -> AttrCharW32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AttrChar -> AttrChar
highAttr (AttrChar -> AttrChar)
-> (AttrCharW32 -> AttrChar) -> AttrCharW32 -> AttrChar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AttrCharW32 -> AttrChar
Color.attrCharFromW32
            markFirst :: Text -> AttrString
markFirst Text
d = AttrString -> AttrString
markFirstAS (AttrString -> AttrString) -> AttrString -> AttrString
forall a b. (a -> b) -> a -> b
$ Text -> AttrString
textToAS Text
d
            markFirstAS :: AttrString -> AttrString
markFirstAS [] = []
            markFirstAS (AttrCharW32
ac : AttrString
rest) = AttrCharW32 -> AttrCharW32
highW32 AttrCharW32
ac AttrCharW32 -> AttrString -> AttrString
forall a. a -> [a] -> [a]
: AttrString
rest
            fmt :: (a, (Text, b, c, d)) -> (a, AttrString)
fmt (a
ekm, (Text
d, b
_, c
_, d
_)) = (a
ekm, Text -> AttrString
markFirst Text
d)
        in ((KeyOrSlot,
  (Text, HumanCmd, Maybe HumanCmd,
   Maybe (EnumMap DisplayFont Overlay)))
 -> (KeyOrSlot, AttrString))
-> [(KeyOrSlot,
     (Text, HumanCmd, Maybe HumanCmd,
      Maybe (EnumMap DisplayFont Overlay)))]
-> [(KeyOrSlot, AttrString)]
forall a b. (a -> b) -> [a] -> [b]
map (KeyOrSlot,
 (Text, HumanCmd, Maybe HumanCmd,
  Maybe (EnumMap DisplayFont Overlay)))
-> (KeyOrSlot, AttrString)
forall {a} {b} {c} {d}. (a, (Text, b, c, d)) -> (a, AttrString)
fmt [(KeyOrSlot,
  (Text, HumanCmd, Maybe HumanCmd,
   Maybe (EnumMap DisplayFont Overlay)))]
kds
      generate :: Int -> (KeyOrSlot, AttrString) -> KYX
      generate Int
y (KeyOrSlot
ekm, AttrString
binding) =
        (KeyOrSlot
ekm, (Int -> Int -> PointUI
PointUI Int
0 Int
y, DisplayFont -> Int -> ButtonWidth
ButtonWidth DisplayFont
squareFont (AttrString -> Int
forall a. [a] -> Int
length AttrString
binding)))
      okxBindings = ( DisplayFont -> Overlay -> EnumMap DisplayFont Overlay
forall k a. Enum k => k -> a -> EnumMap k a
EM.singleton DisplayFont
squareFont
                      (Overlay -> EnumMap DisplayFont Overlay)
-> Overlay -> EnumMap DisplayFont Overlay
forall a b. (a -> b) -> a -> b
$ [AttrLine] -> Overlay
offsetOverlay ([AttrLine] -> Overlay) -> [AttrLine] -> Overlay
forall a b. (a -> b) -> a -> b
$ ((KeyOrSlot, AttrString) -> AttrLine)
-> [(KeyOrSlot, AttrString)] -> [AttrLine]
forall a b. (a -> b) -> [a] -> [b]
map (AttrString -> AttrLine
attrStringToAL (AttrString -> AttrLine)
-> ((KeyOrSlot, AttrString) -> AttrString)
-> (KeyOrSlot, AttrString)
-> AttrLine
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KeyOrSlot, AttrString) -> AttrString
forall a b. (a, b) -> b
snd) [(KeyOrSlot, AttrString)]
bindings
                    , (Int -> (KeyOrSlot, AttrString) -> KYX)
-> [Int] -> [(KeyOrSlot, AttrString)] -> [KYX]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> (KeyOrSlot, AttrString) -> KYX
generate [Int
0..] [(KeyOrSlot, AttrString)]
bindings )
      titleLine =
        RuleContent -> String
rtitle RuleContent
corule String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Version -> String
showVersion (RuleContent -> Version
rexeVersion RuleContent
corule) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" "
      titleAndInfo = (String -> AttrLine) -> [String] -> [AttrLine]
forall a b. (a -> b) -> [a] -> [b]
map String -> AttrLine
stringToAL
                         ([ String
""
                          , String
titleLine String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
rwebAddress String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"
                          , String
"" ]
                          [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
gameInfo)
      webButton = ( KM -> KeyOrSlot
forall a b. a -> Either a b
Left (KM -> KeyOrSlot) -> KM -> KeyOrSlot
forall a b. (a -> b) -> a -> b
$ Char -> KM
K.mkChar Char
'@'  -- to start the menu not here
                  , ( Int -> Int -> PointUI
PointUI (Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* String -> Int
forall a. [a] -> Int
length String
titleLine) Int
1
                    , DisplayFont -> Int -> ButtonWidth
ButtonWidth DisplayFont
squareFont (Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ String -> Int
forall a. [a] -> Int
length String
rwebAddress) ) )
      okxTitle = ( DisplayFont -> Overlay -> EnumMap DisplayFont Overlay
forall k a. Enum k => k -> a -> EnumMap k a
EM.singleton DisplayFont
squareFont (Overlay -> EnumMap DisplayFont Overlay)
-> Overlay -> EnumMap DisplayFont Overlay
forall a b. (a -> b) -> a -> b
$ [AttrLine] -> Overlay
offsetOverlay [AttrLine]
titleAndInfo
                 , [KYX
webButton] )
      okx = Int
-> Int
-> (EnumMap DisplayFont Overlay, [KYX])
-> (EnumMap DisplayFont Overlay, [KYX])
xytranslateOKX Int
2 Int
0
            ((EnumMap DisplayFont Overlay, [KYX])
 -> (EnumMap DisplayFont Overlay, [KYX]))
-> (EnumMap DisplayFont Overlay, [KYX])
-> (EnumMap DisplayFont Overlay, [KYX])
forall a b. (a -> b) -> a -> b
$ Int
-> Int
-> (EnumMap DisplayFont Overlay, [KYX])
-> (EnumMap DisplayFont Overlay, [KYX])
-> (EnumMap DisplayFont Overlay, [KYX])
sideBySideOKX Int
2 ([AttrLine] -> Int
forall a. [a] -> Int
length [AttrLine]
titleAndInfo) (EnumMap DisplayFont Overlay, [KYX])
okxTitle (EnumMap DisplayFont Overlay, [KYX])
okxBindings
      prepareBlurb EnumMap DisplayFont Overlay
ovs =
        let introLen :: Int
introLen = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ EnumMap DisplayFont Overlay -> Int
maxYofFontOverlayMap EnumMap DisplayFont Overlay
ovs
            start0 :: Int
start0 = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
rheight Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
introLen
                            Int -> Int -> Int
forall a. Num a => a -> a -> a
- if DisplayFont -> Bool
isSquareFont DisplayFont
propFont then Int
1 else Int
2)
        in (Overlay -> Overlay)
-> EnumMap DisplayFont Overlay -> EnumMap DisplayFont Overlay
forall a b k. (a -> b) -> EnumMap k a -> EnumMap k b
EM.map (Int -> Int -> Overlay -> Overlay
xytranslateOverlay (-Int
2) (Int
start0 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2)) EnumMap DisplayFont Overlay
ovs
          -- subtracting 2 from X and Y to negate the indentation in
          -- @displayChoiceScreenWithRightPane@
      returnDefaultOKS = (EnumMap DisplayFont Overlay, [KYX])
-> m (EnumMap DisplayFont Overlay, [KYX])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (EnumMap DisplayFont Overlay -> EnumMap DisplayFont Overlay
prepareBlurb EnumMap DisplayFont Overlay
blurb, [])
      displayInRightPane KeyOrSlot
ekm = case KeyOrSlot
ekm KeyOrSlot
-> [(KeyOrSlot,
     (Text, HumanCmd, Maybe HumanCmd,
      Maybe (EnumMap DisplayFont Overlay)))]
-> Maybe
     (Text, HumanCmd, Maybe HumanCmd,
      Maybe (EnumMap DisplayFont Overlay))
forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` [(KeyOrSlot,
  (Text, HumanCmd, Maybe HumanCmd,
   Maybe (EnumMap DisplayFont Overlay)))]
kds of
        Just (Text
_, HumanCmd
_, Maybe HumanCmd
_, Maybe (EnumMap DisplayFont Overlay)
mblurbRight) -> case Maybe (EnumMap DisplayFont Overlay)
mblurbRight of
          Maybe (EnumMap DisplayFont Overlay)
Nothing -> m (EnumMap DisplayFont Overlay, [KYX])
returnDefaultOKS
          Just EnumMap DisplayFont Overlay
blurbRight -> (EnumMap DisplayFont Overlay, [KYX])
-> m (EnumMap DisplayFont Overlay, [KYX])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (EnumMap DisplayFont Overlay -> EnumMap DisplayFont Overlay
prepareBlurb EnumMap DisplayFont Overlay
blurbRight, [])
        Maybe
  (Text, HumanCmd, Maybe HumanCmd,
   Maybe (EnumMap DisplayFont Overlay))
Nothing | KeyOrSlot
ekm KeyOrSlot -> KeyOrSlot -> Bool
forall a. Eq a => a -> a -> Bool
== KM -> KeyOrSlot
forall a b. a -> Either a b
Left (Char -> KM
K.mkChar Char
'@') -> m (EnumMap DisplayFont Overlay, [KYX])
returnDefaultOKS
        Maybe
  (Text, HumanCmd, Maybe HumanCmd,
   Maybe (EnumMap DisplayFont Overlay))
Nothing -> String -> m (EnumMap DisplayFont Overlay, [KYX])
forall a. (?callStack::CallStack) => String -> a
error (String -> m (EnumMap DisplayFont Overlay, [KYX]))
-> String -> m (EnumMap DisplayFont Overlay, [KYX])
forall a b. (a -> b) -> a -> b
$ String
"generateMenu: unexpected key:"
                           String -> KeyOrSlot -> String
forall v. Show v => String -> v -> String
`showFailure` KeyOrSlot
ekm
      keys = [KM
K.leftKM, KM
K.rightKM, KM
K.escKM, Char -> KM
K.mkChar Char
'@']
      loop = do
        kmkm <- (KeyOrSlot -> m (EnumMap DisplayFont Overlay, [KYX]))
-> Bool
-> String
-> ColorMode
-> Bool
-> Slideshow
-> [KM]
-> m (Either (KM, KeyOrSlot) MenuSlot)
forall (m :: * -> *).
MonadClientUI m =>
(KeyOrSlot -> m (EnumMap DisplayFont Overlay, [KYX]))
-> Bool
-> String
-> ColorMode
-> Bool
-> Slideshow
-> [KM]
-> m (Either (KM, KeyOrSlot) MenuSlot)
displayChoiceScreenWithRightPaneKMKM KeyOrSlot -> m (EnumMap DisplayFont Overlay, [KYX])
displayInRightPane Bool
True
                                                     String
menuName ColorMode
ColorFull Bool
True
                                                     ((EnumMap DisplayFont Overlay, [KYX]) -> Slideshow
menuToSlideshow (EnumMap DisplayFont Overlay, [KYX])
okx) [KM]
keys
        case kmkm of
          Left (km :: KM
km@(K.KM {key :: KM -> Key
key=Key
K.Left}), KeyOrSlot
ekm) -> case KeyOrSlot
ekm KeyOrSlot
-> [(KeyOrSlot,
     (Text, HumanCmd, Maybe HumanCmd,
      Maybe (EnumMap DisplayFont Overlay)))]
-> Maybe
     (Text, HumanCmd, Maybe HumanCmd,
      Maybe (EnumMap DisplayFont Overlay))
forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` [(KeyOrSlot,
  (Text, HumanCmd, Maybe HumanCmd,
   Maybe (EnumMap DisplayFont Overlay)))]
kds of
            Just (Text
_, HumanCmd
_, Maybe HumanCmd
Nothing, Maybe (EnumMap DisplayFont Overlay)
_) -> m (Either MError ReqUI)
loop
            Just (Text
_, HumanCmd
_, Just HumanCmd
cmdReverse, Maybe (EnumMap DisplayFont Overlay)
_) -> KM -> HumanCmd -> m (Either MError ReqUI)
cmdSemInCxtOfKM KM
km HumanCmd
cmdReverse
            Maybe
  (Text, HumanCmd, Maybe HumanCmd,
   Maybe (EnumMap DisplayFont Overlay))
Nothing -> FailOrCmd ReqUI -> Either MError ReqUI
forall a. FailOrCmd a -> Either MError a
weaveJust (FailOrCmd ReqUI -> Either MError ReqUI)
-> m (FailOrCmd ReqUI) -> m (Either MError ReqUI)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> m (FailOrCmd ReqUI)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith Text
"never mind"
          Left (km :: KM
km@(K.KM {key :: KM -> Key
key=Key
K.Right}), KeyOrSlot
ekm) -> case KeyOrSlot
ekm KeyOrSlot
-> [(KeyOrSlot,
     (Text, HumanCmd, Maybe HumanCmd,
      Maybe (EnumMap DisplayFont Overlay)))]
-> Maybe
     (Text, HumanCmd, Maybe HumanCmd,
      Maybe (EnumMap DisplayFont Overlay))
forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` [(KeyOrSlot,
  (Text, HumanCmd, Maybe HumanCmd,
   Maybe (EnumMap DisplayFont Overlay)))]
kds of
            Just (Text
_, HumanCmd
cmd, Maybe HumanCmd
_, Maybe (EnumMap DisplayFont Overlay)
_) -> KM -> HumanCmd -> m (Either MError ReqUI)
cmdSemInCxtOfKM KM
km HumanCmd
cmd
            Maybe
  (Text, HumanCmd, Maybe HumanCmd,
   Maybe (EnumMap DisplayFont Overlay))
Nothing -> FailOrCmd ReqUI -> Either MError ReqUI
forall a. FailOrCmd a -> Either MError a
weaveJust (FailOrCmd ReqUI -> Either MError ReqUI)
-> m (FailOrCmd ReqUI) -> m (Either MError ReqUI)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> m (FailOrCmd ReqUI)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith Text
"never mind"
          Left (K.KM {key :: KM -> Key
key=K.Char Char
'@'}, KeyOrSlot
_)-> do
            success <- String -> m Bool
forall (m :: * -> *). MonadClientUI m => String -> m Bool
tryOpenBrowser String
rwebAddress
            if success
            then generateMenu cmdSemInCxtOfKM blurb kdsRaw gameInfo menuName
            else weaveJust <$> failWith "failed to open web browser"
          Left (KM
km, KeyOrSlot
_) -> case KM -> KeyOrSlot
forall a b. a -> Either a b
Left KM
km KeyOrSlot
-> [(KeyOrSlot,
     (Text, HumanCmd, Maybe HumanCmd,
      Maybe (EnumMap DisplayFont Overlay)))]
-> Maybe
     (Text, HumanCmd, Maybe HumanCmd,
      Maybe (EnumMap DisplayFont Overlay))
forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` [(KeyOrSlot,
  (Text, HumanCmd, Maybe HumanCmd,
   Maybe (EnumMap DisplayFont Overlay)))]
kds of
            Just (Text
_, HumanCmd
cmd, Maybe HumanCmd
_, Maybe (EnumMap DisplayFont Overlay)
_) -> KM -> HumanCmd -> m (Either MError ReqUI)
cmdSemInCxtOfKM KM
km HumanCmd
cmd
            Maybe
  (Text, HumanCmd, Maybe HumanCmd,
   Maybe (EnumMap DisplayFont Overlay))
Nothing -> FailOrCmd ReqUI -> Either MError ReqUI
forall a. FailOrCmd a -> Either MError a
weaveJust (FailOrCmd ReqUI -> Either MError ReqUI)
-> m (FailOrCmd ReqUI) -> m (Either MError ReqUI)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> m (FailOrCmd ReqUI)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith Text
"never mind"
          Right MenuSlot
slot -> case MenuSlot -> KeyOrSlot
forall a b. b -> Either a b
Right MenuSlot
slot KeyOrSlot
-> [(KeyOrSlot,
     (Text, HumanCmd, Maybe HumanCmd,
      Maybe (EnumMap DisplayFont Overlay)))]
-> Maybe
     (Text, HumanCmd, Maybe HumanCmd,
      Maybe (EnumMap DisplayFont Overlay))
forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` [(KeyOrSlot,
  (Text, HumanCmd, Maybe HumanCmd,
   Maybe (EnumMap DisplayFont Overlay)))]
kds of
            Just (Text
_, HumanCmd
cmd, Maybe HumanCmd
_, Maybe (EnumMap DisplayFont Overlay)
_) -> KM -> HumanCmd -> m (Either MError ReqUI)
cmdSemInCxtOfKM KM
K.escKM HumanCmd
cmd
            Maybe
  (Text, HumanCmd, Maybe HumanCmd,
   Maybe (EnumMap DisplayFont Overlay))
Nothing -> FailOrCmd ReqUI -> Either MError ReqUI
forall a. FailOrCmd a -> Either MError a
weaveJust (FailOrCmd ReqUI -> Either MError ReqUI)
-> m (FailOrCmd ReqUI) -> m (Either MError ReqUI)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> m (FailOrCmd ReqUI)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith Text
"never mind"
  loop

-- | Display the main menu.
mainMenuHuman :: MonadClientUI m
              => (K.KM -> HumanCmd -> m (Either MError ReqUI))
              -> m (Either MError ReqUI)
mainMenuHuman :: forall (m :: * -> *).
MonadClientUI m =>
(KM -> HumanCmd -> m (Either MError ReqUI))
-> m (Either MError ReqUI)
mainMenuHuman KM -> HumanCmd -> m (Either MError ReqUI)
cmdSemInCxtOfKM = do
  CCUI{coscreen=ScreenContent{rintroScreen}} <- (SessionUI -> CCUI) -> m CCUI
forall a. (SessionUI -> a) -> m a
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> CCUI
sccui
  FontSetup{propFont} <- getFontSetup
  gameMode <- getGameMode
  curTutorial <- getsSession scurTutorial
  overrideTut <- getsSession soverrideTut
  curChal <- getsClient scurChal
  let offOn Bool
b = if Bool
b then a
"on" else a
"off"
      -- Key-description-command tuples.
      kds = [ (Text
"+ setup and start new game>", HumanCmd
ChallengeMenu, Maybe a
forall a. Maybe a
Nothing, Maybe a
forall a. Maybe a
Nothing)
            , (Text
"@ save and exit to desktop", HumanCmd
GameExit, Maybe a
forall a. Maybe a
Nothing, Maybe a
forall a. Maybe a
Nothing)
            , (Text
"+ tweak convenience settings>", HumanCmd
SettingsMenu, Maybe a
forall a. Maybe a
Nothing, Maybe a
forall a. Maybe a
Nothing)
            , (Text
"@ toggle autoplay", HumanCmd
AutomateToggle, Maybe a
forall a. Maybe a
Nothing, Maybe a
forall a. Maybe a
Nothing)
            , (Text
"@ see command help", HumanCmd
Help, Maybe a
forall a. Maybe a
Nothing, Maybe a
forall a. Maybe a
Nothing)
            , (Text
"@ switch to dashboard", HumanCmd
Dashboard, Maybe a
forall a. Maybe a
Nothing, Maybe a
forall a. Maybe a
Nothing)
            , (Text
"^ back to playing", HumanCmd
AutomateBack, Maybe a
forall a. Maybe a
Nothing, Maybe a
forall a. Maybe a
Nothing) ]
      gameName = ModeKind -> Text
MK.mname ModeKind
gameMode
      displayTutorialHints = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
curTutorial Maybe Bool
overrideTut
      gameInfo = (Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
T.unpack
                   [ Text
"Now playing:" Text -> Text -> Text
<+> Text
gameName
                   , Text
""
                   , Text
"      with difficulty:" Text -> Text -> Text
<+> Int -> Text
forall a. Show a => a -> Text
tshow (Challenge -> Int
cdiff Challenge
curChal)
                   , Text
"            cold fish:" Text -> Text -> Text
<+> Bool -> Text
forall {a}. IsString a => Bool -> a
offOn (Challenge -> Bool
cfish Challenge
curChal)
                   , Text
"          ready goods:" Text -> Text -> Text
<+> Bool -> Text
forall {a}. IsString a => Bool -> a
offOn (Challenge -> Bool
cgoods Challenge
curChal)
                   , Text
"            lone wolf:" Text -> Text -> Text
<+> Bool -> Text
forall {a}. IsString a => Bool -> a
offOn (Challenge -> Bool
cwolf Challenge
curChal)
                   , Text
"        finder keeper:" Text -> Text -> Text
<+> Bool -> Text
forall {a}. IsString a => Bool -> a
offOn (Challenge -> Bool
ckeeper Challenge
curChal)
                   , Text
"       tutorial hints:" Text -> Text -> Text
<+> Bool -> Text
forall {a}. IsString a => Bool -> a
offOn Bool
displayTutorialHints
                   , Text
"" ]
      glueLines ([a]
l1 : [a]
l2 : [[a]]
rest) =
        if | [a] -> Bool
forall a. [a] -> Bool
null [a]
l1 -> [a]
l1 [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [[a]] -> [[a]]
glueLines ([a]
l2 [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [[a]]
rest)
           | [a] -> Bool
forall a. [a] -> Bool
null [a]
l2 -> [a]
l1 [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [a]
l2 [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [[a]] -> [[a]]
glueLines [[a]]
rest
           | Bool
otherwise -> ([a]
l1 [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
l2) [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [[a]] -> [[a]]
glueLines [[a]]
rest
      glueLines [[a]]
ll = [[a]]
ll
      backstory | DisplayFont -> Bool
isSquareFont DisplayFont
propFont = ([String], [[String]]) -> [String]
forall a b. (a, b) -> a
fst ([String], [[String]])
rintroScreen
                | Bool
otherwise = [String] -> [String]
forall {a}. [[a]] -> [[a]]
glueLines ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ ([String], [[String]]) -> [String]
forall a b. (a, b) -> a
fst ([String], [[String]])
rintroScreen
      backstoryAL = (String -> AttrLine) -> [String] -> [AttrLine]
forall a b. (a -> b) -> [a] -> [b]
map (String -> AttrLine
stringToAL (String -> AttrLine) -> (String -> String) -> String -> AttrLine
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ')) [String]
backstory
      blurb = [(DisplayFont, [AttrLine])] -> EnumMap DisplayFont Overlay
attrLinesToFontMap [(DisplayFont
propFont, [AttrLine]
backstoryAL)]
  generateMenu cmdSemInCxtOfKM blurb kds gameInfo "main"

-- * MainMenuAutoOn

-- | Display the main menu and set @swasAutomated@.
mainMenuAutoOnHuman :: MonadClientUI m
                    => (K.KM -> HumanCmd -> m (Either MError ReqUI))
                    -> m (Either MError ReqUI)
mainMenuAutoOnHuman :: forall (m :: * -> *).
MonadClientUI m =>
(KM -> HumanCmd -> m (Either MError ReqUI))
-> m (Either MError ReqUI)
mainMenuAutoOnHuman KM -> HumanCmd -> m (Either MError ReqUI)
cmdSemInCxtOfKM = do
  (SessionUI -> SessionUI) -> m ()
forall (m :: * -> *).
MonadClientUI m =>
(SessionUI -> SessionUI) -> m ()
modifySession ((SessionUI -> SessionUI) -> m ())
-> (SessionUI -> SessionUI) -> m ()
forall a b. (a -> b) -> a -> b
$ \SessionUI
sess -> SessionUI
sess {swasAutomated = True}
  (KM -> HumanCmd -> m (Either MError ReqUI))
-> m (Either MError ReqUI)
forall (m :: * -> *).
MonadClientUI m =>
(KM -> HumanCmd -> m (Either MError ReqUI))
-> m (Either MError ReqUI)
mainMenuHuman KM -> HumanCmd -> m (Either MError ReqUI)
cmdSemInCxtOfKM

-- * MainMenuAutoOff

-- | Display the main menu and unset @swasAutomated@.
mainMenuAutoOffHuman :: MonadClientUI m
                     => (K.KM -> HumanCmd -> m (Either MError ReqUI))
                     -> m (Either MError ReqUI)
mainMenuAutoOffHuman :: forall (m :: * -> *).
MonadClientUI m =>
(KM -> HumanCmd -> m (Either MError ReqUI))
-> m (Either MError ReqUI)
mainMenuAutoOffHuman KM -> HumanCmd -> m (Either MError ReqUI)
cmdSemInCxtOfKM = do
  (SessionUI -> SessionUI) -> m ()
forall (m :: * -> *).
MonadClientUI m =>
(SessionUI -> SessionUI) -> m ()
modifySession ((SessionUI -> SessionUI) -> m ())
-> (SessionUI -> SessionUI) -> m ()
forall a b. (a -> b) -> a -> b
$ \SessionUI
sess -> SessionUI
sess {swasAutomated = False}
  (KM -> HumanCmd -> m (Either MError ReqUI))
-> m (Either MError ReqUI)
forall (m :: * -> *).
MonadClientUI m =>
(KM -> HumanCmd -> m (Either MError ReqUI))
-> m (Either MError ReqUI)
mainMenuHuman KM -> HumanCmd -> m (Either MError ReqUI)
cmdSemInCxtOfKM

-- * SettingsMenu

-- | Display the settings menu.
settingsMenuHuman :: MonadClientUI m
                  => (K.KM -> HumanCmd -> m (Either MError ReqUI))
                  -> m (Either MError ReqUI)
settingsMenuHuman :: forall (m :: * -> *).
MonadClientUI m =>
(KM -> HumanCmd -> m (Either MError ReqUI))
-> m (Either MError ReqUI)
settingsMenuHuman KM -> HumanCmd -> m (Either MError ReqUI)
cmdSemInCxtOfKM = do
  CCUI{coscreen=ScreenContent{rwidth}} <- (SessionUI -> CCUI) -> m CCUI
forall a. (SessionUI -> a) -> m a
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> CCUI
sccui
  UIOptions{uMsgWrapColumn} <- getsSession sUIOptions
  FontSetup{..} <- getFontSetup
  markSuspect <- getsClient smarkSuspect
  markVision <- getsSession smarkVision
  markSmell <- getsSession smarkSmell
  noAnim <- getsClient $ fromMaybe False . snoAnim . soptions
  side <- getsClient sside
  factDoctrine <- getsState $ gdoctrine . (EM.! side) . sfactionD
  overrideTut <- getsSession soverrideTut
  let offOn Bool
b = if Bool
b then a
"on" else a
"off"
      offOnAll v
n = case v
n of
        v
0 -> a
"none"
        v
1 -> a
"untried"
        v
2 -> a
"all"
        v
_ -> String -> a
forall a. (?callStack::CallStack) => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"" String -> v -> String
forall v. Show v => String -> v -> String
`showFailure` v
n
      neverEver v
n = case v
n of
        v
0 -> a
"never"
        v
1 -> a
"aiming"
        v
2 -> a
"always"
        v
_ -> String -> a
forall a. (?callStack::CallStack) => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"" String -> v -> String
forall v. Show v => String -> v -> String
`showFailure` v
n
      offOnUnset Maybe Bool
mb = case Maybe Bool
mb of
        Maybe Bool
Nothing -> a
"pass"
        Just Bool
b -> if Bool
b then a
"force on" else a
"force off"
      tsuspect = Text
"@ mark suspect terrain:" Text -> Text -> Text
<+> Int -> Text
forall {v} {a}. (Eq v, Num v, IsString a, Show v) => v -> a
offOnAll Int
markSuspect
      tvisible = Text
"@ show visible zone:" Text -> Text -> Text
<+> Int -> Text
forall {v} {a}. (Eq v, Num v, IsString a, Show v) => v -> a
neverEver Int
markVision
      tsmell = Text
"@ display smell clues:" Text -> Text -> Text
<+> Bool -> Text
forall {a}. IsString a => Bool -> a
offOn Bool
markSmell
      tanim = Text
"@ play animations:" Text -> Text -> Text
<+> Bool -> Text
forall {a}. IsString a => Bool -> a
offOn (Bool -> Bool
not Bool
noAnim)
      tdoctrine = Text
"@ squad doctrine:" Text -> Text -> Text
<+> Doctrine -> Text
Ability.nameDoctrine Doctrine
factDoctrine
      toverride = Text
"@ override tutorial hints:" Text -> Text -> Text
<+> Maybe Bool -> Text
forall {a}. IsString a => Maybe Bool -> a
offOnUnset Maybe Bool
overrideTut
      width = if DisplayFont -> Bool
isSquareFont DisplayFont
propFont
              then Int
rwidth Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
              else Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
uMsgWrapColumn (Int
rwidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2)
      textToBlurb Text
t = EnumMap DisplayFont Overlay -> Maybe (EnumMap DisplayFont Overlay)
forall a. a -> Maybe a
Just (EnumMap DisplayFont Overlay
 -> Maybe (EnumMap DisplayFont Overlay))
-> EnumMap DisplayFont Overlay
-> Maybe (EnumMap DisplayFont Overlay)
forall a b. (a -> b) -> a -> b
$ [(DisplayFont, [AttrLine])] -> EnumMap DisplayFont Overlay
attrLinesToFontMap
        [ ( DisplayFont
propFont
          , Int -> Int -> AttrString -> [AttrLine]
splitAttrString Int
width Int
width
            (AttrString -> [AttrLine]) -> AttrString -> [AttrLine]
forall a b. (a -> b) -> a -> b
$ Text -> AttrString
textToAS Text
t ) ]
      -- Key-description-command-text tuples.
      kds = [ ( Text
tsuspect, Int -> HumanCmd
MarkSuspect Int
1, HumanCmd -> Maybe HumanCmd
forall a. a -> Maybe a
Just (Int -> HumanCmd
MarkSuspect (-Int
1))
              , Text -> Maybe (EnumMap DisplayFont Overlay)
textToBlurb Text
"* mark suspect terrain\nThis setting affects the ongoing and the next games. It determines which suspect terrain is marked in special color on the map: none, untried (not searched nor revealed), all. It correspondingly determines which, if any, suspect tiles are considered for mouse go-to, auto-explore and for the command that marks the nearest unexplored position." )
            , ( Text
tvisible, Int -> HumanCmd
MarkVision Int
1, HumanCmd -> Maybe HumanCmd
forall a. a -> Maybe a
Just (Int -> HumanCmd
MarkVision (-Int
1))
              , Text -> Maybe (EnumMap DisplayFont Overlay)
textToBlurb Text
"* show visible zone\nThis setting affects the ongoing and the next games. It determines the conditions under which the area visible to the party is marked on the map via a gray background: never, when aiming, always." )
            , ( Text
tsmell, HumanCmd
MarkSmell, HumanCmd -> Maybe HumanCmd
forall a. a -> Maybe a
Just HumanCmd
MarkSmell
              , Text -> Maybe (EnumMap DisplayFont Overlay)
textToBlurb Text
"* display smell clues\nThis setting affects the ongoing and the next games. It determines whether the map displays any smell traces (regardless of who left them) detected by a party member that can track via smell (as determined by the smell radius skill; not common among humans)." )
            , ( Text
tanim, HumanCmd
MarkAnim, HumanCmd -> Maybe HumanCmd
forall a. a -> Maybe a
Just HumanCmd
MarkAnim
              , Text -> Maybe (EnumMap DisplayFont Overlay)
textToBlurb Text
"* play animations\nThis setting affects the ongoing and the next games. It determines whether important events, such combat, are highlighted by animations. This overrides the corresponding config file setting." )
            , ( Text
tdoctrine, HumanCmd
Doctrine, Maybe HumanCmd
forall a. Maybe a
Nothing
              , Text -> Maybe (EnumMap DisplayFont Overlay)
textToBlurb Text
"* squad doctrine\nThis setting affects the ongoing game, but does not persist to the next games. It determines the behaviour of henchmen (non-pointman characters) in the party and, in particular, if they are permitted to move autonomously or fire opportunistically (assuming they are able to, usually due to rare equipment). This setting has a poor UI that will be improved in the future." )
            , ( Text
toverride, Int -> HumanCmd
OverrideTut Int
1, HumanCmd -> Maybe HumanCmd
forall a. a -> Maybe a
Just (Int -> HumanCmd
OverrideTut (-Int
1))
              , Text -> Maybe (EnumMap DisplayFont Overlay)
textToBlurb Text
"* override tutorial hints\nThis setting affects the ongoing and the next games. It determines whether tutorial hints are, respectively, not overridden with respect to the default game mode setting, forced to be off, forced to be on. Tutorial hints are rendered as pink messages and can afterwards be re-read from message history." )
            , ( Text
"^ back to main menu", HumanCmd
MainMenu, Maybe HumanCmd
forall a. Maybe a
Nothing, EnumMap DisplayFont Overlay -> Maybe (EnumMap DisplayFont Overlay)
forall a. a -> Maybe a
Just EnumMap DisplayFont Overlay
forall k a. EnumMap k a
EM.empty ) ]
      gameInfo = (Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
T.unpack
                   [ Text
"Tweak convenience settings:"
                   , Text
"" ]
  generateMenu cmdSemInCxtOfKM EM.empty kds gameInfo "settings"

-- * ChallengeMenu

-- | Display the challenge menu.
challengeMenuHuman :: MonadClientUI m
                   => (K.KM -> HumanCmd -> m (Either MError ReqUI))
                   -> m (Either MError ReqUI)
challengeMenuHuman :: forall (m :: * -> *).
MonadClientUI m =>
(KM -> HumanCmd -> m (Either MError ReqUI))
-> m (Either MError ReqUI)
challengeMenuHuman KM -> HumanCmd -> m (Either MError ReqUI)
cmdSemInCxtOfKM = do
  cops <- (State -> COps) -> m COps
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  CCUI{coscreen=ScreenContent{rwidth}} <- getsSession sccui
  UIOptions{uMsgWrapColumn} <- getsSession sUIOptions
  FontSetup{..} <- getFontSetup
  svictories <- getsSession svictories
  snxtScenario <- getsSession snxtScenario
  nxtChal <- getsClient snxtChal
  let (gameModeId, gameMode) = nxtGameMode cops snxtScenario
      victories = case ContentId ModeKind
-> EnumMap (ContentId ModeKind) (Map Challenge Int)
-> Maybe (Map Challenge Int)
forall k a. Enum k => k -> EnumMap k a -> Maybe a
EM.lookup ContentId ModeKind
gameModeId EnumMap (ContentId ModeKind) (Map Challenge Int)
svictories of
        Maybe (Map Challenge Int)
Nothing -> Int
0
        Just Map Challenge Int
cm -> Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (Challenge -> Map Challenge Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Challenge
nxtChal Map Challenge Int
cm)
      star Text
t = if Int
victories Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then Text
"*" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t else Text
t
      tnextScenario = Text
"@ adventure:" Text -> Text -> Text
<+> Text -> Text
star (ModeKind -> Text
MK.mname ModeKind
gameMode)
      offOn Bool
b = if Bool
b then a
"on" else a
"off"
      tnextDiff = Text
"@ difficulty level:" Text -> Text -> Text
<+> Int -> Text
forall a. Show a => a -> Text
tshow (Challenge -> Int
cdiff Challenge
nxtChal)
      tnextFish = Text
"@ cold fish (rather hard):" Text -> Text -> Text
<+> Bool -> Text
forall {a}. IsString a => Bool -> a
offOn (Challenge -> Bool
cfish Challenge
nxtChal)
      tnextGoods = Text
"@ ready goods (hard):" Text -> Text -> Text
<+> Bool -> Text
forall {a}. IsString a => Bool -> a
offOn (Challenge -> Bool
cgoods Challenge
nxtChal)
      tnextWolf = Text
"@ lone wolf (very hard):" Text -> Text -> Text
<+> Bool -> Text
forall {a}. IsString a => Bool -> a
offOn (Challenge -> Bool
cwolf Challenge
nxtChal)
      tnextKeeper = Text
"@ finder keeper (hard):" Text -> Text -> Text
<+> Bool -> Text
forall {a}. IsString a => Bool -> a
offOn (Challenge -> Bool
ckeeper Challenge
nxtChal)
      width = if DisplayFont -> Bool
isSquareFont DisplayFont
propFont
              then Int
rwidth Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
              else Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
uMsgWrapColumn (Int
rwidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2)
      widthFull = if DisplayFont -> Bool
isSquareFont DisplayFont
propFont
                  then Int
rwidth Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
                  else Int
rwidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2
      duplicateEOL Char
'\n' = Text
"\n\n"
      duplicateEOL Char
c = Char -> Text
T.singleton Char
c
      blurb = EnumMap DisplayFont Overlay -> Maybe (EnumMap DisplayFont Overlay)
forall a. a -> Maybe a
Just (EnumMap DisplayFont Overlay
 -> Maybe (EnumMap DisplayFont Overlay))
-> EnumMap DisplayFont Overlay
-> Maybe (EnumMap DisplayFont Overlay)
forall a b. (a -> b) -> a -> b
$ [(DisplayFont, [AttrLine])] -> EnumMap DisplayFont Overlay
attrLinesToFontMap
        [ ( DisplayFont
propFont
          , Int -> Int -> AttrString -> [AttrLine]
splitAttrString Int
width Int
width
            (AttrString -> [AttrLine]) -> AttrString -> [AttrLine]
forall a b. (a -> b) -> a -> b
$ Color -> Text -> AttrString
textFgToAS Color
Color.BrBlack
            (Text -> AttrString) -> Text -> AttrString
forall a b. (a -> b) -> a -> b
$ (Char -> Text) -> Text -> Text
T.concatMap Char -> Text
duplicateEOL (ModeKind -> Text
MK.mdesc ModeKind
gameMode)
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n\n" )
        , ( DisplayFont
propFont
          , Int -> Int -> AttrString -> [AttrLine]
splitAttrString Int
widthFull Int
widthFull
            (AttrString -> [AttrLine]) -> AttrString -> [AttrLine]
forall a b. (a -> b) -> a -> b
$ Text -> AttrString
textToAS
            (Text -> AttrString) -> Text -> AttrString
forall a b. (a -> b) -> a -> b
$ ModeKind -> Text
MK.mrules ModeKind
gameMode
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n\n" )
        , ( DisplayFont
propFont
          , Int -> Int -> AttrString -> [AttrLine]
splitAttrString Int
width Int
width
            (AttrString -> [AttrLine]) -> AttrString -> [AttrLine]
forall a b. (a -> b) -> a -> b
$ Text -> AttrString
textToAS
            (Text -> AttrString) -> Text -> AttrString
forall a b. (a -> b) -> a -> b
$ (Char -> Text) -> Text -> Text
T.concatMap Char -> Text
duplicateEOL (ModeKind -> Text
MK.mreason ModeKind
gameMode) )
        ]
      textToBlurb Text
t = EnumMap DisplayFont Overlay -> Maybe (EnumMap DisplayFont Overlay)
forall a. a -> Maybe a
Just (EnumMap DisplayFont Overlay
 -> Maybe (EnumMap DisplayFont Overlay))
-> EnumMap DisplayFont Overlay
-> Maybe (EnumMap DisplayFont Overlay)
forall a b. (a -> b) -> a -> b
$ [(DisplayFont, [AttrLine])] -> EnumMap DisplayFont Overlay
attrLinesToFontMap
        [ ( DisplayFont
propFont
          , Int -> Int -> AttrString -> [AttrLine]
splitAttrString Int
width Int
width  -- not widthFull!
            (AttrString -> [AttrLine]) -> AttrString -> [AttrLine]
forall a b. (a -> b) -> a -> b
$ Text -> AttrString
textToAS Text
t ) ]
      -- Key-description-command-text tuples.
      kds = [ ( Text
tnextScenario, Int -> HumanCmd
GameScenarioIncr Int
1, HumanCmd -> Maybe HumanCmd
forall a. a -> Maybe a
Just (Int -> HumanCmd
GameScenarioIncr (-Int
1))
              , Maybe (EnumMap DisplayFont Overlay)
blurb )
            , ( Text
tnextDiff, Int -> HumanCmd
GameDifficultyIncr Int
1, HumanCmd -> Maybe HumanCmd
forall a. a -> Maybe a
Just (Int -> HumanCmd
GameDifficultyIncr (-Int
1))
              , Text -> Maybe (EnumMap DisplayFont Overlay)
textToBlurb Text
"* difficulty level\nThis determines the difficulty of survival in the next game that's about to be started. Lower numbers result in easier game. In particular, difficulty below 5 multiplies hitpoints of player characters and difficulty over 5 multiplies hitpoints of their enemies. Game score scales with difficulty.")
            , ( Text
tnextFish, HumanCmd
GameFishToggle, HumanCmd -> Maybe HumanCmd
forall a. a -> Maybe a
Just HumanCmd
GameFishToggle
              , Text -> Maybe (EnumMap DisplayFont Overlay)
textToBlurb Text
"* cold fish\nThis challenge mode setting will affect the next game that's about to be started. When on, it makes it impossible for player characters to be healed by actors from other factions (this is a significant restriction in the long crawl adventure).")
            , ( Text
tnextGoods, HumanCmd
GameGoodsToggle, HumanCmd -> Maybe HumanCmd
forall a. a -> Maybe a
Just HumanCmd
GameGoodsToggle
              , Text -> Maybe (EnumMap DisplayFont Overlay)
textToBlurb Text
"* ready goods\nThis challenge mode setting will affect the next game that's about to be started. When on, it disables crafting for the player, making the selection of equipment, especially melee weapons, very limited, unless the player has the luck to find the rare powerful ready weapons (this applies only if the chosen adventure supports crafting at all).")
            , ( Text
tnextWolf, HumanCmd
GameWolfToggle, HumanCmd -> Maybe HumanCmd
forall a. a -> Maybe a
Just HumanCmd
GameWolfToggle
              , Text -> Maybe (EnumMap DisplayFont Overlay)
textToBlurb Text
"* lone wolf\nThis challenge mode setting will affect the next game that's about to be started. When on, it reduces player's starting actors to exactly one, though later on new heroes may join the party. This makes the game very hard in the long run.")
            , ( Text
tnextKeeper, HumanCmd
GameKeeperToggle, HumanCmd -> Maybe HumanCmd
forall a. a -> Maybe a
Just HumanCmd
GameKeeperToggle
              , Text -> Maybe (EnumMap DisplayFont Overlay)
textToBlurb Text
"* finder keeper\nThis challenge mode setting will affect the next game that's about to be started. When on, it completely disables flinging projectiles by the player, which affects not only ranged damage dealing, but also throwing of consumables that buff teammates engaged in melee combat, weaken and distract enemies, light dark corners, etc.")
            , ( Text
"@ start new game", HumanCmd
GameRestart, Maybe HumanCmd
forall a. Maybe a
Nothing, Maybe (EnumMap DisplayFont Overlay)
blurb )
            , ( Text
"^ back to main menu", HumanCmd
MainMenu, Maybe HumanCmd
forall a. Maybe a
Nothing, Maybe (EnumMap DisplayFont Overlay)
forall a. Maybe a
Nothing ) ]
      gameInfo = (Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
T.unpack [ Text
"Setup and start new game:"
                              , Text
"" ]
  generateMenu cmdSemInCxtOfKM EM.empty kds gameInfo "challenge"

-- * GameDifficultyIncr

gameDifficultyIncr :: MonadClient m => Int -> m ()
gameDifficultyIncr :: forall (m :: * -> *). MonadClient m => Int -> m ()
gameDifficultyIncr Int
delta = do
  nxtDiff <- (StateClient -> Int) -> m Int
forall a. (StateClient -> a) -> m a
forall (m :: * -> *) a.
MonadClientRead m =>
(StateClient -> a) -> m a
getsClient ((StateClient -> Int) -> m Int) -> (StateClient -> Int) -> m Int
forall a b. (a -> b) -> a -> b
$ Challenge -> Int
cdiff (Challenge -> Int)
-> (StateClient -> Challenge) -> StateClient -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateClient -> Challenge
snxtChal
  let d | Int
nxtDiff Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
delta Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
difficultyBound = Int
1
        | Int
nxtDiff Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
delta Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1 = Int
difficultyBound
        | Bool
otherwise = Int
nxtDiff Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
delta
  modifyClient $ \StateClient
cli -> StateClient
cli {snxtChal = (snxtChal cli) {cdiff = d} }

-- * GameFishToggle

gameFishToggle :: MonadClient m => m ()
gameFishToggle :: forall (m :: * -> *). MonadClient m => m ()
gameFishToggle =
  (StateClient -> StateClient) -> m ()
forall (m :: * -> *).
MonadClient m =>
(StateClient -> StateClient) -> m ()
modifyClient ((StateClient -> StateClient) -> m ())
-> (StateClient -> StateClient) -> m ()
forall a b. (a -> b) -> a -> b
$ \StateClient
cli ->
    StateClient
cli {snxtChal = (snxtChal cli) {cfish = not (cfish (snxtChal cli))} }

-- * GameGoodsToggle

gameGoodsToggle :: MonadClient m => m ()
gameGoodsToggle :: forall (m :: * -> *). MonadClient m => m ()
gameGoodsToggle =
  (StateClient -> StateClient) -> m ()
forall (m :: * -> *).
MonadClient m =>
(StateClient -> StateClient) -> m ()
modifyClient ((StateClient -> StateClient) -> m ())
-> (StateClient -> StateClient) -> m ()
forall a b. (a -> b) -> a -> b
$ \StateClient
cli ->
    StateClient
cli {snxtChal = (snxtChal cli) {cgoods = not (cgoods (snxtChal cli))} }

-- * GameWolfToggle

gameWolfToggle :: MonadClient m => m ()
gameWolfToggle :: forall (m :: * -> *). MonadClient m => m ()
gameWolfToggle =
  (StateClient -> StateClient) -> m ()
forall (m :: * -> *).
MonadClient m =>
(StateClient -> StateClient) -> m ()
modifyClient ((StateClient -> StateClient) -> m ())
-> (StateClient -> StateClient) -> m ()
forall a b. (a -> b) -> a -> b
$ \StateClient
cli ->
    StateClient
cli {snxtChal = (snxtChal cli) {cwolf = not (cwolf (snxtChal cli))} }

-- * GameKeeperToggle

gameKeeperToggle :: MonadClient m => m ()
gameKeeperToggle :: forall (m :: * -> *). MonadClient m => m ()
gameKeeperToggle =
  (StateClient -> StateClient) -> m ()
forall (m :: * -> *).
MonadClient m =>
(StateClient -> StateClient) -> m ()
modifyClient ((StateClient -> StateClient) -> m ())
-> (StateClient -> StateClient) -> m ()
forall a b. (a -> b) -> a -> b
$ \StateClient
cli ->
    StateClient
cli {snxtChal = (snxtChal cli) {ckeeper = not (ckeeper (snxtChal cli))} }

-- * GameScenarioIncr

gameScenarioIncr :: MonadClientUI m => Int -> m ()
gameScenarioIncr :: forall (m :: * -> *). MonadClientUI m => Int -> m ()
gameScenarioIncr Int
delta = do
  cops <- (State -> COps) -> m COps
forall a. (State -> a) -> m a
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  oldScenario <- getsSession snxtScenario
  let snxtScenario = Int
oldScenario Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
delta
      snxtTutorial = ModeKind -> Bool
MK.mtutorial (ModeKind -> Bool) -> ModeKind -> Bool
forall a b. (a -> b) -> a -> b
$ (ContentId ModeKind, ModeKind) -> ModeKind
forall a b. (a, b) -> b
snd ((ContentId ModeKind, ModeKind) -> ModeKind)
-> (ContentId ModeKind, ModeKind) -> ModeKind
forall a b. (a -> b) -> a -> b
$ COps -> Int -> (ContentId ModeKind, ModeKind)
nxtGameMode COps
cops Int
snxtScenario
  modifySession $ \SessionUI
sess -> SessionUI
sess {snxtScenario, snxtTutorial}

-- * GameRestart & GameQuit

data ExitStrategy = Restart | Quit

gameExitWithHuman :: MonadClientUI m => ExitStrategy -> m (FailOrCmd ReqUI)
gameExitWithHuman :: forall (m :: * -> *).
MonadClientUI m =>
ExitStrategy -> m (FailOrCmd ReqUI)
gameExitWithHuman ExitStrategy
exitStrategy = do
  snxtChal       <- (StateClient -> Challenge) -> m Challenge
forall a. (StateClient -> a) -> m a
forall (m :: * -> *) a.
MonadClientRead m =>
(StateClient -> a) -> m a
getsClient StateClient -> Challenge
snxtChal
  cops           <- getsState scops
  noConfirmsGame <- isNoConfirmsGame
  gameMode       <- getGameMode
  snxtScenario   <- getsSession snxtScenario
  let nxtGameName = ModeKind -> Text
MK.mname (ModeKind -> Text) -> ModeKind -> Text
forall a b. (a -> b) -> a -> b
$ (ContentId ModeKind, ModeKind) -> ModeKind
forall a b. (a, b) -> b
snd ((ContentId ModeKind, ModeKind) -> ModeKind)
-> (ContentId ModeKind, ModeKind) -> ModeKind
forall a b. (a -> b) -> a -> b
$ COps -> Int -> (ContentId ModeKind, ModeKind)
nxtGameMode COps
cops Int
snxtScenario
      exitReturn GroupName ModeKind
x = FailOrCmd ReqUI -> m (FailOrCmd ReqUI)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FailOrCmd ReqUI -> m (FailOrCmd ReqUI))
-> FailOrCmd ReqUI -> m (FailOrCmd ReqUI)
forall a b. (a -> b) -> a -> b
$ ReqUI -> FailOrCmd ReqUI
forall a b. b -> Either a b
Right (ReqUI -> FailOrCmd ReqUI) -> ReqUI -> FailOrCmd ReqUI
forall a b. (a -> b) -> a -> b
$ GroupName ModeKind -> Challenge -> ReqUI
ReqUIGameRestart GroupName ModeKind
x Challenge
snxtChal
      displayExitMessage Text
diff =
        ColorMode -> Text -> m Bool
forall (m :: * -> *).
MonadClientUI m =>
ColorMode -> Text -> m Bool
displayYesNo ColorMode
ColorBW
        (Text -> m Bool) -> Text -> m Bool
forall a b. (a -> b) -> a -> b
$ Text
diff Text -> Text -> Text
<+> Text
"progress of the ongoing"
          Text -> Text -> Text
<+> ModeKind -> Text
MK.mname ModeKind
gameMode Text -> Text -> Text
<+> Text
"game will be lost! Are you sure?"
  ifM (if' noConfirmsGame
           (return True)  -- true case
           (displayExitMessage $ case exitStrategy of  -- false case
              ExitStrategy
Restart -> Text
"You just requested a new" Text -> Text -> Text
<+> Text
nxtGameName
                         Text -> Text -> Text
<+> Text
"game. The "
              ExitStrategy
Quit -> Text
"If you quit, the "))
      (exitReturn $ case exitStrategy of  -- ifM true case
         ExitStrategy
Restart ->
           let (Text
mainName, Text
_) = (Char -> Bool) -> Text -> (Text, Text)
T.span (\Char
c -> Char -> Bool
Char.isAlpha Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ')
                                      Text
nxtGameName
           in Text -> GroupName ModeKind
forall c. Text -> GroupName c
DefsInternal.GroupName (Text -> GroupName ModeKind) -> Text -> GroupName ModeKind
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
" "
              ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
take Int
2 ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.words Text
mainName
         ExitStrategy
Quit -> GroupName ModeKind
MK.INSERT_COIN)
      (rndToActionUI (oneOf  -- ifM false case
                        [ "yea, would be a pity to leave them to die"
                        , "yea, a shame to get your team stranded" ])
       >>= failWith)

ifM :: Monad m => m Bool -> m b -> m b -> m b
ifM :: forall (m :: * -> *) b. Monad m => m Bool -> m b -> m b -> m b
ifM m Bool
b m b
t m b
f = do b' <- m Bool
b; if b' then t else f

if' :: Bool -> p -> p -> p
if' :: forall p. Bool -> p -> p -> p
if' Bool
b p
t p
f = if Bool
b then p
t else p
f

-- * GameDrop

gameDropHuman :: MonadClientUI m => m ReqUI
gameDropHuman :: forall (m :: * -> *). MonadClientUI m => m ReqUI
gameDropHuman = do
  (SessionUI -> SessionUI) -> m ()
forall (m :: * -> *).
MonadClientUI m =>
(SessionUI -> SessionUI) -> m ()
modifySession ((SessionUI -> SessionUI) -> m ())
-> (SessionUI -> SessionUI) -> m ()
forall a b. (a -> b) -> a -> b
$ \SessionUI
sess -> SessionUI
sess {sallNframes = -1}  -- hack, but we crash anyway
  MsgClassShow -> Text -> m ()
forall (m :: * -> *) a.
(MonadClientUI m, MsgShared a) =>
a -> Text -> m ()
msgAdd MsgClassShow
MsgPromptGeneric Text
"Interrupt! Trashing the unsaved game. The program exits now."
  Text -> m ()
forall (m :: * -> *). MonadClientUI m => Text -> m ()
clientPrintUI Text
"Interrupt! Trashing the unsaved game. The program exits now."
    -- this is not shown by ANSI frontend, but at least shown by sdl2 one
  ReqUI -> m ReqUI
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ReqUI
ReqUIGameDropAndExit

-- * GameExit

gameExitHuman :: Monad m => m ReqUI
gameExitHuman :: forall (m :: * -> *). Monad m => m ReqUI
gameExitHuman =
  ReqUI -> m ReqUI
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ReqUI
ReqUIGameSaveAndExit

-- * GameSave

gameSaveHuman :: MonadClientUI m => m ReqUI
gameSaveHuman :: forall (m :: * -> *). MonadClientUI m => m ReqUI
gameSaveHuman = do
  -- Announce before the saving started, since it can take a while.
  MsgClassSave -> Text -> m ()
forall (m :: * -> *) a.
(MonadClientUI m, MsgShared a) =>
a -> Text -> m ()
msgAdd MsgClassSave
MsgInnerWorkSpam Text
"Saving game backup."
  ReqUI -> m ReqUI
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ReqUI
ReqUIGameSave

-- * Doctrine

-- Note that the difference between seek-target and follow-the-leader doctrine
-- can influence even a faction with passive actors. E.g., if a passive actor
-- has an extra active skill from equipment, he moves every turn.
doctrineHuman :: MonadClientUI m => m (FailOrCmd ReqUI)
doctrineHuman :: forall (m :: * -> *). MonadClientUI m => m (FailOrCmd ReqUI)
doctrineHuman = do
  fid <- (StateClient -> FactionId) -> m FactionId
forall a. (StateClient -> a) -> m a
forall (m :: * -> *) a.
MonadClientRead m =>
(StateClient -> a) -> m a
getsClient StateClient -> FactionId
sside
  fromT <- getsState $ gdoctrine . (EM.! fid) . sfactionD
  let toT = if Doctrine
fromT Doctrine -> Doctrine -> Bool
forall a. Eq a => a -> a -> Bool
== Doctrine
forall a. Bounded a => a
maxBound then Doctrine
forall a. Bounded a => a
minBound else Doctrine -> Doctrine
forall a. Enum a => a -> a
succ Doctrine
fromT
  go <- displaySpaceEsc ColorFull
        $ "(Beware, work in progress!)"
          <+> "Current squad doctrine is '" <> Ability.nameDoctrine fromT <> "'"
          <+> "(" <> Ability.describeDoctrine fromT <> ")."
          <+> "Switching doctrine to '" <> Ability.nameDoctrine toT <> "'"
          <+> "(" <> Ability.describeDoctrine toT <> ")."
          <+> "This clears targets of all non-pointmen teammates."
          <+> "New targets will be picked according to new doctrine."
  if not go
  then failWith "squad doctrine change canceled"
  else return $ Right $ ReqUIDoctrine toT

-- * Automate

automateHuman :: MonadClientUI m => m (FailOrCmd ReqUI)
automateHuman :: forall (m :: * -> *). MonadClientUI m => m (FailOrCmd ReqUI)
automateHuman = do
  m ()
forall (m :: * -> *). MonadClientUI m => m ()
clearAimMode
  proceed <- ColorMode -> Text -> m Bool
forall (m :: * -> *).
MonadClientUI m =>
ColorMode -> Text -> m Bool
displayYesNo ColorMode
ColorBW Text
"Do you really want to cede control to AI?"
  if not proceed
  then failWith "automation canceled"
  else return $ Right ReqUIAutomate

-- * AutomateToggle

automateToggleHuman :: MonadClientUI m => m (FailOrCmd ReqUI)
automateToggleHuman :: forall (m :: * -> *). MonadClientUI m => m (FailOrCmd ReqUI)
automateToggleHuman = do
  swasAutomated <- (SessionUI -> Bool) -> m Bool
forall a. (SessionUI -> a) -> m a
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> Bool
swasAutomated
  if swasAutomated
  then failWith "automation canceled"
  else automateHuman

-- * AutomateBack

automateBackHuman :: MonadClientUI m => m (Either MError ReqUI)
automateBackHuman :: forall (m :: * -> *). MonadClientUI m => m (Either MError ReqUI)
automateBackHuman = do
  swasAutomated <- (SessionUI -> Bool) -> m Bool
forall a. (SessionUI -> a) -> m a
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> Bool
swasAutomated
  return $! if swasAutomated
            then Right ReqUIAutomate
            else Left Nothing