-- | 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 :: (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 :: CCUI -> InputContent
coinput=InputContent{Map HumanCmd [KM]
brevMap :: InputContent -> Map HumanCmd [KM]
brevMap :: Map HumanCmd [KM]
brevMap}} <- (SessionUI -> CCUI) -> m CCUI
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> CCUI
sccui
  PointUI
pUI <- (SessionUI -> PointUI) -> m PointUI
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> PointUI
spointer
  let PointSquare Int
px Int
py = PointUI -> PointSquare
uiToSquare PointUI
pUI
      p :: Point
p = Point :: Int -> Int -> Point
Point {Int
py :: Int
px :: Int
py :: Int
px :: Int
..}  -- abuse of convention: @Point@, not @PointSquare@ used
                      -- for the whole UI screen in square font coordinates
      pointerInArea :: CmdArea -> m Bool
pointerInArea CmdArea
a = do
        [Maybe Area]
rs <- CmdArea -> m [Maybe Area]
forall (m :: * -> *). MonadClientUI m => CmdArea -> m [Maybe Area]
areaToRectangles CmdArea
a
        Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$! (Area -> Bool) -> [Area] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Area -> Point -> Bool
`inside` Point
p) ([Area] -> Bool) -> [Area] -> Bool
forall a b. (a -> b) -> a -> b
$ [Maybe Area] -> [Area]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Area]
rs
  [(CmdArea, HumanCmd)]
cmds <- ((CmdArea, HumanCmd) -> m Bool)
-> [(CmdArea, HumanCmd)] -> m [(CmdArea, HumanCmd)]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (CmdArea -> m Bool
pointerInArea (CmdArea -> m Bool)
-> ((CmdArea, HumanCmd) -> CmdArea)
-> (CmdArea, HumanCmd)
-> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CmdArea, HumanCmd) -> CmdArea
forall a b. (a, b) -> a
fst) [(CmdArea, HumanCmd)]
l
  case [(CmdArea, HumanCmd)]
cmds of
    [] -> do
      m ()
forall (m :: * -> *). MonadClientUI m => m ()
stopPlayBack
      Either MError ReqUI -> m (Either MError ReqUI)
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 :: 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 :: CCUI -> ScreenContent
coscreen=ScreenContent{Int
rwidth :: ScreenContent -> Int
rwidth :: Int
rwidth, Int
rheight :: ScreenContent -> Int
rheight :: Int
rheight}} <- (SessionUI -> CCUI) -> m CCUI
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> CCUI
sccui
 case CmdArea
ca of
  CmdArea
CaMessage -> [(Int, Int, Int, Int)] -> m [(Int, Int, Int, Int)]
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@
    Maybe ActorId
mleader <- (StateClient -> Maybe ActorId) -> m (Maybe ActorId)
forall (m :: * -> *) a.
MonadClientRead m =>
(StateClient -> a) -> m a
getsClient StateClient -> Maybe ActorId
sleader
    case Maybe ActorId
mleader of
      Maybe ActorId
Nothing -> [(Int, Int, Int, Int)] -> m [(Int, Int, Int, Int)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
      Just ActorId
leader -> do
        Actor
b <- (State -> Actor) -> m Actor
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 Int
x Int
y = Point -> PointSquare
mapToSquare (Point -> PointSquare) -> Point -> PointSquare
forall a b. (a -> b) -> a -> b
$ Actor -> Point
bpos Actor
b
        [(Int, Int, Int, Int)] -> m [(Int, Int, Int, Int)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Int
x, Int
y, Int
x, Int
y)]
  CmdArea
CaMapParty -> do  -- takes preference over @CaMap@
    LevelId
lidV <- m LevelId
forall (m :: * -> *). MonadClientUI m => m LevelId
viewedLevelUI
    FactionId
side <- (StateClient -> FactionId) -> m FactionId
forall (m :: * -> *) a.
MonadClientRead m =>
(StateClient -> a) -> m a
getsClient StateClient -> FactionId
sside
    [Actor]
ours <- (State -> [Actor]) -> m [Actor]
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
$ (Actor -> Bool) -> [Actor] -> [Actor]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Actor -> Bool) -> Actor -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Actor -> Bool
bproj) ([Actor] -> [Actor]) -> (State -> [Actor]) -> State -> [Actor]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ActorId, Actor) -> Actor) -> [(ActorId, Actor)] -> [Actor]
forall a b. (a -> b) -> [a] -> [b]
map (ActorId, Actor) -> Actor
forall a b. (a, b) -> b
snd
                        ([(ActorId, Actor)] -> [Actor])
-> (State -> [(ActorId, Actor)]) -> State -> [Actor]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FactionId -> Bool) -> LevelId -> State -> [(ActorId, Actor)]
actorAssocs (FactionId -> FactionId -> Bool
forall a. Eq a => a -> a -> Bool
== FactionId
side) LevelId
lidV
    let rectFromB :: Point -> (Int, Int, Int, Int)
rectFromB Point
p = let PointSquare Int
x Int
y = Point -> PointSquare
mapToSquare Point
p
                      in (Int
x, Int
y, Int
x, Int
y)
    [(Int, Int, Int, Int)] -> m [(Int, Int, Int, Int)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Int, Int, Int, Int)] -> m [(Int, Int, Int, Int)])
-> [(Int, Int, Int, Int)] -> m [(Int, Int, Int, Int)]
forall a b. (a -> b) -> a -> b
$! (Actor -> (Int, Int, Int, Int))
-> [Actor] -> [(Int, Int, Int, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (Point -> (Int, Int, Int, Int)
rectFromB (Point -> (Int, Int, Int, Int))
-> (Actor -> Point) -> Actor -> (Int, Int, Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Actor -> Point
bpos) [Actor]
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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (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 :: m (Either MError ReqUI)
-> m (Either MError ReqUI) -> m (Either MError ReqUI)
byAimModeHuman m (Either MError ReqUI)
cmdNotAimingM m (Either MError ReqUI)
cmdAimingM = do
  Maybe AimMode
aimMode <- (SessionUI -> Maybe AimMode) -> m (Maybe AimMode)
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> Maybe AimMode
saimMode
  if Maybe AimMode -> Bool
forall a. Maybe a -> Bool
isNothing Maybe AimMode
aimMode then m (Either MError ReqUI)
cmdNotAimingM else m (Either MError ReqUI)
cmdAimingM

-- * ComposeIfLocal

composeIfLocalHuman :: MonadClientUI m
                    => m (Either MError ReqUI) -> m (Either MError ReqUI)
                    -> m (Either MError ReqUI)
composeIfLocalHuman :: m (Either MError ReqUI)
-> m (Either MError ReqUI) -> m (Either MError ReqUI)
composeIfLocalHuman m (Either MError ReqUI)
c1 m (Either MError ReqUI)
c2 = do
  Either MError ReqUI
slideOrCmd1 <- m (Either MError ReqUI)
c1
  case Either MError ReqUI
slideOrCmd1 of
    Left MError
merr1 -> do
      Either MError ReqUI
slideOrCmd2 <- m (Either MError ReqUI)
c2
      case Either MError ReqUI
slideOrCmd2 of
        Left MError
merr2 -> Either MError ReqUI -> m (Either MError ReqUI)
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 (m :: * -> *) a. Monad m => a -> m a
return Either MError ReqUI
slideOrCmd2
    Either MError ReqUI
_ -> Either MError ReqUI -> m (Either MError ReqUI)
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 :: m (Either MError ReqUI)
-> m (Either MError ReqUI) -> m (Either MError ReqUI)
composeUnlessErrorHuman m (Either MError ReqUI)
c1 m (Either MError ReqUI)
c2 = do
  Either MError ReqUI
slideOrCmd1 <- m (Either MError ReqUI)
c1
  case Either MError ReqUI
slideOrCmd1 of
    Left MError
Nothing -> m (Either MError ReqUI)
c2
    Either MError ReqUI
_ -> Either MError ReqUI -> m (Either MError ReqUI)
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 :: m (Either MError ReqUI)
-> m (Either MError ReqUI) -> m (Either MError ReqUI)
compose2ndLocalHuman m (Either MError ReqUI)
c1 m (Either MError ReqUI)
c2 = do
  Either MError ReqUI
slideOrCmd1 <- m (Either MError ReqUI)
c1
  case Either MError ReqUI
slideOrCmd1 of
    Left MError
merr1 -> do
      Either MError ReqUI
slideOrCmd2 <- m (Either MError ReqUI)
c2
      case Either MError ReqUI
slideOrCmd2 of
        Left MError
merr2 -> Either MError ReqUI -> m (Either MError ReqUI)
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 (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 (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 :: m (Either MError ReqUI) -> m (Either MError ReqUI)
loopOnNothingHuman m (Either MError ReqUI)
cmd = do
  Either MError ReqUI
res <- m (Either MError ReqUI)
cmd
  case Either MError ReqUI
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 (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 :: m (Either MError ReqUI) -> m (Either MError ReqUI)
executeIfClearHuman m (Either MError ReqUI)
c1 = do
  Bool
sreportNull <- (SessionUI -> Bool) -> m Bool
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> Bool
sreportNull
  ReqDelay
sreqDelay <- (SessionUI -> ReqDelay) -> m ReqDelay
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> ReqDelay
sreqDelay
  -- When server query delay is handled, don't complicate things by clearing
  -- screen instead of running the command.
  if Bool
sreportNull Bool -> Bool -> Bool
|| ReqDelay
sreqDelay ReqDelay -> ReqDelay -> Bool
forall a. Eq a => a -> a -> Bool
== ReqDelay
ReqDelayHandled
  then m (Either MError ReqUI)
c1
  else Either MError ReqUI -> m (Either MError ReqUI)
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

-- * Wait

-- | Leader waits a turn (and blocks, etc.).
waitHuman :: MonadClientUI m => ActorId -> m (FailOrCmd RequestTimed)
waitHuman :: ActorId -> m (FailOrCmd RequestTimed)
waitHuman ActorId
leader = do
  Skills
actorCurAndMaxSk <- (State -> Skills) -> m Skills
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 Skill -> Skills -> Int
Ability.getSk Skill
Ability.SkWait Skills
actorCurAndMaxSk Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then 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 {swaitTimes :: Int
swaitTimes = Int -> Int
forall a. Num a => a -> a
abs (SessionUI -> Int
swaitTimes SessionUI
sess) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1}
    FailOrCmd RequestTimed -> m (FailOrCmd RequestTimed)
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
ReqWait
  else ReqFailure -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a.
MonadClientUI m =>
ReqFailure -> m (FailOrCmd a)
failSer ReqFailure
WaitUnskilled

-- * Wait10

-- | Leader waits a 1/10th of a turn (and doesn't block, etc.).
waitHuman10 :: MonadClientUI m => ActorId -> m (FailOrCmd RequestTimed)
waitHuman10 :: ActorId -> m (FailOrCmd RequestTimed)
waitHuman10 ActorId
leader = do
  Skills
actorCurAndMaxSk <- (State -> Skills) -> m Skills
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 Skill -> Skills -> Int
Ability.getSk Skill
Ability.SkWait Skills
actorCurAndMaxSk Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
4 then 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 {swaitTimes :: Int
swaitTimes = Int -> Int
forall a. Num a => a -> a
abs (SessionUI -> Int
swaitTimes SessionUI
sess) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1}
    FailOrCmd RequestTimed -> m (FailOrCmd RequestTimed)
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
ReqWait10
  else ReqFailure -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a.
MonadClientUI m =>
ReqFailure -> m (FailOrCmd a)
failSer ReqFailure
WaitUnskilled

-- * Yell

-- | Leader yells or yawns, if sleeping.
yellHuman :: MonadClientUI m => ActorId -> m (FailOrCmd RequestTimed)
yellHuman :: ActorId -> m (FailOrCmd RequestTimed)
yellHuman ActorId
leader = do
  Skills
actorCurAndMaxSk <- (State -> Skills) -> m Skills
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 Skill -> Skills -> Int
Ability.getSk Skill
Ability.SkWait Skills
actorCurAndMaxSk Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
     -- If waiting drained and really, potentially, no other possible action,
     -- still allow yelling.
     Bool -> Bool -> Bool
|| Skill -> Skills -> Int
Ability.getSk Skill
Ability.SkMove Skills
actorCurAndMaxSk Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0
     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
     Bool -> Bool -> Bool
|| Skill -> Skills -> Int
Ability.getSk Skill
Ability.SkMelee Skills
actorCurAndMaxSk Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0
  then FailOrCmd RequestTimed -> m (FailOrCmd RequestTimed)
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
ReqYell
  else ReqFailure -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a.
MonadClientUI m =>
ReqFailure -> m (FailOrCmd a)
failSer ReqFailure
WaitUnskilled

-- * MoveDir and RunDir

moveRunHuman :: (MonadClient m, MonadClientUI m)
             => ActorId -> Bool -> Bool -> Bool -> Bool -> Vector
             -> m (FailOrCmd RequestTimed)
moveRunHuman :: ActorId
-> Bool
-> Bool
-> Bool
-> Bool
-> Vector
-> m (FailOrCmd RequestTimed)
moveRunHuman ActorId
leader Bool
initialStep Bool
finalGoal Bool
run Bool
runAhead Vector
dir = do
  Skills
actorCurAndMaxSk <- (State -> Skills) -> m Skills
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
  LevelId
arena <- m LevelId
forall (m :: * -> *). MonadClientUI m => m LevelId
getArenaUI
  Actor
sb <- (State -> Actor) -> m Actor
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
  Faction
fact <- (State -> Faction) -> m Faction
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.! Actor -> FactionId
bfid Actor
sb) (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
  -- 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.
  EnumSet ActorId
sel <- (SessionUI -> EnumSet ActorId) -> m (EnumSet ActorId)
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> EnumSet ActorId
sselected
  let runMembers :: [ActorId]
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
runParams = RunParams :: ActorId -> [ActorId] -> Bool -> Maybe Text -> Int -> 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 :: m ()
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 :: Maybe RunParams
srunning = RunParams -> Maybe RunParams
forall a. a -> Maybe a
Just RunParams
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 :: Point
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).
  [(ActorId, Actor)]
tgts <- (State -> [(ActorId, Actor)]) -> m [(ActorId, Actor)]
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> [(ActorId, Actor)]) -> m [(ActorId, Actor)])
-> (State -> [(ActorId, Actor)]) -> m [(ActorId, Actor)]
forall a b. (a -> b) -> a -> b
$ Point -> LevelId -> State -> [(ActorId, Actor)]
posToAidAssocs Point
tpos LevelId
arena
  case [(ActorId, Actor)]
tgts of
    [] -> do  -- move or search or alter
      FailOrCmd RequestTimed
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 FailOrCmd RequestTimed
runStopOrCmd of
        Left FailError
stopMsg -> FailOrCmd RequestTimed -> m (FailOrCmd RequestTimed)
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 (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.
      Bool
success <- Bool -> ActorId -> m Bool
forall (m :: * -> *). MonadClientUI m => Bool -> ActorId -> m Bool
pickLeader Bool
True ActorId
target
      let !_A :: ()
_A = Bool -> () -> ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Bool
success Bool -> (String, (ActorId, ActorId, Actor)) -> Bool
forall a. Show a => Bool -> a -> 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)) ()
      Text -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith Text
"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 :: ActorId -> ActorId -> m (FailOrCmd RequestTimed)
meleeAid ActorId
leader ActorId
target = do
  FactionId
side <- (StateClient -> FactionId) -> m FactionId
forall (m :: * -> *) a.
MonadClientRead m =>
(StateClient -> a) -> m a
getsClient StateClient -> FactionId
sside
  Actor
tb <- (State -> Actor) -> m Actor
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
target
  Faction
sfact <- (State -> Faction) -> m Faction
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
  Maybe RequestTimed
mel <- ActorId -> ActorId -> m (Maybe RequestTimed)
forall (m :: * -> *).
MonadClient m =>
ActorId -> ActorId -> m (Maybe RequestTimed)
pickWeaponClient ActorId
leader ActorId
target
  case Maybe RequestTimed
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 :: Maybe Target
sxhair = 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}
            FailOrCmd RequestTimed -> m (FailOrCmd RequestTimed)
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) ()
                Bool
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 Bool -> Bool
not Bool
go1 then Text -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith Text
"attack canceled" else m (FailOrCmd RequestTimed)
returnCmd
              | Bool
otherwise = do
                Bool
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 Bool -> Bool
not Bool
go2 then Text -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith Text
"attack canceled" else m (FailOrCmd RequestTimed)
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 :: ActorId -> ActorId -> m (FailOrCmd RequestTimed)
displaceAid ActorId
leader ActorId
target = do
  COps{TileSpeedup
coTileSpeedup :: COps -> TileSpeedup
coTileSpeedup :: TileSpeedup
coTileSpeedup} <- (State -> COps) -> m COps
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  Actor
sb <- (State -> Actor) -> m Actor
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
  Actor
tb <- (State -> Actor) -> m Actor
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
target
  Faction
tfact <- (State -> Faction) -> m Faction
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.! Actor -> FactionId
bfid Actor
tb) (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
  Skills
actorMaxSk <- (State -> Skills) -> m Skills
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
target
  Bool
dEnemy <- (State -> Bool) -> m Bool
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 -> ActorId -> Skills -> State -> Bool
dispEnemy ActorId
leader ActorId
target Skills
actorMaxSk
  let immobile :: Bool
immobile = Skill -> Skills -> Int
Ability.getSk Skill
Ability.SkMove Skills
actorMaxSk Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0
      tpos :: Point
tpos = Actor -> Point
bpos Actor
tb
      adj :: Bool
adj = Actor -> Actor -> Bool
checkAdjacent Actor
sb Actor
tb
      atWar :: Bool
atWar = FactionId -> Faction -> FactionId -> Bool
isFoe (Actor -> FactionId
bfid Actor
tb) Faction
tfact (Actor -> FactionId
bfid Actor
sb)
  if | Bool -> Bool
not Bool
adj -> ReqFailure -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a.
MonadClientUI m =>
ReqFailure -> m (FailOrCmd a)
failSer ReqFailure
DisplaceDistant
     | Bool -> Bool
not (Actor -> Bool
bproj Actor
tb) Bool -> Bool -> Bool
&& Bool
atWar
       Bool -> Bool -> Bool
&& Actor -> Bool
actorDying Actor
tb ->  -- checked separately for a better message
       ReqFailure -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a.
MonadClientUI m =>
ReqFailure -> m (FailOrCmd a)
failSer ReqFailure
DisplaceDying
     | Bool -> Bool
not (Actor -> Bool
bproj Actor
tb) Bool -> Bool -> Bool
&& Bool
atWar
       Bool -> Bool -> Bool
&& Actor -> Bool
actorWaits Actor
tb ->  -- checked separately for a better message
       ReqFailure -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a.
MonadClientUI m =>
ReqFailure -> m (FailOrCmd a)
failSer ReqFailure
DisplaceBraced
     | Bool -> Bool
not (Actor -> Bool
bproj Actor
tb) Bool -> Bool -> Bool
&& Bool
atWar
       Bool -> Bool -> Bool
&& Bool
immobile ->  -- checked separately for a better message
       ReqFailure -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a.
MonadClientUI m =>
ReqFailure -> m (FailOrCmd a)
failSer ReqFailure
DisplaceImmobile
     | Bool -> Bool
not Bool
dEnemy Bool -> Bool -> Bool
&& Bool
atWar ->
       ReqFailure -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a.
MonadClientUI m =>
ReqFailure -> m (FailOrCmd a)
failSer ReqFailure
DisplaceSupported
     | Bool
otherwise -> do
       let lid :: LevelId
lid = Actor -> LevelId
blid Actor
sb
       Level
lvl <- LevelId -> m Level
forall (m :: * -> *). MonadStateRead m => LevelId -> m Level
getLevel LevelId
lid
       -- Displacing requires full access.
       if TileSpeedup -> ContentId TileKind -> Bool
Tile.isWalkable TileSpeedup
coTileSpeedup (ContentId TileKind -> Bool) -> ContentId TileKind -> Bool
forall a b. (a -> b) -> a -> b
$ Level
lvl Level -> Point -> ContentId TileKind
`at` Point
tpos then
         case Point -> Level -> [ActorId]
posToAidsLvl Point
tpos Level
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 (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 ReqFailure -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a.
MonadClientUI m =>
ReqFailure -> m (FailOrCmd a)
failSer ReqFailure
DisplaceAccess

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

alterCommon :: MonadClientUI m
            => ActorId -> Bool -> Point -> m (FailOrCmd RequestTimed)
alterCommon :: ActorId -> Bool -> Point -> m (FailOrCmd RequestTimed)
alterCommon ActorId
leader Bool
bumping Point
tpos = do
  CCUI{coscreen :: CCUI -> ScreenContent
coscreen=ScreenContent{Int
rwidth :: Int
rwidth :: ScreenContent -> Int
rwidth}} <- (SessionUI -> CCUI) -> m CCUI
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> CCUI
sccui
  cops :: COps
cops@COps{ContentData TileKind
cotile :: COps -> ContentData TileKind
cotile :: ContentData TileKind
cotile, TileSpeedup
coTileSpeedup :: TileSpeedup
coTileSpeedup :: COps -> TileSpeedup
coTileSpeedup} <- (State -> COps) -> m COps
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  FactionId
side <- (StateClient -> FactionId) -> m FactionId
forall (m :: * -> *) a.
MonadClientRead m =>
(StateClient -> a) -> m a
getsClient StateClient -> FactionId
sside
  EnumMap FactionId Faction
factionD <- (State -> EnumMap FactionId Faction)
-> m (EnumMap FactionId Faction)
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> EnumMap FactionId Faction
sfactionD
  Skills
actorCurAndMaxSk <- (State -> Skills) -> m Skills
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
  Actor
sb <- (State -> Actor) -> m Actor
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 alterSkill :: Int
alterSkill = Skill -> Skills -> Int
Ability.getSk Skill
Ability.SkAlter Skills
actorCurAndMaxSk
      spos :: Point
spos = Actor -> Point
bpos Actor
sb
  Bool
alterable <- (State -> Bool) -> m Bool
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
$ LevelId -> Point -> State -> Bool
tileAlterable (Actor -> LevelId
blid Actor
sb) Point
tpos
  Level
lvl <- LevelId -> m Level
forall (m :: * -> *). MonadStateRead m => LevelId -> m Level
getLevel (LevelId -> m Level) -> LevelId -> m Level
forall a b. (a -> b) -> a -> b
$ Actor -> LevelId
blid Actor
sb
  Time
localTime <- (State -> Time) -> m Time
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Time) -> m Time) -> (State -> Time) -> m Time
forall a b. (a -> b) -> a -> b
$ LevelId -> State -> Time
getLocalTime (Actor -> LevelId
blid Actor
sb)
  ItemBag
embeds <- (State -> ItemBag) -> m ItemBag
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
$ LevelId -> Point -> State -> ItemBag
getEmbedBag (Actor -> LevelId
blid Actor
sb) Point
tpos
  ItemId -> ItemFull
itemToF <- (State -> ItemId -> ItemFull) -> m (ItemId -> ItemFull)
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> ItemId -> ItemFull) -> m (ItemId -> ItemFull))
-> (State -> ItemId -> ItemFull) -> m (ItemId -> ItemFull)
forall a b. (a -> b) -> a -> b
$ (ItemId -> State -> ItemFull) -> State -> ItemId -> ItemFull
forall a b c. (a -> b -> c) -> b -> a -> c
flip ItemId -> State -> ItemFull
itemToFull
  ItemId -> ItemKind
getKind <- (State -> ItemId -> ItemKind) -> m (ItemId -> ItemKind)
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> ItemId -> ItemKind) -> m (ItemId -> ItemKind))
-> (State -> ItemId -> ItemKind) -> m (ItemId -> ItemKind)
forall a b. (a -> b) -> a -> b
$ (ItemId -> State -> ItemKind) -> State -> ItemId -> ItemKind
forall a b c. (a -> b -> c) -> b -> a -> c
flip ItemId -> State -> ItemKind
getIidKind
  let t :: ContentId TileKind
t = Level
lvl Level -> Point -> ContentId TileKind
`at` Point
tpos
      underFeet :: Bool
underFeet = Point
tpos Point -> Point -> Bool
forall a. Eq a => a -> a -> Bool
== Point
spos  -- if enter and alter, be more permissive
      modificationFailureHint :: m ()
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 | Bool -> Bool
not Bool
alterable -> do
         let name :: Part
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, (Int, ItemTimers)) -> Part
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 :: [(ItemKind, (ItemId, (Int, ItemTimers)))]
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 :: [Part]
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
         Text -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith (Text -> m (FailOrCmd RequestTimed))
-> Text -> m (FailOrCmd RequestTimed)
forall a b. (a -> b) -> a -> b
$ [Part] -> Text
makePhrase ([Part] -> Text) -> [Part] -> Text
forall a b. (a -> b) -> a -> b
$
           [Part
"there is no point kicking", Part -> Part
MU.AW Part
name]
           [Part] -> [Part] -> [Part]
forall a. [a] -> [a] -> [a]
++ if ItemBag -> Bool
forall k a. EnumMap k a -> Bool
EM.null ItemBag
embeds
              then []
              else [Part
"with", [Part] -> Part
MU.WWandW [Part]
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
     | TileSpeedup -> ContentId TileKind -> Bool
Tile.isSuspect TileSpeedup
coTileSpeedup ContentId TileKind
t
       Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
underFeet
       Bool -> Bool -> Bool
&& Int
alterSkill Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1 -> do
         m ()
modificationFailureHint
         ReqFailure -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a.
MonadClientUI m =>
ReqFailure -> m (FailOrCmd a)
failSer ReqFailure
AlterUnskilled
     | Bool -> Bool
not (TileSpeedup -> ContentId TileKind -> Bool
Tile.isSuspect TileSpeedup
coTileSpeedup ContentId TileKind
t)
       Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
underFeet
       Bool -> Bool -> Bool
&& Int
alterSkill Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< TileSpeedup -> ContentId TileKind -> Int
Tile.alterMinSkill TileSpeedup
coTileSpeedup ContentId TileKind
t -> do
         -- Rather rare (requires high skill), so describe the tile.
         [(MsgClassShow, Text)]
blurb <- Point -> LevelId -> m [(MsgClassShow, Text)]
forall (m :: * -> *).
MonadClientUI m =>
Point -> LevelId -> m [(MsgClassShow, Text)]
lookAtPosition Point
tpos (Actor -> LevelId
blid Actor
sb)
         ((MsgClassShow, Text) -> m ()) -> [(MsgClassShow, Text)] -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m ()) -> t a -> m ()
mapM_ ((MsgClassShow -> Text -> m ()) -> (MsgClassShow, Text) -> m ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry MsgClassShow -> Text -> m ()
forall (m :: * -> *) a.
(MonadClientUI m, MsgShared a) =>
a -> Text -> m ()
msgAdd) [(MsgClassShow, Text)]
blurb
         m ()
modificationFailureHint
         ReqFailure -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a.
MonadClientUI m =>
ReqFailure -> m (FailOrCmd a)
failSer ReqFailure
AlterUnwalked
     | Point -> Point -> Int
chessDist Point
tpos (Actor -> Point
bpos Actor
sb) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 ->
         -- Checked late to give useful info about distant tiles.
         ReqFailure -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a.
MonadClientUI m =>
ReqFailure -> m (FailOrCmd a)
failSer ReqFailure
AlterDistant
     | Bool -> Bool
not Bool
underFeet
       Bool -> Bool -> Bool
&& (Point -> Level -> Bool
occupiedBigLvl Point
tpos Level
lvl Bool -> Bool -> Bool
|| Point -> Level -> Bool
occupiedProjLvl Point
tpos Level
lvl) ->
         -- Don't mislead describing terrain, if other actor is to blame.
         ReqFailure -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a.
MonadClientUI m =>
ReqFailure -> m (FailOrCmd a)
failSer ReqFailure
AlterBlockActor
     | Bool
otherwise -> do  -- promising
         FailOrCmd ()
verAlters <- ActorId -> Bool -> Point -> m (FailOrCmd ())
forall (m :: * -> *).
MonadClientUI m =>
ActorId -> Bool -> Point -> m (FailOrCmd ())
verifyAlters ActorId
leader Bool
bumping Point
tpos
         case FailOrCmd ()
verAlters of
           Right () ->
             if Bool
bumping then
               FailOrCmd RequestTimed -> m (FailOrCmd RequestTimed)
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 (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 (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 :: ActorId -> m (Either MError RequestTimed)
runOnceAheadHuman ActorId
leader = do
  FactionId
side <- (StateClient -> FactionId) -> m FactionId
forall (m :: * -> *) a.
MonadClientRead m =>
(StateClient -> a) -> m a
getsClient StateClient -> FactionId
sside
  Faction
fact <- (State -> Faction) -> m Faction
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
  Bool
keyPressed <- m Bool
forall (m :: * -> *). MonadClientUI m => m Bool
anyKeyPressed
  Maybe RunParams
srunning <- (SessionUI -> Maybe RunParams) -> m (Maybe RunParams)
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> Maybe RunParams
srunning
  -- When running, stop if disturbed. If not running, stop at once.
  case Maybe RunParams
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 (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 :: [ActorId]
runMembers :: RunParams -> [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 (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
      LevelId
arena <- m LevelId
forall (m :: * -> *). MonadClientUI m => m LevelId
getArenaUI
      Either Text RequestTimed
runOutcome <- LevelId -> RunParams -> m (Either Text RequestTimed)
forall (m :: * -> *).
MonadClientUI m =>
LevelId -> RunParams -> m (Either Text RequestTimed)
continueRun LevelId
arena RunParams
runParams
      case Either Text RequestTimed
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 (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 (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 :: 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 :: ActorId -> Bool -> Bool -> m (FailOrCmd RequestTimed)
goToXhair ActorId
leader Bool
initialStep Bool
run = do
  Maybe AimMode
aimMode <- (SessionUI -> Maybe AimMode) -> m (Maybe AimMode)
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> Maybe AimMode
saimMode
  -- Movement is legal only outside aiming mode.
  if Maybe AimMode -> Bool
forall a. Maybe a -> Bool
isJust Maybe AimMode
aimMode
  then Text -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith Text
"cannot move in aiming mode"
  else ActorId -> Bool -> Bool -> m (FailOrCmd RequestTimed)
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
ActorId -> Bool -> Bool -> m (FailOrCmd RequestTimed)
goToXhairExplorationMode ActorId
leader Bool
initialStep Bool
run

goToXhairExplorationMode :: (MonadClient m, MonadClientUI m)
                         => ActorId -> Bool -> Bool
                         -> m (FailOrCmd RequestTimed)
goToXhairExplorationMode :: ActorId -> Bool -> Bool -> m (FailOrCmd RequestTimed)
goToXhairExplorationMode ActorId
leader Bool
initialStep Bool
run = do
  Skills
actorCurAndMaxSk <- (State -> Skills) -> m Skills
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
  Actor
sb <- (State -> Actor) -> m Actor
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 moveSkill :: Int
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 | Int
moveSkill Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 -> do
       Maybe Target
xhair <- (SessionUI -> Maybe Target) -> m (Maybe Target)
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> Maybe Target
sxhair
       Maybe Target
xhairGoTo <- (SessionUI -> Maybe Target) -> m (Maybe Target)
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> Maybe Target
sxhairGoTo
       FailOrCmd RequestTimed
mfail <-
         if Maybe Target -> Bool
forall a. Maybe a -> Bool
isJust Maybe Target
xhairGoTo Bool -> Bool -> Bool
&& Maybe Target
xhairGoTo Maybe Target -> Maybe Target -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Target
xhair
         then Text -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith Text
"crosshair position changed"
         else do
           Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Target -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Target
xhairGoTo) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$  -- set it up for next steps
             (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 {sxhairGoTo :: Maybe Target
sxhairGoTo = Maybe Target
xhair}
           ActorId -> Bool -> Bool -> m (FailOrCmd RequestTimed)
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
ActorId -> Bool -> Bool -> m (FailOrCmd RequestTimed)
goToXhairGoTo ActorId
leader Bool
initialStep Bool
run
       Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FailOrCmd RequestTimed -> Bool
forall a b. Either a b -> Bool
isLeft FailOrCmd RequestTimed
mfail) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
         (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 {sxhairGoTo :: Maybe Target
sxhairGoTo = Maybe Target
forall a. Maybe a
Nothing}
       FailOrCmd RequestTimed -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a. Monad m => a -> m a
return FailOrCmd RequestTimed
mfail
     | Actor -> Watchfulness
bwatch Actor
sb Watchfulness -> Watchfulness -> Bool
forall a. Eq a => a -> a -> Bool
== Watchfulness
WSleep -> ReqFailure -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a.
MonadClientUI m =>
ReqFailure -> m (FailOrCmd a)
failSer ReqFailure
MoveUnskilledAsleep
     | Bool
otherwise -> ReqFailure -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a.
MonadClientUI m =>
ReqFailure -> m (FailOrCmd a)
failSer ReqFailure
MoveUnskilled

goToXhairGoTo :: (MonadClient m, MonadClientUI m)
              => ActorId -> Bool -> Bool -> m (FailOrCmd RequestTimed)
goToXhairGoTo :: ActorId -> Bool -> Bool -> m (FailOrCmd RequestTimed)
goToXhairGoTo ActorId
leader Bool
initialStep Bool
run = do
  Actor
b <- (State -> Actor) -> m Actor
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
  Maybe Point
mxhairPos <- m (Maybe Point)
forall (m :: * -> *). MonadClientUI m => m (Maybe Point)
mxhairToPos
  case Maybe Point
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
      Maybe RunParams
running <- (SessionUI -> Maybe RunParams) -> m (Maybe RunParams)
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> Maybe RunParams
srunning
      case Maybe RunParams
running of
        -- Don't use running params from previous run or goto-xhair.
        Just RunParams
paramOld | Bool -> Bool
not Bool
initialStep -> do
          LevelId
arena <- m LevelId
forall (m :: * -> *). MonadClientUI m => m LevelId
getArenaUI
          FailOrCmd (Bool, Vector)
runOutcome <- 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
paramOld
          case FailOrCmd (Bool, Vector)
runOutcome of
            Left FailError
stopMsg -> FailOrCmd RequestTimed -> m (FailOrCmd RequestTimed)
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) ()
          (Array BfsDistance
bfs, Maybe AndPath
mpath) <- ActorId -> Point -> m (Array BfsDistance, Maybe AndPath)
forall (m :: * -> *).
MonadClient m =>
ActorId -> Point -> m (Array BfsDistance, Maybe AndPath)
getCacheBfsAndPath ActorId
leader Point
c
          Bool
xhairMoused <- (SessionUI -> Bool) -> m Bool
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> Bool
sxhairMoused
          case Maybe AndPath
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 :: 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 :: Int
runWaiting :: RunParams -> Int
runWaiting} -> do
      Bool
onLevel <- (State -> Bool) -> m Bool
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
      Actor
b <- (State -> Actor) -> m Actor
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
r
      Maybe Point
mxhairPos <- m (Maybe Point)
forall (m :: * -> *). MonadClientUI m => m (Maybe Point)
mxhairToPos
      if Bool -> Bool
not Bool
onLevel Bool -> Bool -> Bool
|| Maybe Point
mxhairPos Maybe Point -> Maybe Point -> Bool
forall a. Eq a => a -> a -> Bool
== Point -> Maybe Point
forall a. a -> Maybe a
Just (Actor -> Point
bpos Actor
b) then do
        let paramNew :: RunParams
paramNew = RunParams
paramOld {runMembers :: [ActorId]
runMembers = [ActorId]
rs}
        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
      else do
        State
sL <- m State
forall (m :: * -> *). MonadStateRead m => m State
getState
        (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 -> State -> StateClient -> StateClient
updateLeader ActorId
r State
sL
        let runMembersNew :: [ActorId]
runMembersNew = [ActorId]
rs [ActorId] -> [ActorId] -> [ActorId]
forall a. [a] -> [a] -> [a]
++ [ActorId
r]
            paramNew :: RunParams
paramNew = RunParams
paramOld { runMembers :: [ActorId]
runMembers = [ActorId]
runMembersNew
                                , runWaiting :: Int
runWaiting = Int
0}
        (Array BfsDistance
bfs, Maybe AndPath
mpath) <- ActorId -> Point -> m (Array BfsDistance, Maybe AndPath)
forall (m :: * -> *).
MonadClient m =>
ActorId -> Point -> m (Array BfsDistance, Maybe AndPath)
getCacheBfsAndPath ActorId
r Point
c
        Bool
xhairMoused <- (SessionUI -> Bool) -> m Bool
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> Bool
sxhairMoused
        case Maybe AndPath
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
            [ActorId]
tgts <- (State -> [ActorId]) -> m [ActorId]
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 [ActorId]
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 :: Maybe RunParams
srunning = RunParams -> Maybe RunParams
forall a. a -> Maybe a
Just RunParams
paramNew}
                FailOrCmd (Bool, Vector) -> m (FailOrCmd (Bool, Vector))
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 (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 :: Int
runWaiting=Int
runWaiting Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
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 :: 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 :: 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 :: 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) ()
  Skills
actorCurAndMaxSk <- (State -> Skills) -> m Skills
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 Skill -> Skills -> Int
Ability.getSk Skill
Ability.SkMoveItem Skills
actorCurAndMaxSk Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
  then 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
  else ReqFailure -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a.
MonadClientUI m =>
ReqFailure -> m (FailOrCmd a)
failSer ReqFailure
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 :: ActorId
-> [CStore]
-> CStore
-> Maybe Text
-> Bool
-> m (FailOrCmd RequestTimed)
moveOrSelectItem ActorId
leader [CStore]
storesRaw CStore
destCStore Maybe Text
mverb Bool
auto = do
  Actor
b <- (State -> Actor) -> m Actor
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
  Skills
actorCurAndMaxSk <- (State -> Skills) -> m Skills
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
  Maybe (LevelId, Point)
mstash <- (State -> Maybe (LevelId, Point)) -> m (Maybe (LevelId, Point))
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Maybe (LevelId, Point)) -> m (Maybe (LevelId, Point)))
-> (State -> Maybe (LevelId, Point)) -> m (Maybe (LevelId, Point))
forall a b. (a -> b) -> a -> b
$ \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 :: Bool
calmE = Actor -> Skills -> Bool
calmEnough Actor
b Skills
actorCurAndMaxSk
      overStash :: Bool
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 :: [CStore]
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
  Maybe (ItemId, CStore, Bool)
itemSel <- (SessionUI -> Maybe (ItemId, CStore, Bool))
-> m (Maybe (ItemId, CStore, Bool))
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> Maybe (ItemId, CStore, Bool)
sitemSel
  (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 :: Maybe (ItemId, CStore, Bool)
sitemSel = Maybe (ItemId, CStore, Bool)
forall a. Maybe a
Nothing}  -- prevent surprise
  case Maybe (ItemId, CStore, Bool)
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 (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 (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 (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CStore]
stores -> do
      ItemBag
bag <- (State -> ItemBag) -> m ItemBag
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 ItemId
iid ItemId -> ItemBag -> Maybe (Int, ItemTimers)
forall k a. Enum k => k -> EnumMap k a -> Maybe a
`EM.lookup` ItemBag
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
               Either MError Int
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 Either MError Int
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 (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
      FailOrCmd (CStore, [(ItemId, (Int, ItemTimers))])
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 FailOrCmd (CStore, [(ItemId, (Int, ItemTimers))])
mis of
        Left FailError
err -> FailOrCmd RequestTimed -> m (FailOrCmd RequestTimed)
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 :: Maybe (ItemId, CStore, Bool)
sitemSel = (ItemId, CStore, Bool) -> Maybe (ItemId, CStore, Bool)
forall a. a -> Maybe a
Just (ItemId
iid, CStore
fromCStore, Bool
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 :: 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
  Skills
actorCurAndMaxSk <- (State -> Skills) -> m Skills
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
  Actor
b <- (State -> Actor) -> m Actor
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
  Maybe (LevelId, Point)
mstash <- (State -> Maybe (LevelId, Point)) -> m (Maybe (LevelId, Point))
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Maybe (LevelId, Point)) -> m (Maybe (LevelId, Point)))
-> (State -> Maybe (LevelId, Point)) -> m (Maybe (LevelId, Point))
forall a b. (a -> b) -> a -> b
$ \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
  Maybe (CStore, CStore)
lastItemMove <- (SessionUI -> Maybe (CStore, CStore)) -> m (Maybe (CStore, CStore))
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> Maybe (CStore, CStore)
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 :: Bool
calmE = Actor -> Skills -> Bool
calmEnough Actor
b Skills
actorCurAndMaxSk
      overStash :: Bool
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 | 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 (CStore, [(ItemId, (Int, ItemTimers))]))
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 (CStore, [(ItemId, (Int, ItemTimers))]))
forall (m :: * -> *) a.
MonadClientUI m =>
ReqFailure -> m (FailOrCmd a)
failSer ReqFailure
ItemOverStash
     | CStore
destCStore CStore -> CStore -> Bool
forall a. Eq a => a -> a -> Bool
== CStore
CEqp Bool -> Bool -> Bool
&& Actor -> Int -> Bool
eqpOverfull Actor
b Int
1 -> ReqFailure -> m (FailOrCmd (CStore, [(ItemId, (Int, ItemTimers))]))
forall (m :: * -> *) a.
MonadClientUI m =>
ReqFailure -> m (FailOrCmd a)
failSer ReqFailure
EqpOverfull
     | Bool
otherwise -> do
       let storesLast :: [CStore]
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 (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
prompt = Text
"What to"
           promptEqp :: Text
promptEqp = Text
"What consumable to"
           eqpItemsN :: Actor -> Text
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 -> Skills -> ItemDialogMode -> Text
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
""
           (Text
promptGeneric, m Suitability
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 CStore
destCStore CStore -> CStore -> Bool
forall a. Eq a => a -> a -> Bool
== CStore
CEqp
             then (Text
promptEqp, Suitability -> m Suitability
forall (m :: * -> *) a. Monad m => a -> m a
return (Suitability -> m Suitability) -> Suitability -> m Suitability
forall a b. (a -> b) -> a -> b
$ (Maybe CStore -> ItemFull -> (Int, ItemTimers) -> Bool)
-> Suitability
SuitsSomething ((Maybe CStore -> ItemFull -> (Int, ItemTimers) -> Bool)
 -> Suitability)
-> (Maybe CStore -> ItemFull -> (Int, ItemTimers) -> Bool)
-> Suitability
forall a b. (a -> b) -> a -> b
$ \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 (Text
prompt, Suitability -> m Suitability
forall (m :: * -> *) a. Monad m => a -> m a
return Suitability
SuitsEverything)
       Either Text (CStore, [(ItemId, (Int, ItemTimers))])
ggi <-
         ActorId
-> m Suitability
-> (Actor -> ActorUI -> Skills -> ItemDialogMode -> State -> Text)
-> (Actor -> ActorUI -> Skills -> ItemDialogMode -> State -> Text)
-> [CStore]
-> Bool
-> Bool
-> m (Either Text (CStore, [(ItemId, (Int, ItemTimers))]))
forall (m :: * -> *).
MonadClientUI m =>
ActorId
-> m Suitability
-> (Actor -> ActorUI -> Skills -> ItemDialogMode -> State -> Text)
-> (Actor -> ActorUI -> Skills -> ItemDialogMode -> State -> Text)
-> [CStore]
-> Bool
-> Bool
-> m (Either Text (CStore, [(ItemId, (Int, ItemTimers))]))
getFull ActorId
leader m Suitability
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)
                 [CStore]
storesLast (Bool -> Bool
not Bool
auto) Bool
True
       case Either Text (CStore, [(ItemId, (Int, ItemTimers))])
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 :: Maybe (CStore, CStore)
slastItemMove = (CStore, CStore) -> Maybe (CStore, CStore)
forall a. a -> Maybe a
Just (CStore
fromCStore, CStore
destCStore)}
           FailOrCmd (CStore, [(ItemId, (Int, ItemTimers))])
-> m (FailOrCmd (CStore, [(ItemId, (Int, ItemTimers))]))
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 :: 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 (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CStore]
stores) ()
  Skills
actorCurAndMaxSk <- (State -> Skills) -> m Skills
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
  Actor
b <- (State -> Actor) -> m Actor
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
  DiscoveryBenefit
discoBenefit <- (StateClient -> DiscoveryBenefit) -> m DiscoveryBenefit
forall (m :: * -> *) a.
MonadClientRead m =>
(StateClient -> a) -> m a
getsClient StateClient -> DiscoveryBenefit
sdiscoBenefit
  let calmE :: Bool
calmE = Actor -> Skills -> Bool
calmEnough Actor
b Skills
actorCurAndMaxSk
      ret4 :: [(ItemId, ItemQuant)] -> Int -> m [(ItemId, Int, CStore, CStore)]
      ret4 :: [(ItemId, (Int, ItemTimers))]
-> Int -> m [(ItemId, Int, CStore, CStore)]
ret4 [] Int
_ = [(ItemId, Int, CStore, CStore)]
-> m [(ItemId, Int, CStore, CStore)]
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
              [(ItemId, Int, CStore, CStore)]
l4 <- [(ItemId, (Int, ItemTimers))]
-> Int -> m [(ItemId, Int, CStore, CStore)]
ret4 [(ItemId, (Int, ItemTimers))]
rest Int
n
              [(ItemId, Int, CStore, CStore)]
-> m [(ItemId, Int, CStore, CStore)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(ItemId, Int, CStore, CStore)]
 -> m [(ItemId, Int, CStore, CStore)])
-> [(ItemId, Int, CStore, CStore)]
-> m [(ItemId, Int, CStore, CStore)]
forall a b. (a -> b) -> a -> b
$ (ItemId
iid, Int
k, CStore
fromCStore, CStore
toCStore) (ItemId, Int, CStore, CStore)
-> [(ItemId, Int, CStore, CStore)]
-> [(ItemId, Int, CStore, CStore)]
forall a. a -> [a] -> [a]
: [(ItemId, Int, CStore, CStore)]
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 (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 (m :: * -> *) a. Monad m => a -> m a
return []
          CStore
_ -> CStore -> m [(ItemId, Int, CStore, CStore)]
retRec CStore
destCStore
  [(ItemId, Int, CStore, CStore)]
l4 <- [(ItemId, (Int, ItemTimers))]
-> Int -> m [(ItemId, Int, CStore, CStore)]
ret4 [(ItemId, (Int, ItemTimers))]
l Int
0
  if [(ItemId, Int, CStore, CStore)] -> Bool
forall a. [a] -> Bool
null [(ItemId, Int, CStore, CStore)]
l4
  then String -> m RequestTimed
forall a. (?callStack::CallStack) => String -> a
error (String -> m RequestTimed) -> String -> m RequestTimed
forall a b. (a -> b) -> a -> b
$ String
"" String
-> ([CStore], CStore, [(ItemId, (Int, ItemTimers))], CStore)
-> String
forall v. Show v => String -> v -> String
`showFailure` ([CStore]
stores, CStore
fromCStore, [(ItemId, (Int, ItemTimers))]
l, CStore
destCStore)
  else RequestTimed -> m RequestTimed
forall (m :: * -> *) a. Monad m => a -> m a
return (RequestTimed -> m RequestTimed) -> RequestTimed -> m RequestTimed
forall a b. (a -> b) -> a -> b
$! [(ItemId, Int, CStore, CStore)] -> RequestTimed
ReqMoveItems [(ItemId, Int, CStore, CStore)]
l4

-- * Project

projectHuman :: (MonadClient m, MonadClientUI m)
             => ActorId -> m (FailOrCmd RequestTimed)
projectHuman :: ActorId -> m (FailOrCmd RequestTimed)
projectHuman ActorId
leader = do
  Challenge
curChal <- (StateClient -> Challenge) -> m Challenge
forall (m :: * -> *) a.
MonadClientRead m =>
(StateClient -> a) -> m a
getsClient StateClient -> Challenge
scurChal
  Skills
actorCurAndMaxSk <- (State -> Skills) -> m Skills
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 | Challenge -> Bool
ckeeper Challenge
curChal ->
       ReqFailure -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a.
MonadClientUI m =>
ReqFailure -> m (FailOrCmd a)
failSer ReqFailure
ProjectFinderKeeper
     | Skill -> Skills -> Int
Ability.getSk Skill
Ability.SkProject Skills
actorCurAndMaxSk Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 ->
       -- Detailed are check later.
       ReqFailure -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a.
MonadClientUI m =>
ReqFailure -> m (FailOrCmd a)
failSer ReqFailure
ProjectUnskilled
     | Bool
otherwise -> do
       Maybe (ItemId, CStore, Bool)
itemSel <- (SessionUI -> Maybe (ItemId, CStore, Bool))
-> m (Maybe (ItemId, CStore, Bool))
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> Maybe (ItemId, CStore, Bool)
sitemSel
       case Maybe (ItemId, CStore, Bool)
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
           Actor
b <- (State -> Actor) -> m Actor
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
           ItemBag
bag <- (State -> ItemBag) -> m ItemBag
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 ItemId
iid ItemId -> ItemBag -> Maybe (Int, ItemTimers)
forall k a. Enum k => k -> EnumMap k a -> Maybe a
`EM.lookup` ItemBag
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
itemFull <- (State -> ItemFull) -> m ItemFull
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, (ItemId, ItemFull))
i = (CStore
fromCStore, (ItemId
iid, ItemFull
itemFull))
               ActorId
-> (CStore, (ItemId, ItemFull)) -> m (FailOrCmd RequestTimed)
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
ActorId
-> (CStore, (ItemId, ItemFull)) -> m (FailOrCmd RequestTimed)
projectItem ActorId
leader (CStore, (ItemId, ItemFull))
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 :: ActorId
-> (CStore, (ItemId, ItemFull)) -> m (FailOrCmd RequestTimed)
projectItem ActorId
leader (CStore
fromCStore, (ItemId
iid, ItemFull
itemFull)) = do
  Skills
actorCurAndMaxSk <- (State -> Skills) -> m Skills
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
  Actor
b <- (State -> Actor) -> m Actor
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 calmE :: Bool
calmE = Actor -> Skills -> Bool
calmEnough Actor
b Skills
actorCurAndMaxSk
  if CStore
fromCStore CStore -> CStore -> Bool
forall a. Eq a => a -> a -> Bool
== CStore
CEqp Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
calmE then ReqFailure -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a.
MonadClientUI m =>
ReqFailure -> m (FailOrCmd a)
failSer ReqFailure
ItemNotCalm
  else do
    Either Text (ItemFull -> Either ReqFailure (Point, Bool))
mpsuitReq <- ActorId
-> m (Either Text (ItemFull -> Either ReqFailure (Point, Bool)))
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
ActorId
-> m (Either Text (ItemFull -> Either ReqFailure (Point, Bool)))
psuitReq ActorId
leader
    case Either Text (ItemFull -> Either ReqFailure (Point, Bool))
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{Double
benFling :: Benefit -> Double
benFling :: Double
benFling} <- (StateClient -> Benefit) -> m Benefit
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
            Bool
go <- if Double
benFling Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
0
                  then ColorMode -> Text -> m Bool
forall (m :: * -> *).
MonadClientUI m =>
ColorMode -> Text -> m Bool
displayYesNo ColorMode
ColorFull
                         Text
"The item may be beneficial. Do you really want to fling it?"
                  else Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
            if Bool
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.
              Maybe Target
sxhair <- (SessionUI -> Maybe Target) -> m (Maybe Target)
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> Maybe Target
sxhair
              (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 -> Maybe Target
forall a b. a -> b -> a
const Maybe Target
sxhair)
              -- Project.
              Int
eps <- (StateClient -> Int) -> m Int
forall (m :: * -> *) a.
MonadClientRead m =>
(StateClient -> a) -> m a
getsClient StateClient -> Int
seps
              FailOrCmd RequestTimed -> m (FailOrCmd RequestTimed)
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 -> Int -> ItemId -> CStore -> RequestTimed
ReqProject Point
pos Int
eps ItemId
iid CStore
fromCStore
            else 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 :: Maybe (ItemId, CStore, Bool)
sitemSel = Maybe (ItemId, CStore, Bool)
forall a. Maybe a
Nothing}
              Text -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith Text
"never mind"

-- * Apply

applyHuman :: MonadClientUI m => ActorId -> m (FailOrCmd RequestTimed)
applyHuman :: ActorId -> m (FailOrCmd RequestTimed)
applyHuman ActorId
leader = do
  Skills
actorCurAndMaxSk <- (State -> Skills) -> m Skills
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 Skill -> Skills -> Int
Ability.getSk Skill
Ability.SkApply
                   Skills
actorCurAndMaxSk Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 then  -- detailed check later
    ReqFailure -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a.
MonadClientUI m =>
ReqFailure -> m (FailOrCmd a)
failSer ReqFailure
ApplyUnskilled
  else do
    Maybe (ItemId, CStore, Bool)
itemSel <- (SessionUI -> Maybe (ItemId, CStore, Bool))
-> m (Maybe (ItemId, CStore, Bool))
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> Maybe (ItemId, CStore, Bool)
sitemSel
    case Maybe (ItemId, CStore, Bool)
itemSel of
      Just (ItemId
iid, CStore
fromCStore, Bool
_) -> do
        Actor
b <- (State -> Actor) -> m Actor
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
        ItemBag
bag <- (State -> ItemBag) -> m ItemBag
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 ItemId
iid ItemId -> ItemBag -> Maybe (Int, ItemTimers)
forall k a. Enum k => k -> EnumMap k a -> Maybe a
`EM.lookup` ItemBag
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
itemFull <- (State -> ItemFull) -> m ItemFull
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
            ActorId
-> (CStore, (ItemId, ItemFullKit)) -> m (FailOrCmd RequestTimed)
forall (m :: * -> *).
MonadClientUI m =>
ActorId
-> (CStore, (ItemId, ItemFullKit)) -> m (FailOrCmd RequestTimed)
applyItem ActorId
leader (CStore
fromCStore, (ItemId
iid, (ItemFull
itemFull, (Int, ItemTimers)
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 :: ActorId
-> (CStore, (ItemId, ItemFullKit)) -> m (FailOrCmd RequestTimed)
applyItem ActorId
leader (CStore
fromCStore, (ItemId
iid, (ItemFull
itemFull, (Int, ItemTimers)
kit))) = do
  COps{RuleContent
corule :: COps -> RuleContent
corule :: RuleContent
corule} <- (State -> COps) -> m COps
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  Skills
actorCurAndMaxSk <- (State -> Skills) -> m Skills
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
  Actor
b <- (State -> Actor) -> m Actor
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
  Time
localTime <- (State -> Time) -> m Time
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Time) -> m Time) -> (State -> Time) -> m Time
forall a b. (a -> b) -> a -> b
$ LevelId -> State -> Time
getLocalTime (Actor -> LevelId
blid Actor
b)
  let skill :: Int
skill = Skill -> Skills -> Int
Ability.getSk Skill
Ability.SkApply Skills
actorCurAndMaxSk
      calmE :: Bool
calmE = Actor -> Skills -> Bool
calmEnough Actor
b Skills
actorCurAndMaxSk
      arItem :: AspectRecord
arItem = ItemFull -> AspectRecord
aspectRecordFull ItemFull
itemFull
  if CStore
fromCStore CStore -> CStore -> Bool
forall a. Eq a => a -> a -> Bool
== CStore
CEqp Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
calmE then ReqFailure -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a.
MonadClientUI m =>
ReqFailure -> m (FailOrCmd a)
failSer ReqFailure
ItemNotCalm
  else case 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 of
    Left ReqFailure
reqFail -> ReqFailure -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a.
MonadClientUI m =>
ReqFailure -> m (FailOrCmd a)
failSer ReqFailure
reqFail
    Right Bool
_ -> do
      Benefit{Double
benApply :: Benefit -> Double
benApply :: Double
benApply} <- (StateClient -> Benefit) -> m Benefit
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
      Bool
go <-
        if | Flag -> AspectRecord -> Bool
IA.checkFlag Flag
Ability.Periodic AspectRecord
arItem
             Bool -> Bool -> Bool
&& Bool -> Bool
not (Flag -> AspectRecord -> Bool
IA.checkFlag Flag
Ability.Durable AspectRecord
arItem) ->
             -- No warning if item durable, because activation weak,
             -- but price low, due to no destruction.
             ColorMode -> Text -> m Bool
forall (m :: * -> *).
MonadClientUI m =>
ColorMode -> Text -> m Bool
displayYesNo ColorMode
ColorFull
                          Text
"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?"
           | Double
benApply Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
0 ->
             ColorMode -> Text -> m Bool
forall (m :: * -> *).
MonadClientUI m =>
ColorMode -> Text -> m Bool
displayYesNo ColorMode
ColorFull
                          Text
"The item appears harmful. Do you really want to trigger it?"
           | Bool
otherwise -> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
      if Bool
go
      then FailOrCmd RequestTimed -> m (FailOrCmd RequestTimed)
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
$ ItemId -> CStore -> RequestTimed
ReqApply ItemId
iid CStore
fromCStore
      else 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 :: Maybe (ItemId, CStore, Bool)
sitemSel = Maybe (ItemId, CStore, Bool)
forall a. Maybe a
Nothing}
        Text -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith Text
"never mind"

-- * AlterDir

-- | Ask for a direction and alter a tile, if possible.
alterDirHuman :: MonadClientUI m => ActorId -> m (FailOrCmd RequestTimed)
alterDirHuman :: 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 (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 :: ActorId -> Point -> m (FailOrCmd RequestTimed)
alterTileAtPos ActorId
leader Point
pos = do
  Actor
sb <- (State -> Actor) -> m Actor
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 :: Maybe Target
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 `~`.
  Maybe Target -> m ()
forall (m :: * -> *). MonadClientUI m => Maybe Target -> m ()
setXHairFromGUI Maybe Target
sxhair
  ActorId -> Bool -> Point -> m (FailOrCmd RequestTimed)
forall (m :: * -> *).
MonadClientUI m =>
ActorId -> Bool -> Point -> m (FailOrCmd RequestTimed)
alterCommon ActorId
leader Bool
False Point
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 :: ActorId -> Bool -> Point -> m (FailOrCmd ())
verifyAlters ActorId
leader Bool
bumping Point
tpos = do
  COps{ContentData TileKind
cotile :: ContentData TileKind
cotile :: COps -> ContentData TileKind
cotile, TileSpeedup
coTileSpeedup :: TileSpeedup
coTileSpeedup :: COps -> TileSpeedup
coTileSpeedup} <- (State -> COps) -> m COps
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  Actor
sb <- (State -> Actor) -> m Actor
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
  AspectRecord
arItem <- (State -> AspectRecord) -> m AspectRecord
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> AspectRecord) -> m AspectRecord)
-> (State -> AspectRecord) -> m AspectRecord
forall a b. (a -> b) -> a -> b
$ ItemId -> State -> AspectRecord
aspectRecordFromIid (ItemId -> State -> AspectRecord)
-> ItemId -> State -> AspectRecord
forall a b. (a -> b) -> a -> b
$ Actor -> ItemId
btrunk Actor
sb
  ItemBag
embeds <- (State -> ItemBag) -> m ItemBag
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
$ LevelId -> Point -> State -> ItemBag
getEmbedBag (Actor -> LevelId
blid Actor
sb) Point
tpos
  Level
lvl <- LevelId -> m Level
forall (m :: * -> *). MonadStateRead m => LevelId -> m Level
getLevel (LevelId -> m Level) -> LevelId -> m Level
forall a b. (a -> b) -> a -> b
$ Actor -> LevelId
blid Actor
sb
  ItemId -> ItemKind
getKind <- (State -> ItemId -> ItemKind) -> m (ItemId -> ItemKind)
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> ItemId -> ItemKind) -> m (ItemId -> ItemKind))
-> (State -> ItemId -> ItemKind) -> m (ItemId -> ItemKind)
forall a b. (a -> b) -> a -> b
$ (ItemId -> State -> ItemKind) -> State -> ItemId -> ItemKind
forall a b c. (a -> b -> c) -> b -> a -> c
flip ItemId -> State -> ItemKind
getIidKind
  let embedKindList :: [(ItemKind, (ItemId, (Int, ItemTimers)))]
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 :: Bool
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 :: Bool
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 :: ContentId TileKind
tile = Level
lvl Level -> Point -> ContentId TileKind
`at` Point
tpos
      feats :: [Feature]
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 :: [TileAction]
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 [TileAction] -> Bool
forall a. [a] -> Bool
null [TileAction]
tileActions
     Bool -> Bool -> Bool
&& Bool
blockedByItem
     Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
underFeet
     Bool -> Bool -> Bool
&& TileSpeedup -> ContentId TileKind -> Bool
Tile.isModifiable TileSpeedup
coTileSpeedup ContentId TileKind
tile
  then ReqFailure -> m (FailOrCmd ())
forall (m :: * -> *) a.
MonadClientUI m =>
ReqFailure -> m (FailOrCmd a)
failSer ReqFailure
AlterBlockItem
  else ActorId -> Bool -> Point -> [TileAction] -> m (FailOrCmd ())
forall (m :: * -> *).
MonadClientUI m =>
ActorId -> Bool -> Point -> [TileAction] -> m (FailOrCmd ())
processTileActions ActorId
leader Bool
bumping Point
tpos [TileAction]
tileActions

processTileActions :: forall m. MonadClientUI m
                   => ActorId -> Bool -> Point -> [TileAction]
                   -> m (FailOrCmd ())
processTileActions :: ActorId -> Bool -> Point -> [TileAction] -> m (FailOrCmd ())
processTileActions ActorId
leader Bool
bumping Point
tpos [TileAction]
tas = do
  COps{TileSpeedup
coTileSpeedup :: TileSpeedup
coTileSpeedup :: COps -> TileSpeedup
coTileSpeedup} <- (State -> COps) -> m COps
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  ItemId -> ItemKind
getKind <- (State -> ItemId -> ItemKind) -> m (ItemId -> ItemKind)
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> ItemId -> ItemKind) -> m (ItemId -> ItemKind))
-> (State -> ItemId -> ItemKind) -> m (ItemId -> ItemKind)
forall a b. (a -> b) -> a -> b
$ (ItemId -> State -> ItemKind) -> State -> ItemId -> ItemKind
forall a b c. (a -> b -> c) -> b -> a -> c
flip ItemId -> State -> ItemKind
getIidKind
  Actor
sb <- (State -> Actor) -> m Actor
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
  Level
lvl <- LevelId -> m Level
forall (m :: * -> *). MonadStateRead m => LevelId -> m Level
getLevel (LevelId -> m Level) -> LevelId -> m Level
forall a b. (a -> b) -> a -> b
$ Actor -> LevelId
blid Actor
sb
  AspectRecord
sar <- (State -> AspectRecord) -> m AspectRecord
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> AspectRecord) -> m AspectRecord)
-> (State -> AspectRecord) -> m AspectRecord
forall a b. (a -> b) -> a -> b
$ ItemId -> State -> AspectRecord
aspectRecordFromIid (ItemId -> State -> AspectRecord)
-> ItemId -> State -> AspectRecord
forall a b. (a -> b) -> a -> b
$ Actor -> ItemId
btrunk Actor
sb
  let leaderIsMist :: Bool
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 :: Int
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
-> [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 (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
               FailOrCmd ()
mfail <- m (FailOrCmd ())
forall (m :: * -> *). MonadClientUI m => m (FailOrCmd ())
verifyEscape
               case FailOrCmd ()
mfail of
                 Left FailError
err -> FailOrCmd (Maybe (Bool, Bool))
-> m (FailOrCmd (Maybe (Bool, Bool)))
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 (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.
              [(ItemId, ItemFullKit)]
kitAssG <- (State -> [(ItemId, ItemFullKit)]) -> m [(ItemId, ItemFullKit)]
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]
              [(ItemId, ItemFullKit)]
kitAssE <- (State -> [(ItemId, ItemFullKit)]) -> m [(ItemId, ItemFullKit)]
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
CEqp]
              let kitAss :: [((CStore, Bool), (ItemId, ItemFullKit))]
kitAss = [(ItemId, ItemFullKit)]
-> [(ItemId, ItemFullKit)]
-> [((CStore, Bool), (ItemId, ItemFullKit))]
listToolsToConsume [(ItemId, ItemFullKit)]
kitAssG [(ItemId, ItemFullKit)]
kitAssE
                  grps0 :: [(Bool, Int, GroupName ItemKind)]
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
                  (EnumMap CStore ItemBag
_, [(CStore, (ItemId, ItemFull))]
iidsToApply, [(Bool, Int, GroupName ItemKind)]
grps) =
                    ((EnumMap CStore ItemBag, [(CStore, (ItemId, ItemFull))],
  [(Bool, Int, GroupName ItemKind)])
 -> ((CStore, Bool), (ItemId, ItemFullKit))
 -> (EnumMap CStore ItemBag, [(CStore, (ItemId, ItemFull))],
     [(Bool, Int, GroupName ItemKind)]))
-> (EnumMap CStore ItemBag, [(CStore, (ItemId, ItemFull))],
    [(Bool, Int, GroupName ItemKind)])
-> [((CStore, Bool), (ItemId, ItemFullKit))]
-> (EnumMap CStore ItemBag, [(CStore, (ItemId, ItemFull))],
    [(Bool, Int, GroupName ItemKind)])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (EnumMap CStore ItemBag, [(CStore, (ItemId, ItemFull))],
 [(Bool, Int, GroupName ItemKind)])
-> ((CStore, Bool), (ItemId, ItemFullKit))
-> (EnumMap CStore ItemBag, [(CStore, (ItemId, ItemFull))],
    [(Bool, Int, GroupName ItemKind)])
subtractIidfromGrps (EnumMap CStore ItemBag
forall k a. EnumMap k a
EM.empty, [], [(Bool, Int, GroupName ItemKind)]
grps0) [((CStore, Bool), (ItemId, ItemFullKit))]
kitAss
              if [(Bool, Int, GroupName ItemKind)] -> Bool
forall a. [a] -> Bool
null [(Bool, Int, GroupName ItemKind)]
grps then do
                let hasEffectOrDmg :: (a, (a, ItemFull)) -> Bool
hasEffectOrDmg (a
_, (a
_, ItemFull{ItemKind
itemKind :: ItemFull -> ItemKind
itemKind :: 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)
                FailOrCmd ()
mfail <- case ((CStore, (ItemId, ItemFull)) -> Bool)
-> [(CStore, (ItemId, ItemFull))] -> [(CStore, (ItemId, ItemFull))]
forall a. (a -> Bool) -> [a] -> [a]
filter (CStore, (ItemId, ItemFull)) -> Bool
forall a a. (a, (a, ItemFull)) -> Bool
hasEffectOrDmg [(CStore, (ItemId, ItemFull))]
iidsToApply of
                  [] -> FailOrCmd () -> m (FailOrCmd ())
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 FailOrCmd ()
mfail of
                  Left FailError
err -> FailOrCmd (Maybe (Bool, Bool))
-> m (FailOrCmd (Maybe (Bool, Bool)))
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 (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 Maybe Bool
-> [TileAction] -> Bool -> m (FailOrCmd (Maybe (Bool, Bool)))
processTA Maybe Bool
museResult [TileAction]
rest Bool
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
  FailOrCmd (Maybe (Bool, Bool))
mfail <- Maybe Bool
-> [TileAction] -> Bool -> m (FailOrCmd (Maybe (Bool, Bool)))
processTA Maybe Bool
forall a. Maybe a
Nothing [TileAction]
tas Bool
False
  case FailOrCmd (Maybe (Bool, Bool))
mfail of
    Left FailError
err -> FailOrCmd () -> m (FailOrCmd ())
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 (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) ()
      [(MsgClassShow, Text)]
blurb <- Point -> LevelId -> m [(MsgClassShow, Text)]
forall (m :: * -> *).
MonadClientUI m =>
Point -> LevelId -> m [(MsgClassShow, Text)]
lookAtPosition Point
tpos (Actor -> LevelId
blid Actor
sb)
      ((MsgClassShow, Text) -> m ()) -> [(MsgClassShow, Text)] -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
(a -> m ()) -> t a -> m ()
mapM_ ((MsgClassShow -> Text -> m ()) -> (MsgClassShow, Text) -> m ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry MsgClassShow -> Text -> m ()
forall (m :: * -> *) a.
(MonadClientUI m, MsgShared a) =>
a -> Text -> m ()
msgAdd) [(MsgClassShow, Text)]
blurb
      if Bool
bumpFailed then do
        HumanCmd -> KM
revCmd <- m (HumanCmd -> KM)
forall (m :: * -> *). MonadClientUI m => m (HumanCmd -> KM)
revCmdMap
        let km :: KM
km = HumanCmd -> KM
revCmd HumanCmd
AlterDir
            msg :: Text
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 Bool
useResult then do
          MError
merr <- Text -> m MError
forall (m :: * -> *). MonadClientUI m => Text -> m MError
failMsg Text
msg
          MsgClassShow -> Text -> m ()
forall (m :: * -> *) a.
(MonadClientUI m, MsgShared a) =>
a -> Text -> m ()
msgAdd MsgClassShow
MsgPromptAction (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ FailError -> Text
showFailError (FailError -> Text) -> FailError -> Text
forall a b. (a -> b) -> a -> b
$ MError -> FailError
forall a. (?callStack::CallStack) => Maybe a -> a
fromJust MError
merr
          FailOrCmd () -> m (FailOrCmd ())
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 ()  -- effect the embed activation, though
        else Text -> m (FailOrCmd ())
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith Text
msg
      else Text -> m (FailOrCmd ())
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith Text
"unable to activate nor modify at this time"
        -- related to, among others, @SfxNoItemsForTile@ on the server

verifyEscape :: MonadClientUI m => m (FailOrCmd ())
verifyEscape :: m (FailOrCmd ())
verifyEscape = do
  FactionId
side <- (StateClient -> FactionId) -> m FactionId
forall (m :: * -> *) a.
MonadClientRead m =>
(StateClient -> a) -> m a
getsClient StateClient -> FactionId
sside
  Faction
fact <- (State -> Faction) -> m Faction
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
  if Bool -> Bool
not (FactionKind -> Bool
FK.fcanEscape (FactionKind -> Bool) -> FactionKind -> Bool
forall a b. (a -> b) -> a -> b
$ Faction -> FactionKind
gkind Faction
fact)
  then Text -> m (FailOrCmd ())
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith
         Text
"This is the way out, but where would you go in this alien world?"
           -- exceptionally a full sentence, because a real question
  else do
    (ItemBag
_, Int
total) <- (State -> (ItemBag, Int)) -> m (ItemBag, Int)
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> (ItemBag, Int)) -> m (ItemBag, Int))
-> (State -> (ItemBag, Int)) -> m (ItemBag, Int)
forall a b. (a -> b) -> a -> b
$ FactionId -> State -> (ItemBag, Int)
calculateTotal FactionId
side
    Int
dungeonTotal <- (State -> Int) -> m Int
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> Int
sgold
    let prompt :: Text
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.
    Bool
go <- ColorMode -> Text -> m Bool
forall (m :: * -> *).
MonadClientUI m =>
ColorMode -> Text -> m Bool
displayYesNo ColorMode
ColorBW Text
prompt
    if Bool -> Bool
not Bool
go
    then Text -> m (FailOrCmd ())
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith Text
"here's your chance"
    else FailOrCmd () -> m (FailOrCmd ())
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 ()

verifyToolEffect :: MonadClientUI m
                 => LevelId -> CStore -> ItemFull -> m (FailOrCmd ())
verifyToolEffect :: LevelId -> CStore -> ItemFull -> m (FailOrCmd ())
verifyToolEffect LevelId
lid CStore
store ItemFull
itemFull = do
  CCUI{coscreen :: CCUI -> ScreenContent
coscreen=ScreenContent{Int
rwidth :: Int
rwidth :: ScreenContent -> Int
rwidth}} <- (SessionUI -> CCUI) -> m CCUI
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> CCUI
sccui
  FactionId
side <- (StateClient -> FactionId) -> m FactionId
forall (m :: * -> *) a.
MonadClientRead m =>
(StateClient -> a) -> m a
getsClient StateClient -> FactionId
sside
  Time
localTime <- (State -> Time) -> m Time
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Time) -> m Time) -> (State -> Time) -> m Time
forall a b. (a -> b) -> a -> b
$ LevelId -> State -> Time
getLocalTime LevelId
lid
  EnumMap FactionId Faction
factionD <- (State -> EnumMap FactionId Faction)
-> m (EnumMap FactionId Faction)
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> EnumMap FactionId Faction
sfactionD
  let (Part
name1, Part
powers) = Int
-> FactionId
-> EnumMap FactionId Faction
-> Time
-> ItemFull
-> (Int, ItemTimers)
-> (Part, Part)
partItemShort Int
rwidth FactionId
side EnumMap FactionId Faction
factionD Time
localTime
                                      ItemFull
itemFull (Int, ItemTimers)
quantSingle
      objectA :: Text
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
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 :: Text
objectThe = [Part] -> Text
makePhrase [Part
"the", Part
name1]
  Bool
go <- ColorMode -> Text -> m Bool
forall (m :: * -> *).
MonadClientUI m =>
ColorMode -> Text -> m Bool
displayYesNo ColorMode
ColorBW Text
prompt
  if Bool -> Bool
not Bool
go
  then Text -> m (FailOrCmd ())
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith (Text -> m (FailOrCmd ())) -> Text -> m (FailOrCmd ())
forall a b. (a -> b) -> a -> b
$ Text
"replace" Text -> Text -> Text
<+> Text
objectThe Text -> Text -> Text
<+> Text
"and try again"
         -- question capitalized and ended with a dot, answer neither
  else FailOrCmd () -> m (FailOrCmd ())
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 ()

-- * AlterWithPointer

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

-- * CloseDir

-- | Close nearby open tile; ask for direction, if there is more than one.
closeDirHuman :: MonadClientUI m
              => ActorId -> m (FailOrCmd RequestTimed)
closeDirHuman :: ActorId -> m (FailOrCmd RequestTimed)
closeDirHuman ActorId
leader = do
  COps{TileSpeedup
coTileSpeedup :: TileSpeedup
coTileSpeedup :: COps -> TileSpeedup
coTileSpeedup} <- (State -> COps) -> m COps
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  Actor
b <- (State -> Actor) -> m Actor
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
  Level
lvl <- LevelId -> m Level
forall (m :: * -> *). MonadStateRead m => LevelId -> m Level
getLevel (LevelId -> m Level) -> LevelId -> m Level
forall a b. (a -> b) -> a -> b
$ Actor -> LevelId
blid Actor
b
  let vPts :: [Point]
vPts = Point -> [Point]
vicinityUnsafe (Point -> [Point]) -> Point -> [Point]
forall a b. (a -> b) -> a -> b
$ Actor -> Point
bpos Actor
b
      openPts :: [Point]
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 [Point]
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 (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 :: ActorId -> Point -> m (FailOrCmd RequestTimed)
closeTileAtPos ActorId
leader Point
tpos = do
  COps{TileSpeedup
coTileSpeedup :: TileSpeedup
coTileSpeedup :: COps -> TileSpeedup
coTileSpeedup} <- (State -> COps) -> m COps
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  Skills
actorCurAndMaxSk <- (State -> Skills) -> m Skills
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
  Actor
b <- (State -> Actor) -> m Actor
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
  Bool
alterable <- (State -> Bool) -> m Bool
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
$ LevelId -> Point -> State -> Bool
tileAlterable (Actor -> LevelId
blid Actor
b) Point
tpos
  Level
lvl <- LevelId -> m Level
forall (m :: * -> *). MonadStateRead m => LevelId -> m Level
getLevel (LevelId -> m Level) -> LevelId -> m Level
forall a b. (a -> b) -> a -> b
$ Actor -> LevelId
blid Actor
b
  let alterSkill :: Int
alterSkill = Skill -> Skills -> Int
Ability.getSk Skill
Ability.SkAlter Skills
actorCurAndMaxSk
      t :: ContentId TileKind
t = Level
lvl Level -> Point -> ContentId TileKind
`at` Point
tpos
      isOpen :: Bool
isOpen = TileSpeedup -> ContentId TileKind -> Bool
Tile.isClosable TileSpeedup
coTileSpeedup ContentId TileKind
t
      isClosed :: Bool
isClosed = TileSpeedup -> ContentId TileKind -> Bool
Tile.isOpenable TileSpeedup
coTileSpeedup ContentId TileKind
t
  case (Bool
alterable, Bool
isClosed, Bool
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 (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 :: Bool -> ActorId -> Point -> Text -> m ()
msgAddDone Bool
mentionTile ActorId
leader Point
p Text
verb = do
  COps{ContentData TileKind
cotile :: ContentData TileKind
cotile :: COps -> ContentData TileKind
cotile} <- (State -> COps) -> m COps
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  Actor
b <- (State -> Actor) -> m Actor
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
  Level
lvl <- LevelId -> m Level
forall (m :: * -> *). MonadStateRead m => LevelId -> m Level
getLevel (LevelId -> m Level) -> LevelId -> m Level
forall a b. (a -> b) -> a -> b
$ Actor -> LevelId
blid Actor
b
  let tname :: Text
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 :: Text
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 :: Text
object | Bool
mentionTile = Text
"the" Text -> Text -> Text
<+> Text
s
             | Bool
otherwise = Text
""
      v :: Vector
v = Point
p Point -> Point -> Vector
`vectorToFrom` Actor -> Point
bpos Actor
b
      dir :: Text
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
  MsgClassShowAndSave -> Text -> m ()
forall (m :: * -> *) a.
(MonadClientUI m, MsgShared a) =>
a -> Text -> m ()
msgAdd MsgClassShowAndSave
MsgActionComplete (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"You" Text -> Text -> Text
<+> Text
verb Text -> Text -> Text
<+> Text
object Text -> Text -> Text
<+> Text
dir Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"."

-- | Prompts user to pick a point.
pickPoint :: MonadClientUI m => ActorId -> Text -> m (Maybe Point)
pickPoint :: ActorId -> Text -> m (Maybe Point)
pickPoint ActorId
leader Text
verb = do
  Actor
b <- (State -> Actor) -> m Actor
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{Bool
uVi :: UIOptions -> Bool
uVi :: Bool
uVi, Bool
uLeftHand :: UIOptions -> Bool
uLeftHand :: Bool
uLeftHand} <- (SessionUI -> UIOptions) -> m UIOptions
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> UIOptions
sUIOptions
  let dirKeys :: [Key]
dirKeys = Bool -> Bool -> [Key]
K.dirAllKey Bool
uVi Bool
uLeftHand
      keys :: [KM]
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
  MsgClassShow -> Text -> m ()
forall (m :: * -> *) a.
(MonadClientUI m, MsgShared a) =>
a -> Text -> m ()
msgAdd MsgClassShow
MsgPromptGeneric (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Where to" Text -> Text -> Text
<+> Text
verb Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"? [movement key] [pointer]"
  Slideshow
slides <- [KM] -> m Slideshow
forall (m :: * -> *). MonadClientUI m => [KM] -> m Slideshow
reportToSlideshow [KM
K.escKM]
  KM
km <- ColorMode -> [KM] -> Slideshow -> m KM
forall (m :: * -> *).
MonadClientUI m =>
ColorMode -> [KM] -> Slideshow -> m KM
getConfirms ColorMode
ColorFull [KM]
keys Slideshow
slides
  case KM -> Key
K.key KM
km of
    Key
K.LeftButtonRelease -> do
      PointUI
pUI <- (SessionUI -> PointUI) -> m PointUI
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> PointUI
spointer
      let p :: Point
p = PointSquare -> Point
squareToMap (PointSquare -> Point) -> PointSquare -> Point
forall a b. (a -> b) -> a -> b
$ PointUI -> PointSquare
uiToSquare PointUI
pUI
      Maybe Point -> m (Maybe Point)
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 -> Maybe Point
forall a. a -> Maybe a
Just Point
p
    Key
_ -> Maybe Point -> m (Maybe Point)
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 :: (KM -> HumanCmd -> m (Either MError ReqUI))
-> m (Either MError ReqUI)
helpHuman KM -> HumanCmd -> m (Either MError ReqUI)
cmdSemInCxtOfKM = do
  ccui :: CCUI
ccui@CCUI{InputContent
coinput :: InputContent
coinput :: CCUI -> InputContent
coinput, coscreen :: CCUI -> ScreenContent
coscreen=ScreenContent{Int
rwidth :: Int
rwidth :: ScreenContent -> Int
rwidth, Int
rheight :: Int
rheight :: ScreenContent -> Int
rheight, ([String], [[String]])
rintroScreen :: ScreenContent -> ([String], [[String]])
rintroScreen :: ([String], [[String]])
rintroScreen}}
    <- (SessionUI -> CCUI) -> m CCUI
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> CCUI
sccui
  fontSetup :: FontSetup
fontSetup@FontSetup{DisplayFont
propFont :: FontSetup -> DisplayFont
monoFont :: FontSetup -> DisplayFont
squareFont :: FontSetup -> DisplayFont
propFont :: DisplayFont
monoFont :: DisplayFont
squareFont :: DisplayFont
..} <- m FontSetup
forall (m :: * -> *). MonadClientUI m => m FontSetup
getFontSetup
  ContentId ModeKind
gameModeId <- (State -> ContentId ModeKind) -> m (ContentId ModeKind)
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> ContentId ModeKind
sgameModeId
  EnumMap DisplayFont Overlay
modeOv <- Bool -> ContentId ModeKind -> m (EnumMap DisplayFont Overlay)
forall (m :: * -> *).
MonadClientUI m =>
Bool -> ContentId ModeKind -> m (EnumMap DisplayFont Overlay)
describeMode Bool
True ContentId ModeKind
gameModeId
  Bool
curTutorial <- (SessionUI -> Bool) -> m Bool
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> Bool
scurTutorial
  Maybe Bool
overrideTut <- (SessionUI -> Maybe Bool) -> m (Maybe Bool)
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> Maybe Bool
soverrideTut
  let displayTutorialHints :: Bool
displayTutorialHints = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
curTutorial Maybe Bool
overrideTut
      modeH :: (Text, (EnumMap DisplayFont Overlay, [KYX]))
modeH = ( Text
"Press SPACE or PGDN to advance or ESC to see the map again."
              , (EnumMap DisplayFont Overlay
modeOv, []) )
      keyH :: [(Text, (EnumMap DisplayFont Overlay, [KYX]))]
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]] -> [[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]]
manualScreens = [[String]] -> [[String]] -> Int -> [[String]]
packIntoScreens (([String], [[String]]) -> [[String]]
forall a b. (a, b) -> b
snd ([String], [[String]])
rintroScreen) [] Int
0
      sideBySide :: ([AttrLine], [AttrLine]) -> [Overlay]
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])]
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 :: [EnumMap DisplayFont Overlay]
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 -> (a, (a, [a]))
addMnualHeader a
ov =
        ( a
"Showing PLAYING.md (best viewed in the browser)."
        , (a
ov, []) )
      manualH :: [(Text, (EnumMap DisplayFont Overlay, [KYX]))]
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, (EnumMap DisplayFont Overlay, [KYX]))
-> [(EnumMap DisplayFont Overlay, [KYX])]
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 :: Slideshow
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.
  KeyOrSlot
ekm <- String -> ColorMode -> Bool -> Slideshow -> [KM] -> m KeyOrSlot
forall (m :: * -> *).
MonadClientUI m =>
String -> ColorMode -> Bool -> Slideshow -> [KM] -> m KeyOrSlot
displayChoiceScreen String
"help" ColorMode
ColorFull Bool
True Slideshow
sli
                             [KM
K.spaceKM, KM
K.returnKM, KM
K.escKM]
  case KeyOrSlot
ekm of
    Left KM
km | KM
km KM -> [KM] -> 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 (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 (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 :: (KM -> HumanCmd -> m (Either MError ReqUI))
-> m (Either MError ReqUI)
hintHuman KM -> HumanCmd -> m (Either MError ReqUI)
cmdSemInCxtOfKM = do
  Bool
sreportNull <- (SessionUI -> Bool) -> m Bool
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> Bool
sreportNull
  if Bool
sreportNull then do
    m ()
forall (m :: * -> *). MonadClientUI m => m ()
promptMainKeys
    Either MError ReqUI -> m (Either MError ReqUI)
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
  else
    (KM -> HumanCmd -> m (Either MError ReqUI))
-> m (Either MError ReqUI)
forall (m :: * -> *).
MonadClientUI m =>
(KM -> HumanCmd -> m (Either MError ReqUI))
-> m (Either MError ReqUI)
helpHuman KM -> HumanCmd -> m (Either MError ReqUI)
cmdSemInCxtOfKM

-- * Dashboard

-- | Display the dashboard.
dashboardHuman :: MonadClientUI m
               => (K.KM -> HumanCmd -> m (Either MError ReqUI))
               -> m (Either MError ReqUI)
dashboardHuman :: (KM -> HumanCmd -> m (Either MError ReqUI))
-> m (Either MError ReqUI)
dashboardHuman KM -> HumanCmd -> m (Either MError ReqUI)
cmdSemInCxtOfKM = do
  CCUI{InputContent
coinput :: InputContent
coinput :: CCUI -> InputContent
coinput, coscreen :: CCUI -> ScreenContent
coscreen=ScreenContent{Int
rwidth :: Int
rwidth :: ScreenContent -> Int
rwidth, Int
rheight :: Int
rheight :: ScreenContent -> Int
rheight}} <- (SessionUI -> CCUI) -> m CCUI
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> CCUI
sccui
  fontSetup :: FontSetup
fontSetup@FontSetup{DisplayFont
propFont :: DisplayFont
monoFont :: DisplayFont
squareFont :: DisplayFont
propFont :: FontSetup -> DisplayFont
monoFont :: FontSetup -> DisplayFont
squareFont :: FontSetup -> DisplayFont
..} <- m FontSetup
forall (m :: * -> *). MonadClientUI m => m FontSetup
getFontSetup
  Bool
curTutorial <- (SessionUI -> Bool) -> m Bool
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> Bool
scurTutorial
  Maybe Bool
overrideTut <- (SessionUI -> Maybe Bool) -> m (Maybe Bool)
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> Maybe Bool
soverrideTut
  let displayTutorialHints :: Bool
displayTutorialHints = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
curTutorial Maybe Bool
overrideTut
      offsetCol2 :: Int
offsetCol2 = Int
3
      (EnumMap DisplayFont Overlay
ov0, [KYX]
kxs0) = InputContent
-> DisplayFont
-> DisplayFont
-> Int
-> (HumanCmd -> Bool)
-> Bool
-> CmdCategory
-> ([Text], [Text], [Text])
-> ([Text], [Text])
-> (EnumMap DisplayFont Overlay, [KYX])
okxsN InputContent
coinput DisplayFont
monoFont DisplayFont
propFont Int
offsetCol2 (Bool -> HumanCmd -> Bool
forall a b. a -> b -> a
const Bool
False)
                          Bool
False CmdCategory
CmdDashboard ([], [], []) ([], [])
      al1 :: AttrString
al1 = Text -> AttrString
textToAS Text
"Dashboard"
      splitHelp :: (AttrString, (EnumMap DisplayFont Overlay, [KYX]))
-> [(EnumMap DisplayFont Overlay, [KYX])]
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 :: Slideshow
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]
extraKeys = [KM
K.returnKM, KM
K.escKM]
  KeyOrSlot
ekm <- String -> ColorMode -> Bool -> Slideshow -> [KM] -> m KeyOrSlot
forall (m :: * -> *).
MonadClientUI m =>
String -> ColorMode -> Bool -> Slideshow -> [KM] -> m KeyOrSlot
displayChoiceScreen String
"dashboard" ColorMode
ColorFull Bool
False Slideshow
sli [KM]
extraKeys
  case KeyOrSlot
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 (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 :: ActorId
-> (KM -> HumanCmd -> m (Either MError ReqUI))
-> m (Either MError ReqUI)
itemMenuHuman ActorId
leader KM -> HumanCmd -> m (Either MError ReqUI)
cmdSemInCxtOfKM = do
  COps{RuleContent
corule :: RuleContent
corule :: COps -> RuleContent
corule} <- (State -> COps) -> m COps
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  Maybe (ItemId, CStore, Bool)
itemSel <- (SessionUI -> Maybe (ItemId, CStore, Bool))
-> m (Maybe (ItemId, CStore, Bool))
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> Maybe (ItemId, CStore, Bool)
sitemSel
  fontSetup :: FontSetup
fontSetup@FontSetup{DisplayFont
propFont :: DisplayFont
monoFont :: DisplayFont
squareFont :: DisplayFont
propFont :: FontSetup -> DisplayFont
monoFont :: FontSetup -> DisplayFont
squareFont :: FontSetup -> DisplayFont
..} <- m FontSetup
forall (m :: * -> *). MonadClientUI m => m FontSetup
getFontSetup
  case Maybe (ItemId, CStore, Bool)
itemSel of
    Just (ItemId
iid, CStore
fromCStore, Bool
_) -> do
      FactionId
side <- (StateClient -> FactionId) -> m FactionId
forall (m :: * -> *) a.
MonadClientRead m =>
(StateClient -> a) -> m a
getsClient StateClient -> FactionId
sside
      Actor
b <- (State -> Actor) -> m Actor
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
      ActorUI
bUI <- (SessionUI -> ActorUI) -> m ActorUI
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession ((SessionUI -> ActorUI) -> m ActorUI)
-> (SessionUI -> ActorUI) -> m ActorUI
forall a b. (a -> b) -> a -> b
$ ActorId -> SessionUI -> ActorUI
getActorUI ActorId
leader
      ItemBag
bag <- (State -> ItemBag) -> m ItemBag
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 ItemId
iid ItemId -> ItemBag -> Maybe (Int, ItemTimers)
forall k a. Enum k => k -> EnumMap k a -> Maybe a
`EM.lookup` ItemBag
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 :: CCUI -> ScreenContent
coscreen=ScreenContent{Int
rwidth :: Int
rwidth :: ScreenContent -> Int
rwidth, Int
rheight :: Int
rheight :: ScreenContent -> Int
rheight}} <- (SessionUI -> CCUI) -> m CCUI
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> CCUI
sccui
          Skills
actorCurAndMaxSk <- (State -> Skills) -> m Skills
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
          ItemFull
itemFull <- (State -> ItemFull) -> m ItemFull
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
          Time
localTime <- (State -> Time) -> m Time
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Time) -> m Time) -> (State -> Time) -> m Time
forall a b. (a -> b) -> a -> b
$ LevelId -> State -> Time
getLocalTime (Actor -> LevelId
blid Actor
b)
          [(ActorId, (Actor, CStore))]
found <- (State -> [(ActorId, (Actor, CStore))])
-> m [(ActorId, (Actor, CStore))]
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> [(ActorId, (Actor, CStore))])
 -> m [(ActorId, (Actor, CStore))])
-> (State -> [(ActorId, (Actor, CStore))])
-> m [(ActorId, (Actor, CStore))]
forall a b. (a -> b) -> a -> b
$ ActorId
-> FactionId -> ItemId -> State -> [(ActorId, (Actor, CStore))]
findIid ActorId
leader FactionId
side ItemId
iid
          let !_A :: ()
_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 a. Show a => Bool -> a -> Bool
`blame` (ItemId
iid, ActorId
leader)) ()
              fAlt :: (ActorId, (Actor, CStore)) -> Bool
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))]
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 :: Bool
markParagraphs = Int
rheight Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
45
              meleeSkill :: Int
meleeSkill = Skill -> Skills -> Int
Ability.getSk Skill
Ability.SkHurtMelee Skills
actorCurAndMaxSk
              partRawActor :: ActorId -> m Part
partRawActor ActorId
aid = (SessionUI -> Part) -> m Part
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 -> CStore -> m String
ppLoc ActorId
aid CStore
store = do
                [Part]
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)
                String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$! String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack ([Part] -> Text
makePhrase [Part]
parts) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"
              dmode :: ItemDialogMode
dmode = CStore -> ItemDialogMode
MStore CStore
fromCStore
          [String]
foundTexts <- ((ActorId, (Actor, CStore)) -> m String)
-> [(ActorId, (Actor, CStore))] -> m [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(ActorId
aid, (Actor
_, CStore
store)) -> ActorId -> CStore -> m String
forall (m :: * -> *).
MonadClientUI m =>
ActorId -> CStore -> m String
ppLoc ActorId
aid CStore
store) [(ActorId, (Actor, CStore))]
foundAlt
          (Overlay
ovLab, Overlay
ovDesc) <-
            Bool
-> Int
-> ItemDialogMode
-> ItemId
-> (Int, ItemTimers)
-> ItemFull
-> Int
-> m (Overlay, Overlay)
forall (m :: * -> *).
MonadClientUI m =>
Bool
-> Int
-> ItemDialogMode
-> ItemId
-> (Int, ItemTimers)
-> ItemFull
-> Int
-> m (Overlay, Overlay)
itemDescOverlays Bool
markParagraphs Int
meleeSkill ItemDialogMode
dmode ItemId
iid (Int, ItemTimers)
kit
                             ItemFull
itemFull Int
rwidth
          let foundPrefix :: AttrString
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 :: Overlay
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 :: Int
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 :: Int
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. [a] -> a
last Overlay
ovPrefix))
              foundKeys :: [KM]
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)]
ks = [KM] -> [String] -> [(KM, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [KM]
foundKeys [String]
foundTexts
              width :: Int
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
              (Overlay
ovFoundRaw, [KYX]
kxsFound) = DisplayFont
-> Int -> Int -> Int -> [(KM, String)] -> (Overlay, [KYX])
wrapOKX DisplayFont
monoFont Int
ystart Int
xstart Int
width [(KM, String)]
ks
              ovFound :: Overlay
ovFound = Overlay
ovPrefix Overlay -> Overlay -> Overlay
forall a. [a] -> [a] -> [a]
++ Overlay
ovFoundRaw
          Report
report <- Bool -> m Report
forall (m :: * -> *). MonadClientUI m => Bool -> m Report
getReportUI Bool
True
          CCUI{InputContent
coinput :: InputContent
coinput :: CCUI -> InputContent
coinput} <- (SessionUI -> CCUI) -> m CCUI
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> CCUI
sccui
          Maybe (LevelId, Point)
mstash <- (State -> Maybe (LevelId, Point)) -> m (Maybe (LevelId, Point))
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Maybe (LevelId, Point)) -> m (Maybe (LevelId, Point)))
-> (State -> Maybe (LevelId, Point)) -> m (Maybe (LevelId, Point))
forall a b. (a -> b) -> a -> b
$ \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
          Bool
curTutorial <- (SessionUI -> Bool) -> m Bool
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> Bool
scurTutorial
          Maybe Bool
overrideTut <- (SessionUI -> Maybe Bool) -> m (Maybe Bool)
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> Maybe Bool
soverrideTut
          let displayTutorialHints :: Bool
displayTutorialHints = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
curTutorial Maybe Bool
overrideTut
              calmE :: Bool
calmE = Actor -> Skills -> Bool
calmEnough Actor
b Skills
actorCurAndMaxSk
              greyedOut :: HumanCmd -> Bool
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
aiming :: AimModeCmd -> HumanCmd
exploration :: AimModeCmd -> HumanCmd
aiming :: HumanCmd
exploration :: 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 -> Text -> Text -> Text
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
offsetCol2 = Int
11
              keyCaption :: Text
keyCaption = Int -> Text -> Text -> Text
fmt Int
offsetCol2 Text
"keys" Text
"command"
              offset :: Int
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)
              (EnumMap DisplayFont Overlay
ov0, [KYX]
kxs0) = Int
-> Int
-> (EnumMap DisplayFont Overlay, [KYX])
-> (EnumMap DisplayFont Overlay, [KYX])
xytranslateOKX Int
0 Int
offset ((EnumMap DisplayFont Overlay, [KYX])
 -> (EnumMap DisplayFont Overlay, [KYX]))
-> (EnumMap DisplayFont Overlay, [KYX])
-> (EnumMap DisplayFont Overlay, [KYX])
forall a b. (a -> b) -> a -> b
$
                 InputContent
-> DisplayFont
-> DisplayFont
-> Int
-> (HumanCmd -> Bool)
-> Bool
-> CmdCategory
-> ([Text], [Text], [Text])
-> ([Text], [Text])
-> (EnumMap DisplayFont Overlay, [KYX])
okxsN InputContent
coinput DisplayFont
monoFont DisplayFont
propFont Int
offsetCol2 HumanCmd -> Bool
greyedOut
                       Bool
True CmdCategory
CmdItemMenu ([], [], [Text
"", Text
keyCaption]) ([], [])
              t0 :: Text
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
alRep = (AttrString -> AttrString -> AttrString)
-> AttrString -> [AttrString] -> AttrString
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
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, (EnumMap DisplayFont Overlay, [KYX]))
-> [(EnumMap DisplayFont Overlay, [KYX])]
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 :: Slideshow
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]
extraKeys = [KM
K.spaceKM, KM
K.escKM] [KM] -> [KM] -> [KM]
forall a. [a] -> [a] -> [a]
++ [KM]
foundKeys
          m ()
forall (m :: * -> *). MonadClientUI m => m ()
recordHistory  -- report shown (e.g., leader switch), save to history
          KeyOrSlot
ekm <- String -> ColorMode -> Bool -> Slideshow -> [KM] -> m KeyOrSlot
forall (m :: * -> *).
MonadClientUI m =>
String -> ColorMode -> Bool -> Slideshow -> [KM] -> m KeyOrSlot
displayChoiceScreen String
"item menu" ColorMode
ColorFull Bool
False Slideshow
sli [KM]
extraKeys
          case KeyOrSlot
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 (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. [a] -> Int -> a
!! (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
                  Faction
fact <- (State -> Faction) -> m Faction
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 :: Bool
banned = Faction -> Bool
bannedPointmanSwitchBetweenLevels Faction
fact
                  if Actor -> LevelId
blid Actor
bNew LevelId -> LevelId -> Bool
forall a. Eq a => a -> a -> Bool
/= Actor -> LevelId
blid Actor
b Bool -> Bool -> Bool
&& Bool
banned
                  then 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
<$> ReqFailure -> m (FailOrCmd ReqUI)
forall (m :: * -> *) a.
MonadClientUI m =>
ReqFailure -> m (FailOrCmd a)
failSer ReqFailure
NoChangeDunLeader
                  else do
                    -- Verbosity not necessary to notice the switch
                    -- and it's explicitly requested, so no surprise.
                    m Bool -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Bool -> m ()) -> m Bool -> m ()
forall a b. (a -> b) -> a -> b
$ Bool -> ActorId -> m Bool
forall (m :: * -> *). MonadClientUI m => Bool -> ActorId -> m Bool
pickLeader Bool
False ActorId
newAid
                    (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 :: Maybe (ItemId, CStore, Bool)
sitemSel = (ItemId, CStore, Bool) -> Maybe (ItemId, CStore, Bool)
forall a. a -> Maybe a
Just (ItemId
iid, CStore
newCStore, Bool
False)}
                    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
newAid KM -> HumanCmd -> m (Either MError ReqUI)
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 :: Maybe (ItemId, CStore, Bool)
sitemSel = (ItemId, CStore, Bool) -> Maybe (ItemId, CStore, Bool)
forall a. a -> Maybe a
Just (ItemId
iid, CStore
fromCStore, Bool
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 :: 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
  FailOrCmd ActorId
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 FailOrCmd ActorId
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 (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 :: (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{RuleContent
corule :: RuleContent
corule :: COps -> RuleContent
corule} <- (State -> COps) -> m COps
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  CCUI{ coinput :: CCUI -> InputContent
coinput=InputContent{Map HumanCmd [KM]
brevMap :: Map HumanCmd [KM]
brevMap :: InputContent -> Map HumanCmd [KM]
brevMap}
      , coscreen :: CCUI -> ScreenContent
coscreen=ScreenContent{Int
rheight :: Int
rheight :: ScreenContent -> Int
rheight, String
rwebAddress :: ScreenContent -> String
rwebAddress :: String
rwebAddress} } <- (SessionUI -> CCUI) -> m CCUI
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> CCUI
sccui
  FontSetup{DisplayFont
propFont :: DisplayFont
monoFont :: DisplayFont
squareFont :: DisplayFont
propFont :: FontSetup -> DisplayFont
monoFont :: FontSetup -> DisplayFont
squareFont :: FontSetup -> DisplayFont
..} <- m FontSetup
forall (m :: * -> *). MonadClientUI m => m FontSetup
getFontSetup
  let matchKM :: MenuSlot
-> (Text, HumanCmd, Maybe HumanCmd,
    Maybe (EnumMap DisplayFont Overlay))
-> (KeyOrSlot,
    (Text, HumanCmd, Maybe HumanCmd,
     Maybe (EnumMap DisplayFont Overlay)))
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 :: [(KeyOrSlot,
  (Text, HumanCmd, Maybe HumanCmd,
   Maybe (EnumMap DisplayFont Overlay)))]
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 :: [(KeyOrSlot, AttrString)]
bindings =  -- key bindings to display
        let attrCursor :: Attr
attrCursor = Attr
Color.defAttr {bg :: Highlight
Color.bg = Highlight
Color.HighlightNoneCursor}
            highAttr :: AttrChar -> AttrChar
highAttr AttrChar
ac = AttrChar
ac {acAttr :: Attr
Color.acAttr = Attr
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 -> (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 :: (EnumMap DisplayFont Overlay, [KYX])
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 :: String
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 :: [AttrLine]
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 :: KYX
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 :: (EnumMap DisplayFont Overlay, [KYX])
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 :: (EnumMap DisplayFont Overlay, [KYX])
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 -> EnumMap DisplayFont Overlay
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 :: m (EnumMap DisplayFont Overlay, [KYX])
returnDefaultOKS = (EnumMap DisplayFont Overlay, [KYX])
-> m (EnumMap DisplayFont Overlay, [KYX])
forall (m :: * -> *) a. Monad m => a -> m a
return (EnumMap DisplayFont Overlay -> EnumMap DisplayFont Overlay
prepareBlurb EnumMap DisplayFont Overlay
blurb, [])
      displayInRightPane :: KeyOrSlot -> m (EnumMap DisplayFont Overlay, [KYX])
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 (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]
keys = [KM
K.leftKM, KM
K.rightKM, KM
K.escKM, Char -> KM
K.mkChar Char
'@']
      loop :: m (Either MError ReqUI)
loop = do
        Either (KM, KeyOrSlot) MenuSlot
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 Either (KM, KeyOrSlot) MenuSlot
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
            Bool
success <- String -> m Bool
forall (m :: * -> *). MonadClientUI m => String -> m Bool
tryOpenBrowser String
rwebAddress
            if Bool
success
            then (KM -> HumanCmd -> m (Either MError ReqUI))
-> EnumMap DisplayFont Overlay
-> [(Text, HumanCmd, Maybe HumanCmd,
     Maybe (EnumMap DisplayFont Overlay))]
-> [String]
-> String
-> m (Either MError ReqUI)
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
            else 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
"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"
  m (Either MError ReqUI)
loop

-- | Display the main menu.
mainMenuHuman :: MonadClientUI m
              => (K.KM -> HumanCmd -> m (Either MError ReqUI))
              -> m (Either MError ReqUI)
mainMenuHuman :: (KM -> HumanCmd -> m (Either MError ReqUI))
-> m (Either MError ReqUI)
mainMenuHuman KM -> HumanCmd -> m (Either MError ReqUI)
cmdSemInCxtOfKM = do
  CCUI{coscreen :: CCUI -> ScreenContent
coscreen=ScreenContent{([String], [[String]])
rintroScreen :: ([String], [[String]])
rintroScreen :: ScreenContent -> ([String], [[String]])
rintroScreen}} <- (SessionUI -> CCUI) -> m CCUI
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> CCUI
sccui
  FontSetup{DisplayFont
propFont :: DisplayFont
propFont :: FontSetup -> DisplayFont
propFont} <- m FontSetup
forall (m :: * -> *). MonadClientUI m => m FontSetup
getFontSetup
  ModeKind
gameMode <- m ModeKind
forall (m :: * -> *). MonadStateRead m => m ModeKind
getGameMode
  Bool
curTutorial <- (SessionUI -> Bool) -> m Bool
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> Bool
scurTutorial
  Maybe Bool
overrideTut <- (SessionUI -> Maybe Bool) -> m (Maybe Bool)
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> Maybe Bool
soverrideTut
  Challenge
curChal <- (StateClient -> Challenge) -> m Challenge
forall (m :: * -> *) a.
MonadClientRead m =>
(StateClient -> a) -> m a
getsClient StateClient -> Challenge
scurChal
  let offOn :: Bool -> p
offOn Bool
b = if Bool
b then p
"on" else p
"off"
      -- Key-description-command tuples.
      kds :: [(Text, HumanCmd, Maybe a, Maybe a)]
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 :: Text
gameName = ModeKind -> Text
MK.mname ModeKind
gameMode
      displayTutorialHints :: Bool
displayTutorialHints = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
curTutorial Maybe Bool
overrideTut
      gameInfo :: [String]
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 p. IsString p => Bool -> p
offOn (Challenge -> Bool
cfish Challenge
curChal)
                   , Text
"          ready goods:" Text -> Text -> Text
<+> Bool -> Text
forall p. IsString p => Bool -> p
offOn (Challenge -> Bool
cgoods Challenge
curChal)
                   , Text
"            lone wolf:" Text -> Text -> Text
<+> Bool -> Text
forall p. IsString p => Bool -> p
offOn (Challenge -> Bool
cwolf Challenge
curChal)
                   , Text
"        finder keeper:" Text -> Text -> Text
<+> Bool -> Text
forall p. IsString p => Bool -> p
offOn (Challenge -> Bool
ckeeper Challenge
curChal)
                   , Text
"       tutorial hints:" Text -> Text -> Text
<+> Bool -> Text
forall p. IsString p => Bool -> p
offOn Bool
displayTutorialHints
                   , Text
"" ]
      glueLines :: [[a]] -> [[a]]
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 :: [String]
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 :: [AttrLine]
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 :: EnumMap DisplayFont Overlay
blurb = [(DisplayFont, [AttrLine])] -> EnumMap DisplayFont Overlay
attrLinesToFontMap [(DisplayFont
propFont, [AttrLine]
backstoryAL)]
  (KM -> HumanCmd -> m (Either MError ReqUI))
-> EnumMap DisplayFont Overlay
-> [(Text, HumanCmd, Maybe HumanCmd,
     Maybe (EnumMap DisplayFont Overlay))]
-> [String]
-> String
-> m (Either MError ReqUI)
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))]
forall a a. [(Text, HumanCmd, Maybe a, Maybe a)]
kds [String]
gameInfo String
"main"

-- * MainMenuAutoOn

-- | Display the main menu and set @swasAutomated@.
mainMenuAutoOnHuman :: MonadClientUI m
                    => (K.KM -> HumanCmd -> m (Either MError ReqUI))
                    -> m (Either MError ReqUI)
mainMenuAutoOnHuman :: (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 :: Bool
swasAutomated = Bool
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 :: (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 :: Bool
swasAutomated = Bool
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 :: (KM -> HumanCmd -> m (Either MError ReqUI))
-> m (Either MError ReqUI)
settingsMenuHuman KM -> HumanCmd -> m (Either MError ReqUI)
cmdSemInCxtOfKM = do
  CCUI{coscreen :: CCUI -> ScreenContent
coscreen=ScreenContent{Int
rwidth :: Int
rwidth :: ScreenContent -> Int
rwidth}} <- (SessionUI -> CCUI) -> m CCUI
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> CCUI
sccui
  UIOptions{Int
uMsgWrapColumn :: UIOptions -> Int
uMsgWrapColumn :: Int
uMsgWrapColumn} <- (SessionUI -> UIOptions) -> m UIOptions
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> UIOptions
sUIOptions
  FontSetup{DisplayFont
propFont :: DisplayFont
monoFont :: DisplayFont
squareFont :: DisplayFont
propFont :: FontSetup -> DisplayFont
monoFont :: FontSetup -> DisplayFont
squareFont :: FontSetup -> DisplayFont
..} <- m FontSetup
forall (m :: * -> *). MonadClientUI m => m FontSetup
getFontSetup
  Int
markSuspect <- (StateClient -> Int) -> m Int
forall (m :: * -> *) a.
MonadClientRead m =>
(StateClient -> a) -> m a
getsClient StateClient -> Int
smarkSuspect
  Int
markVision <- (SessionUI -> Int) -> m Int
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> Int
smarkVision
  Bool
markSmell <- (SessionUI -> Bool) -> m Bool
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> Bool
smarkSmell
  Bool
noAnim <- (StateClient -> Bool) -> m Bool
forall (m :: * -> *) a.
MonadClientRead m =>
(StateClient -> a) -> m a
getsClient ((StateClient -> Bool) -> m Bool)
-> (StateClient -> Bool) -> m Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (Maybe Bool -> Bool)
-> (StateClient -> Maybe Bool) -> StateClient -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClientOptions -> Maybe Bool
snoAnim (ClientOptions -> Maybe Bool)
-> (StateClient -> ClientOptions) -> StateClient -> Maybe Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateClient -> ClientOptions
soptions
  FactionId
side <- (StateClient -> FactionId) -> m FactionId
forall (m :: * -> *) a.
MonadClientRead m =>
(StateClient -> a) -> m a
getsClient StateClient -> FactionId
sside
  Doctrine
factDoctrine <- (State -> Doctrine) -> m Doctrine
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Doctrine) -> m Doctrine)
-> (State -> Doctrine) -> m Doctrine
forall a b. (a -> b) -> a -> b
$ Faction -> Doctrine
gdoctrine (Faction -> Doctrine) -> (State -> Faction) -> State -> Doctrine
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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
  Maybe Bool
overrideTut <- (SessionUI -> Maybe Bool) -> m (Maybe Bool)
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> Maybe Bool
soverrideTut
  let offOn :: Bool -> p
offOn Bool
b = if Bool
b then p
"on" else p
"off"
      offOnAll :: v -> p
offOnAll v
n = case v
n of
        v
0 -> p
"none"
        v
1 -> p
"untried"
        v
2 -> p
"all"
        v
_ -> String -> p
forall a. (?callStack::CallStack) => String -> a
error (String -> p) -> String -> p
forall a b. (a -> b) -> a -> b
$ String
"" String -> v -> String
forall v. Show v => String -> v -> String
`showFailure` v
n
      neverEver :: v -> p
neverEver v
n = case v
n of
        v
0 -> p
"never"
        v
1 -> p
"aiming"
        v
2 -> p
"always"
        v
_ -> String -> p
forall a. (?callStack::CallStack) => String -> a
error (String -> p) -> String -> p
forall a b. (a -> b) -> a -> b
$ String
"" String -> v -> String
forall v. Show v => String -> v -> String
`showFailure` v
n
      offOnUnset :: Maybe Bool -> p
offOnUnset Maybe Bool
mb = case Maybe Bool
mb of
        Maybe Bool
Nothing -> p
"pass"
        Just Bool
b -> if Bool
b then p
"force on" else p
"force off"
      tsuspect :: Text
tsuspect = Text
"@ mark suspect terrain:" Text -> Text -> Text
<+> Int -> Text
forall v p. (Eq v, Num v, IsString p, Show v) => v -> p
offOnAll Int
markSuspect
      tvisible :: Text
tvisible = Text
"@ show visible zone:" Text -> Text -> Text
<+> Int -> Text
forall v p. (Eq v, Num v, IsString p, Show v) => v -> p
neverEver Int
markVision
      tsmell :: Text
tsmell = Text
"@ display smell clues:" Text -> Text -> Text
<+> Bool -> Text
forall p. IsString p => Bool -> p
offOn Bool
markSmell
      tanim :: Text
tanim = Text
"@ play animations:" Text -> Text -> Text
<+> Bool -> Text
forall p. IsString p => Bool -> p
offOn (Bool -> Bool
not Bool
noAnim)
      tdoctrine :: Text
tdoctrine = Text
"@ squad doctrine:" Text -> Text -> Text
<+> Doctrine -> Text
Ability.nameDoctrine Doctrine
factDoctrine
      toverride :: Text
toverride = Text
"@ override tutorial hints:" Text -> Text -> Text
<+> Maybe Bool -> Text
forall p. IsString p => Maybe Bool -> p
offOnUnset Maybe Bool
overrideTut
      width :: Int
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 -> Maybe (EnumMap DisplayFont Overlay)
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, HumanCmd, Maybe HumanCmd,
  Maybe (EnumMap DisplayFont Overlay))]
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 :: [String]
gameInfo = (Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
T.unpack
                   [ Text
"Tweak convenience settings:"
                   , Text
"" ]
  (KM -> HumanCmd -> m (Either MError ReqUI))
-> EnumMap DisplayFont Overlay
-> [(Text, HumanCmd, Maybe HumanCmd,
     Maybe (EnumMap DisplayFont Overlay))]
-> [String]
-> String
-> m (Either MError ReqUI)
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
forall k a. EnumMap k a
EM.empty [(Text, HumanCmd, Maybe HumanCmd,
  Maybe (EnumMap DisplayFont Overlay))]
kds [String]
gameInfo String
"settings"

-- * ChallengeMenu

-- | Display the challenge menu.
challengeMenuHuman :: MonadClientUI m
                   => (K.KM -> HumanCmd -> m (Either MError ReqUI))
                   -> m (Either MError ReqUI)
challengeMenuHuman :: (KM -> HumanCmd -> m (Either MError ReqUI))
-> m (Either MError ReqUI)
challengeMenuHuman KM -> HumanCmd -> m (Either MError ReqUI)
cmdSemInCxtOfKM = do
  COps
cops <- (State -> COps) -> m COps
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  CCUI{coscreen :: CCUI -> ScreenContent
coscreen=ScreenContent{Int
rwidth :: Int
rwidth :: ScreenContent -> Int
rwidth}} <- (SessionUI -> CCUI) -> m CCUI
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> CCUI
sccui
  UIOptions{Int
uMsgWrapColumn :: Int
uMsgWrapColumn :: UIOptions -> Int
uMsgWrapColumn} <- (SessionUI -> UIOptions) -> m UIOptions
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> UIOptions
sUIOptions
  FontSetup{DisplayFont
propFont :: DisplayFont
monoFont :: DisplayFont
squareFont :: DisplayFont
propFont :: FontSetup -> DisplayFont
monoFont :: FontSetup -> DisplayFont
squareFont :: FontSetup -> DisplayFont
..} <- m FontSetup
forall (m :: * -> *). MonadClientUI m => m FontSetup
getFontSetup
  EnumMap (ContentId ModeKind) (Map Challenge Int)
svictories <- (SessionUI -> EnumMap (ContentId ModeKind) (Map Challenge Int))
-> m (EnumMap (ContentId ModeKind) (Map Challenge Int))
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> EnumMap (ContentId ModeKind) (Map Challenge Int)
svictories
  Int
snxtScenario <- (SessionUI -> Int) -> m Int
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> Int
snxtScenario
  Challenge
nxtChal <- (StateClient -> Challenge) -> m Challenge
forall (m :: * -> *) a.
MonadClientRead m =>
(StateClient -> a) -> m a
getsClient StateClient -> Challenge
snxtChal
  let (ContentId ModeKind
gameModeId, ModeKind
gameMode) = COps -> Int -> (ContentId ModeKind, ModeKind)
nxtGameMode COps
cops Int
snxtScenario
      victories :: Int
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 -> Text
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
tnextScenario = Text
"@ adventure:" Text -> Text -> Text
<+> Text -> Text
star (ModeKind -> Text
MK.mname ModeKind
gameMode)
      offOn :: Bool -> p
offOn Bool
b = if Bool
b then p
"on" else p
"off"
      tnextDiff :: Text
tnextDiff = Text
"@ difficulty level:" Text -> Text -> Text
<+> Int -> Text
forall a. Show a => a -> Text
tshow (Challenge -> Int
cdiff Challenge
nxtChal)
      tnextFish :: Text
tnextFish = Text
"@ cold fish (rather hard):" Text -> Text -> Text
<+> Bool -> Text
forall p. IsString p => Bool -> p
offOn (Challenge -> Bool
cfish Challenge
nxtChal)
      tnextGoods :: Text
tnextGoods = Text
"@ ready goods (hard):" Text -> Text -> Text
<+> Bool -> Text
forall p. IsString p => Bool -> p
offOn (Challenge -> Bool
cgoods Challenge
nxtChal)
      tnextWolf :: Text
tnextWolf = Text
"@ lone wolf (very hard):" Text -> Text -> Text
<+> Bool -> Text
forall p. IsString p => Bool -> p
offOn (Challenge -> Bool
cwolf Challenge
nxtChal)
      tnextKeeper :: Text
tnextKeeper = Text
"@ finder keeper (hard):" Text -> Text -> Text
<+> Bool -> Text
forall p. IsString p => Bool -> p
offOn (Challenge -> Bool
ckeeper Challenge
nxtChal)
      width :: Int
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 :: Int
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 -> Text
duplicateEOL Char
'\n' = Text
"\n\n"
      duplicateEOL Char
c = Char -> Text
T.singleton Char
c
      blurb :: Maybe (EnumMap DisplayFont Overlay)
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 -> Maybe (EnumMap DisplayFont Overlay)
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, HumanCmd, Maybe HumanCmd,
  Maybe (EnumMap DisplayFont Overlay))]
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 :: [String]
gameInfo = (Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
T.unpack [ Text
"Setup and start new game:"
                              , Text
"" ]
  (KM -> HumanCmd -> m (Either MError ReqUI))
-> EnumMap DisplayFont Overlay
-> [(Text, HumanCmd, Maybe HumanCmd,
     Maybe (EnumMap DisplayFont Overlay))]
-> [String]
-> String
-> m (Either MError ReqUI)
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
forall k a. EnumMap k a
EM.empty [(Text, HumanCmd, Maybe HumanCmd,
  Maybe (EnumMap DisplayFont Overlay))]
kds [String]
gameInfo String
"challenge"

-- * GameDifficultyIncr

gameDifficultyIncr :: MonadClient m => Int -> m ()
gameDifficultyIncr :: Int -> m ()
gameDifficultyIncr Int
delta = do
  Int
nxtDiff <- (StateClient -> Int) -> m Int
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
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
  (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 :: Challenge
snxtChal = (StateClient -> Challenge
snxtChal StateClient
cli) {cdiff :: Int
cdiff = Int
d} }

-- * GameFishToggle

gameFishToggle :: MonadClient m => m ()
gameFishToggle :: 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 :: Challenge
snxtChal = (StateClient -> Challenge
snxtChal StateClient
cli) {cfish :: Bool
cfish = Bool -> Bool
not (Challenge -> Bool
cfish (StateClient -> Challenge
snxtChal StateClient
cli))} }

-- * GameGoodsToggle

gameGoodsToggle :: MonadClient m => m ()
gameGoodsToggle :: 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 :: Challenge
snxtChal = (StateClient -> Challenge
snxtChal StateClient
cli) {cgoods :: Bool
cgoods = Bool -> Bool
not (Challenge -> Bool
cgoods (StateClient -> Challenge
snxtChal StateClient
cli))} }

-- * GameWolfToggle

gameWolfToggle :: MonadClient m => m ()
gameWolfToggle :: 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 :: Challenge
snxtChal = (StateClient -> Challenge
snxtChal StateClient
cli) {cwolf :: Bool
cwolf = Bool -> Bool
not (Challenge -> Bool
cwolf (StateClient -> Challenge
snxtChal StateClient
cli))} }

-- * GameKeeperToggle

gameKeeperToggle :: MonadClient m => m ()
gameKeeperToggle :: 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 :: Challenge
snxtChal = (StateClient -> Challenge
snxtChal StateClient
cli) {ckeeper :: Bool
ckeeper = Bool -> Bool
not (Challenge -> Bool
ckeeper (StateClient -> Challenge
snxtChal StateClient
cli))} }

-- * GameScenarioIncr

gameScenarioIncr :: MonadClientUI m => Int -> m ()
gameScenarioIncr :: Int -> m ()
gameScenarioIncr Int
delta = do
  COps
cops <- (State -> COps) -> m COps
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  Int
oldScenario <- (SessionUI -> Int) -> m Int
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> Int
snxtScenario
  let snxtScenario :: Int
snxtScenario = Int
oldScenario Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
delta
      snxtTutorial :: Bool
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
  (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 {Int
snxtScenario :: Int
snxtScenario :: Int
snxtScenario, Bool
snxtTutorial :: Bool
snxtTutorial :: Bool
snxtTutorial}

-- * GameRestart & GameQuit

data ExitStrategy = Restart | Quit

gameExitWithHuman :: MonadClientUI m => ExitStrategy -> m (FailOrCmd ReqUI)
gameExitWithHuman :: ExitStrategy -> m (FailOrCmd ReqUI)
gameExitWithHuman ExitStrategy
exitStrategy = do
  Challenge
snxtChal       <- (StateClient -> Challenge) -> m Challenge
forall (m :: * -> *) a.
MonadClientRead m =>
(StateClient -> a) -> m a
getsClient StateClient -> Challenge
snxtChal
  COps
cops           <- (State -> COps) -> m COps
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> COps
scops
  Bool
noConfirmsGame <- m Bool
forall (m :: * -> *). MonadStateRead m => m Bool
isNoConfirmsGame
  ModeKind
gameMode       <- m ModeKind
forall (m :: * -> *). MonadStateRead m => m ModeKind
getGameMode
  Int
snxtScenario   <- (SessionUI -> Int) -> m Int
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> Int
snxtScenario
  let nxtGameName :: Text
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 -> m (FailOrCmd ReqUI)
exitReturn GroupName ModeKind
x = FailOrCmd ReqUI -> m (FailOrCmd ReqUI)
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 -> m Bool
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?"
  m Bool
-> m (FailOrCmd ReqUI)
-> m (FailOrCmd ReqUI)
-> m (FailOrCmd ReqUI)
forall (m :: * -> *) b. Monad m => m Bool -> m b -> m b -> m b
ifM (Bool -> m Bool -> m Bool -> m Bool
forall p. Bool -> p -> p -> p
if' Bool
noConfirmsGame
           (Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True)  -- true case
           (Text -> m Bool
displayExitMessage (Text -> m Bool) -> Text -> m Bool
forall a b. (a -> b) -> a -> b
$ case ExitStrategy
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 "))
      (GroupName ModeKind -> m (FailOrCmd ReqUI)
exitReturn (GroupName ModeKind -> m (FailOrCmd ReqUI))
-> GroupName ModeKind -> m (FailOrCmd ReqUI)
forall a b. (a -> b) -> a -> b
$ case ExitStrategy
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)
      (Rnd Text -> m Text
forall (m :: * -> *) a. MonadClientUI m => Rnd a -> m a
rndToActionUI ([Text] -> Rnd Text
forall a. [a] -> Rnd a
oneOf  -- ifM false case
                        [ Text
"yea, would be a pity to leave them to die"
                        , Text
"yea, a shame to get your team stranded" ])
       m Text -> (Text -> m (FailOrCmd ReqUI)) -> m (FailOrCmd ReqUI)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> m (FailOrCmd ReqUI)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith)

ifM :: Monad m => m Bool -> m b -> m b -> m b
ifM :: m Bool -> m b -> m b -> m b
ifM m Bool
b m b
t m b
f = do Bool
b' <- m Bool
b; if Bool
b' then m b
t else m b
f

if' :: Bool -> p -> p -> p
if' :: 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 :: 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 :: Int
sallNframes = -Int
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 (m :: * -> *) a. Monad m => a -> m a
return ReqUI
ReqUIGameDropAndExit

-- * GameExit

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

-- * GameSave

gameSaveHuman :: MonadClientUI m => m ReqUI
gameSaveHuman :: 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 (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 :: m (FailOrCmd ReqUI)
doctrineHuman = do
  FactionId
fid <- (StateClient -> FactionId) -> m FactionId
forall (m :: * -> *) a.
MonadClientRead m =>
(StateClient -> a) -> m a
getsClient StateClient -> FactionId
sside
  Doctrine
fromT <- (State -> Doctrine) -> m Doctrine
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Doctrine) -> m Doctrine)
-> (State -> Doctrine) -> m Doctrine
forall a b. (a -> b) -> a -> b
$ Faction -> Doctrine
gdoctrine (Faction -> Doctrine) -> (State -> Faction) -> State -> Doctrine
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EnumMap FactionId Faction -> FactionId -> Faction
forall k a. Enum k => EnumMap k a -> k -> a
EM.! FactionId
fid) (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 toT :: Doctrine
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
  Bool
go <- ColorMode -> Text -> m Bool
forall (m :: * -> *).
MonadClientUI m =>
ColorMode -> Text -> m Bool
displaySpaceEsc ColorMode
ColorFull
        (Text -> m Bool) -> Text -> m Bool
forall a b. (a -> b) -> a -> b
$ Text
"(Beware, work in progress!)"
          Text -> Text -> Text
<+> Text
"Current squad doctrine is '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Doctrine -> Text
Ability.nameDoctrine Doctrine
fromT Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'"
          Text -> Text -> Text
<+> Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Doctrine -> Text
Ability.describeDoctrine Doctrine
fromT Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")."
          Text -> Text -> Text
<+> Text
"Switching doctrine to '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Doctrine -> Text
Ability.nameDoctrine Doctrine
toT Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'"
          Text -> Text -> Text
<+> Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Doctrine -> Text
Ability.describeDoctrine Doctrine
toT Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")."
          Text -> Text -> Text
<+> Text
"This clears targets of all non-pointmen teammates."
          Text -> Text -> Text
<+> Text
"New targets will be picked according to new doctrine."
  if Bool -> Bool
not Bool
go
  then Text -> m (FailOrCmd ReqUI)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith Text
"squad doctrine change canceled"
  else FailOrCmd ReqUI -> m (FailOrCmd ReqUI)
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
$ Doctrine -> ReqUI
ReqUIDoctrine Doctrine
toT

-- * Automate

automateHuman :: MonadClientUI m => m (FailOrCmd ReqUI)
automateHuman :: m (FailOrCmd ReqUI)
automateHuman = do
  m ()
forall (m :: * -> *). MonadClientUI m => m ()
clearAimMode
  Bool
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 Bool -> Bool
not Bool
proceed
  then Text -> m (FailOrCmd ReqUI)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith Text
"automation canceled"
  else FailOrCmd ReqUI -> m (FailOrCmd ReqUI)
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
ReqUIAutomate

-- * AutomateToggle

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

-- * AutomateBack

automateBackHuman :: MonadClientUI m => m (Either MError ReqUI)
automateBackHuman :: m (Either MError ReqUI)
automateBackHuman = do
  Bool
swasAutomated <- (SessionUI -> Bool) -> m Bool
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> Bool
swasAutomated
  Either MError ReqUI -> m (Either MError ReqUI)
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
$! if Bool
swasAutomated
            then ReqUI -> Either MError ReqUI
forall a b. b -> Either a b
Right ReqUI
ReqUIAutomate
            else MError -> Either MError ReqUI
forall a b. a -> Either a b
Left MError
forall a. Maybe a
Nothing