{-# LANGUAGE TupleSections #-}
-- | 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
  , gameTutorialToggle, gameDifficultyIncr
  , gameFishToggle, gameGoodsToggle, gameWolfToggle, gameKeeperToggle
  , gameScenarioIncr
    -- * Global commands that never take time
  , gameRestartHuman, gameQuitHuman, 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 (isLeft)
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           Game.LambdaHack.Client.UI.ItemSlot (SlotChar (SlotChar))
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.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

-- * ByArea

-- | Pick command depending on area the mouse pointer is in.
-- The first matching area is chosen. If none match, only interrupt.
byAreaHuman :: (MonadClient m, 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 cmdSemInCxtOfKM :: KM -> HumanCmd -> m (Either MError ReqUI)
cmdSemInCxtOfKM l :: [(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 px :: Int
px py :: Int
py = PointUI -> PointSquare
uiToSquare PointUI
pUI
      p :: Point
p = $WPoint :: Int -> Int -> Point
Point {..}  -- abuse of convention: @Point@, not @PointSquare@ used
                      -- for the whole UI screen in square font coordinates
      pointerInArea :: CmdArea -> m Bool
pointerInArea a :: 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 (Point -> Area -> 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 :: * -> *). (MonadClient 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
    (_, cmd :: HumanCmd
cmd) : _ -> 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
            _ -> 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 ca :: 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
  CaMessage -> [(Int, Int, Int, Int)] -> m [(Int, Int, Int, Int)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(0, 0, Int
rwidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1, 0)]
  CaMapLeader -> do  -- takes preference over @CaMapParty@ and @CaMap@
    ActorId
leader <- m ActorId
forall (m :: * -> *). MonadClientUI m => m ActorId
getLeaderUI
    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 x :: Int
x y :: 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)]
  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 p :: Point
p =
          let PointSquare x :: Int
x y :: 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
  CaMap ->
    let PointSquare xo :: Int
xo yo :: Int
yo = Point -> PointSquare
mapToSquare Point
originPoint
        PointSquare xe :: Int
xe ye :: 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
- 1) (Int
rheight Int -> Int -> Int
forall a. Num a => a -> a -> a
- 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)]
  CaLevelNumber -> let y :: Int
y = Int
rheight Int -> Int -> Int
forall a. Num a => a -> a -> a
- 2
                   in [(Int, Int, Int, Int)] -> m [(Int, Int, Int, Int)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(0, Int
y, 1, Int
y)]
  CaArenaName -> let y :: Int
y = Int
rheight Int -> Int -> Int
forall a. Num a => a -> a -> a
- 2
                     x :: Int
x = (Int
rwidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- 11
                 in [(Int, Int, Int, Int)] -> m [(Int, Int, Int, Int)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(3, Int
y, Int
x, Int
y)]
  CaPercentSeen -> let y :: Int
y = Int
rheight Int -> Int -> Int
forall a. Num a => a -> a -> a
- 2
                       x :: Int
x = (Int
rwidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 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
- 9, Int
y, Int
x, Int
y)]
  CaXhairDesc -> let y :: Int
y = Int
rheight Int -> Int -> Int
forall a. Num a => a -> a -> a
- 2
                     x :: Int
x = (Int
rwidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 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
- 1, Int
y)]
  CaSelected -> let y :: Int
y = Int
rheight Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1
                    x :: Int
x = (Int
rwidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 2
                in [(Int, Int, Int, Int)] -> m [(Int, Int, Int, Int)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(0, Int
y, Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- 24, Int
y)]
  CaCalmGauge -> let y :: Int
y = Int
rheight Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1
                     x :: Int
x = (Int
rwidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 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
- 22, Int
y, Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- 18, Int
y)]
  CaCalmValue -> let y :: Int
y = Int
rheight Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1
                     x :: Int
x = (Int
rwidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 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
- 17, Int
y, Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- 11, Int
y)]
  CaHPGauge -> let y :: Int
y = Int
rheight Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1
                   x :: Int
x = (Int
rwidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 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
- 9, Int
y, Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- 6, Int
y)]
  CaHPValue -> let y :: Int
y = Int
rheight Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1
                   x :: Int
x = (Int
rwidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 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
- 6, Int
y, Int
x, Int
y)]
  CaLeaderDesc -> let y :: Int
y = Int
rheight Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1
                      x :: Int
x = (Int
rwidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 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
- 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 cmdNotAimingM :: m (Either MError ReqUI)
cmdNotAimingM cmdAimingM :: 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 c1 :: m (Either MError ReqUI)
c1 c2 :: m (Either MError ReqUI)
c2 = do
  Either MError ReqUI
slideOrCmd1 <- m (Either MError ReqUI)
c1
  case Either MError ReqUI
slideOrCmd1 of
    Left merr1 :: MError
merr1 -> do
      Either MError ReqUI
slideOrCmd2 <- m (Either MError ReqUI)
c2
      case Either MError ReqUI
slideOrCmd2 of
        Left merr2 :: 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 -> m (Either MError ReqUI)
forall (m :: * -> *) a. Monad m => a -> m a
return Either MError ReqUI
slideOrCmd2
    _ -> 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 c1 :: m (Either MError ReqUI)
c1 c2 :: m (Either MError ReqUI)
c2 = do
  Either MError ReqUI
slideOrCmd1 <- m (Either MError ReqUI)
c1
  case Either MError ReqUI
slideOrCmd1 of
    Left Nothing -> m (Either MError ReqUI)
c2
    _ -> 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 c1 :: m (Either MError ReqUI)
c1 c2 :: m (Either MError ReqUI)
c2 = do
  Either MError ReqUI
slideOrCmd1 <- m (Either MError ReqUI)
c1
  case Either MError ReqUI
slideOrCmd1 of
    Left merr1 :: MError
merr1 -> do
      Either MError ReqUI
slideOrCmd2 <- m (Either MError ReqUI)
c2
      case Either MError ReqUI
slideOrCmd2 of
        Left merr2 :: 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 -> m (Either MError ReqUI)
forall (m :: * -> *) a. Monad m => a -> m a
return Either MError ReqUI
slideOrCmd1  -- ignore second request, keep effect
    req :: 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 cmd :: m (Either MError ReqUI)
cmd = do
  Either MError ReqUI
res <- m (Either MError ReqUI)
cmd
  case Either MError ReqUI
res of
    Left 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 -> 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 c1 :: 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
  if Bool
sreportNull 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 => m (FailOrCmd RequestTimed)
waitHuman :: m (FailOrCmd RequestTimed)
waitHuman = do
  Skills
actorCurAndMaxSk <- m Skills
forall (m :: * -> *). MonadClientUI m => m Skills
leaderSkillsClientUI
  if Skill -> Skills -> Int
Ability.getSk Skill
Ability.SkWait Skills
actorCurAndMaxSk Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 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
$ \sess :: 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
+ 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 => m (FailOrCmd RequestTimed)
waitHuman10 :: m (FailOrCmd RequestTimed)
waitHuman10 = do
  Skills
actorCurAndMaxSk <- m Skills
forall (m :: * -> *). MonadClientUI m => m Skills
leaderSkillsClientUI
  if Skill -> Skills -> Int
Ability.getSk Skill
Ability.SkWait Skills
actorCurAndMaxSk Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 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
$ \sess :: 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
+ 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 => m (FailOrCmd RequestTimed)
yellHuman :: m (FailOrCmd RequestTimed)
yellHuman = do
  Skills
actorCurAndMaxSk <- m Skills
forall (m :: * -> *). MonadClientUI m => m Skills
leaderSkillsClientUI
  if Skill -> Skills -> Int
Ability.getSk Skill
Ability.SkWait Skills
actorCurAndMaxSk Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 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
<= 0
     Bool -> Bool -> Bool
|| Skill -> Skills -> Int
Ability.getSk Skill
Ability.SkDisplace Skills
actorCurAndMaxSk Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 0
     Bool -> Bool -> Bool
|| Skill -> Skills -> Int
Ability.getSk Skill
Ability.SkMelee Skills
actorCurAndMaxSk Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 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)
             => Bool -> Bool -> Bool -> Bool -> Vector
             -> m (FailOrCmd RequestTimed)
moveRunHuman :: Bool
-> Bool -> Bool -> Bool -> Vector -> m (FailOrCmd RequestTimed)
moveRunHuman initialStep :: Bool
initialStep finalGoal :: Bool
finalGoal run :: Bool
run runAhead :: Bool
runAhead dir :: Vector
dir = do
  ActorId
leader <- m ActorId
forall (m :: * -> *). MonadClientUI m => m ActorId
getLeaderUI
  Skills
actorCurAndMaxSk <- m Skills
forall (m :: * -> *). MonadClientUI m => m Skills
leaderSkillsClientUI
  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 = $WRunParams :: 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 = 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
$ \sess :: 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 :: * -> *).
(MonadClient 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 <- Bool -> Vector -> m (FailOrCmd RequestTimed)
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
Bool -> Vector -> m (FailOrCmd RequestTimed)
moveSearchAlter Bool
run Vector
dir
      case FailOrCmd RequestTimed
runStopOrCmd of
        Left stopMsg :: 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 runCmd :: 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
    [(target :: ActorId
target, _)] | 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
> 0 ->
      -- No @stopPlayBack@: initial displace is benign enough.
      -- Displacing requires accessibility, but it's checked later on.
      ActorId -> m (FailOrCmd RequestTimed)
forall (m :: * -> *).
MonadClientUI m =>
ActorId -> m (FailOrCmd RequestTimed)
displaceAid ActorId
target
    _ : _ : _ | 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
> 0 ->
      ReqFailure -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a.
MonadClientUI m =>
ReqFailure -> m (FailOrCmd a)
failSer ReqFailure
DisplaceMultiple
    (target :: ActorId
target, tb :: Actor
tb) : _ | 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 :: * -> *). (MonadClient 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 :: * -> *).
(MonadClient 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` "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 "the pointman switched by bumping"
    (target :: ActorId
target, tb :: Actor
tb) : _ | 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 :: * -> *). (MonadClient 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
> 0
      then -- No problem if there are many projectiles at the spot. We just
           -- attack the first one.
           ActorId -> m (FailOrCmd RequestTimed)
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
ActorId -> m (FailOrCmd RequestTimed)
meleeAid ActorId
target
      else ReqFailure -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a.
MonadClientUI m =>
ReqFailure -> m (FailOrCmd a)
failSer ReqFailure
MeleeUnskilled
    _ : _ -> Text -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith "actor in the way"

-- | Actor attacks an enemy actor or his own projectile.
meleeAid :: (MonadClient m, MonadClientUI m)
         => ActorId -> m (FailOrCmd RequestTimed)
meleeAid :: ActorId -> m (FailOrCmd RequestTimed)
meleeAid target :: ActorId
target = do
  ActorId
leader <- m ActorId
forall (m :: * -> *). MonadClientUI m => m ActorId
getLeaderUI
  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
    Nothing -> Text -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith "nothing to melee with"
    Just wp :: 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
$ \sess :: 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 :: * -> *).
(MonadClient m, MonadClientUI m) =>
ColorMode -> Text -> m Bool
displayYesNo ColorMode
ColorBW
                         "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 "attack canceled" else m (FailOrCmd RequestTimed)
returnCmd
              | Bool
otherwise = do
                Bool
go2 <- ColorMode -> Text -> m Bool
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
ColorMode -> Text -> m Bool
displayYesNo ColorMode
ColorBW
                         "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 "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 -> m (FailOrCmd RequestTimed)
displaceAid :: ActorId -> m (FailOrCmd RequestTimed)
displaceAid target :: 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
  ActorId
leader <- m ActorId
forall (m :: * -> *). MonadClientUI m => m ActorId
getLeaderUI
  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
<= 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 -> (ActorId, Actor, ActorId, Actor) -> String
forall v. Show v => String -> v -> String
`showFailure` (ActorId
leader, Actor
sb, ActorId
target, Actor
tb)
           [_] -> 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
           _ -> 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 :: (MonadClient m, MonadClientUI m)
                => Bool -> Vector -> m (FailOrCmd RequestTimed)
moveSearchAlter :: Bool -> Vector -> m (FailOrCmd RequestTimed)
moveSearchAlter run :: Bool
run dir :: 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
  ActorId
leader <- m ActorId
forall (m :: * -> *). MonadClientUI m => m ActorId
getLeaderUI
  Skills
actorCurAndMaxSk <- m Skills
forall (m :: * -> *). MonadClientUI m => m Skills
leaderSkillsClientUI
  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
> 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 <- LevelId -> Point -> m [(MsgClassShow, Text)]
forall (m :: * -> *).
MonadClientUI m =>
LevelId -> Point -> m [(MsgClassShow, Text)]
lookAtPosition (Actor -> LevelId
blid Actor
sb) Point
tpos
        ((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.
(MonadClient m, 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
$ "the terrain is" Text -> Text -> Text
<+>
          if | TileSpeedup -> ContentId TileKind -> Bool
Tile.isModifiable TileSpeedup
coTileSpeedup ContentId TileKind
t -> "potentially modifiable"
             | Bool
alterable -> "potentially triggerable"
             | Bool
otherwise -> "completely inert"
      else Bool -> Point -> m (FailOrCmd RequestTimed)
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
Bool -> Point -> m (FailOrCmd RequestTimed)
alterCommon 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 :: (MonadClient m, MonadClientUI m)
            => Bool -> Point -> m (FailOrCmd RequestTimed)
alterCommon :: Bool -> Point -> m (FailOrCmd RequestTimed)
alterCommon bumping :: Bool
bumping tpos :: 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
  ActorId
leader <- m ActorId
forall (m :: * -> *). MonadClientUI m => m ActorId
getLeaderUI
  Skills
actorCurAndMaxSk <- m Skills
forall (m :: * -> *). MonadClientUI m => m Skills
leaderSkillsClientUI
  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.
(MonadClient m, MonadClientUI m, MsgShared a) =>
a -> Text -> m ()
msgAdd MsgClassShowAndSave
MsgTutorialHint "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 (iid :: ItemId
iid, kit :: (Int, ItemTimers)
kit@(k :: Int
k, _)) =
               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 (\(iid :: ItemId
iid, kit :: (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
$
           ["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 ["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
<= 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 <- LevelId -> Point -> m [(MsgClassShow, Text)]
forall (m :: * -> *).
MonadClientUI m =>
LevelId -> Point -> m [(MsgClassShow, Text)]
lookAtPosition (Actor -> LevelId
blid Actor
sb) Point
tpos
         ((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.
(MonadClient m, 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
> 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 <- Bool -> ActorId -> Point -> m (FailOrCmd ())
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
Bool -> ActorId -> Point -> m (FailOrCmd ())
verifyAlters Bool
bumping ActorId
leader 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
               Point -> Text -> m ()
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
Point -> Text -> m ()
msgAddDone Point
tpos "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 err :: 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 :: (MonadClient m, MonadClientUI m)
                  => m (Either MError RequestTimed)
runOnceAheadHuman :: m (Either MError RequestTimed)
runOnceAheadHuman = 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
  ActorId
leader <- m ActorId
forall (m :: * -> *). MonadClientUI m => m ActorId
getLeaderUI
  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
    Nothing -> do
      MsgClassIgnore -> Text -> m ()
forall (m :: * -> *) a.
(MonadClient m, MonadClientUI m, MsgShared a) =>
a -> Text -> m ()
msgAdd MsgClassIgnore
MsgRunStopReason "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.
(MonadClient m, MonadClientUI m, MsgShared a) =>
a -> Text -> m ()
msgAdd MsgClassIgnore
MsgRunStopReason "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
_runParams | Bool
keyPressed -> do
      m ()
forall (m :: * -> *). MonadClientUI m => m ()
discardPressedKey
      MsgClassIgnore -> Text -> m ()
forall (m :: * -> *) a.
(MonadClient m, MonadClientUI m, MsgShared a) =>
a -> Text -> m ()
msgAdd MsgClassIgnore
MsgRunStopReason "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 "interrupted"
    Just runParams :: 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 stopMsg :: Text
stopMsg -> do
          MsgClassIgnore -> Text -> m ()
forall (m :: * -> *) a.
(MonadClient m, MonadClientUI m, MsgShared a) =>
a -> Text -> m ()
msgAdd MsgClassIgnore
MsgRunStopReason ("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 runCmd :: 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)
                     => m (FailOrCmd RequestTimed)
moveOnceToXhairHuman :: m (FailOrCmd RequestTimed)
moveOnceToXhairHuman = Bool -> Bool -> m (FailOrCmd RequestTimed)
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
Bool -> Bool -> m (FailOrCmd RequestTimed)
goToXhair Bool
True Bool
False

goToXhair :: (MonadClient m, MonadClientUI m)
          => Bool -> Bool -> m (FailOrCmd RequestTimed)
goToXhair :: Bool -> Bool -> m (FailOrCmd RequestTimed)
goToXhair initialStep :: Bool
initialStep run :: 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 "cannot move in aiming mode"
  else Bool -> Bool -> m (FailOrCmd RequestTimed)
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
Bool -> Bool -> m (FailOrCmd RequestTimed)
goToXhairExplorationMode Bool
initialStep Bool
run

goToXhairExplorationMode :: (MonadClient m, MonadClientUI m)
                         => Bool -> Bool -> m (FailOrCmd RequestTimed)
goToXhairExplorationMode :: Bool -> Bool -> m (FailOrCmd RequestTimed)
goToXhairExplorationMode initialStep :: Bool
initialStep run :: Bool
run = 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 Bool -> Bool
not (Maybe Target -> Bool
forall a. Maybe a -> Bool
isNothing 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 "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
$ \sess :: SessionUI
sess -> SessionUI
sess {sxhairGoTo :: Maybe Target
sxhairGoTo = Maybe Target
xhair}
      Bool -> Bool -> m (FailOrCmd RequestTimed)
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
Bool -> Bool -> m (FailOrCmd RequestTimed)
goToXhairGoTo 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
$ \sess :: 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

goToXhairGoTo :: (MonadClient m, MonadClientUI m)
              => Bool -> Bool -> m (FailOrCmd RequestTimed)
goToXhairGoTo :: Bool -> Bool -> m (FailOrCmd RequestTimed)
goToXhairGoTo initialStep :: Bool
initialStep run :: Bool
run = do
  ActorId
leader <- m ActorId
forall (m :: * -> *). MonadClientUI m => m ActorId
getLeaderUI
  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
xhairPos <- m (Maybe Point)
forall (m :: * -> *). MonadClientUI m => m (Maybe Point)
xhairToPos
  case Maybe Point
xhairPos of
    Nothing -> Text -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith "crosshair position invalid"
    Just c :: 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 paramOld :: 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 stopMsg :: 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 (finalGoal :: Bool
finalGoal, dir :: Vector
dir) ->
              Bool
-> Bool -> Bool -> Bool -> Vector -> m (FailOrCmd RequestTimed)
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
Bool
-> Bool -> Bool -> Bool -> Vector -> m (FailOrCmd RequestTimed)
moveRunHuman Bool
initialStep Bool
finalGoal Bool
run Bool
False Vector
dir
        _ | 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 "position reached"
        _ -> do
          let !_A :: ()
_A = Bool -> () -> ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Bool
initialStep Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
run) ()
          (bfs :: Array BfsDistance
bfs, mpath :: 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
            _ | 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
                "no route to crosshair (press again to go there anyway)"
            _ | 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
              Bool
-> Bool -> Bool -> Bool -> Vector -> m (FailOrCmd RequestTimed)
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
Bool
-> Bool -> Bool -> Bool -> Vector -> m (FailOrCmd RequestTimed)
moveRunHuman Bool
initialStep Bool
True Bool
run Bool
False Vector
dir
            Nothing -> Text -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith "no route to crosshair"
            Just AndPath{pathList :: AndPath -> [Point]
pathList=[]} -> Text -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith "almost there"
            Just AndPath{pathList :: AndPath -> [Point]
pathList = p1 :: Point
p1 : _} -> 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
              Bool
-> Bool -> Bool -> Bool -> Vector -> m (FailOrCmd RequestTimed)
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
Bool
-> Bool -> Bool -> Bool -> Vector -> m (FailOrCmd RequestTimed)
moveRunHuman 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 arena :: LevelId
arena c :: Point
c paramOld :: 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 "selected actors no longer there"
    RunParams{runMembers :: RunParams -> [ActorId]
runMembers = r :: ActorId
r : rs :: [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
xhairPos <- m (Maybe Point)
forall (m :: * -> *). MonadClientUI m => m (Maybe Point)
xhairToPos
      if Bool -> Bool
not Bool
onLevel Bool -> Bool -> Bool
|| Maybe Point
xhairPos 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 = 0}
        (bfs :: Array BfsDistance
bfs, mpath :: 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
          _ | 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 "no route to crosshair (press again to go there anyway)"
          Nothing -> Text -> m (FailOrCmd (Bool, Vector))
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith "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 "almost there"
          Just AndPath{pathList :: AndPath -> [Point]
pathList = p1 :: Point
p1 : _} -> 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
$ \sess :: 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)
              [target :: 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
+ 1}
              _ ->
                Text -> m (FailOrCmd (Bool, Vector))
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith "collective running finished"  -- usually OK

-- * RunOnceToXhair

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

-- * ContinueToXhair

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

-- * MoveItem

moveItemHuman :: forall m. (MonadClient m, MonadClientUI m)
              => [CStore] -> CStore -> Maybe Text -> Bool
              -> m (FailOrCmd RequestTimed)
moveItemHuman :: [CStore]
-> CStore -> Maybe Text -> Bool -> m (FailOrCmd RequestTimed)
moveItemHuman stores :: [CStore]
stores destCStore :: CStore
destCStore mverb :: Maybe Text
mverb auto :: 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 <- m Skills
forall (m :: * -> *). MonadClientUI m => m Skills
leaderSkillsClientUI
  if Skill -> Skills -> Int
Ability.getSk Skill
Ability.SkMoveItem Skills
actorCurAndMaxSk Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0
  then [CStore]
-> CStore -> Maybe Text -> Bool -> m (FailOrCmd RequestTimed)
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
[CStore]
-> CStore -> Maybe Text -> Bool -> m (FailOrCmd RequestTimed)
moveOrSelectItem [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. (MonadClient m, MonadClientUI m)
                 => [CStore] -> CStore -> Maybe Text -> Bool
                 -> m (FailOrCmd RequestTimed)
moveOrSelectItem :: [CStore]
-> CStore -> Maybe Text -> Bool -> m (FailOrCmd RequestTimed)
moveOrSelectItem storesRaw :: [CStore]
storesRaw destCStore :: CStore
destCStore mverb :: Maybe Text
mverb auto :: Bool
auto = do
  ActorId
leader <- m ActorId
forall (m :: * -> *). MonadClientUI m => m ActorId
getLeaderUI
  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 <- m Skills
forall (m :: * -> *). MonadClientUI m => m Skills
leaderSkillsClientUI
  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
$ \s :: 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
        CEqp : rest :: [CStore]
rest@(_ : _) | Bool -> Bool
not Bool
calmE -> [CStore]
rest [CStore] -> [CStore] -> [CStore]
forall a. [a] -> [a] -> [a]
++ [CStore
CEqp]
        CGround : rest :: [CStore]
rest@(_ : _) | Bool
overStash -> [CStore]
rest [CStore] -> [CStore] -> [CStore]
forall a. [a] -> [a] -> [a]
++ [CStore
CGround]
        _ -> [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
$ \sess :: 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
    _ | [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 "you can't loot items from your own stash"
    Just (_, fromCStore :: CStore
fromCStore@CStore
CEqp, _) | 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 "neither the selected item nor any other can be unequipped"
    Just (_, fromCStore :: CStore
fromCStore@CStore
CGround, _) | 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 "you vainly paw through your own hoard"
    Just (iid :: ItemId
iid, fromCStore :: CStore
fromCStore, _) | 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
        Nothing ->  -- the case of old selection or selection from another actor
          [CStore]
-> CStore -> Maybe Text -> Bool -> m (FailOrCmd RequestTimed)
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
[CStore]
-> CStore -> Maybe Text -> Bool -> m (FailOrCmd RequestTimed)
moveOrSelectItem [CStore]
stores CStore
destCStore Maybe Text
mverb Bool
auto
        Just (k :: Int
k, it :: 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
> 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
== 0 -> Text -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith "no more items can be equipped"
             | Bool
otherwise -> do
               Either MError Int
socK <- Bool -> Int -> m (Either MError Int)
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
Bool -> Int -> m (Either MError Int)
pickNumber (Bool -> Bool
not Bool
auto) Int
kToPick
               case Either MError Int
socK of
                 Left Nothing -> [CStore]
-> CStore -> Maybe Text -> Bool -> m (FailOrCmd RequestTimed)
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
[CStore]
-> CStore -> Maybe Text -> Bool -> m (FailOrCmd RequestTimed)
moveOrSelectItem [CStore]
stores CStore
destCStore Maybe Text
mverb Bool
auto
                 Left (Just err :: 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 kChosen :: 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
<$> [CStore]
-> (CStore, [(ItemId, (Int, ItemTimers))])
-> CStore
-> m RequestTimed
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
[CStore]
-> (CStore, [(ItemId, (Int, ItemTimers))])
-> CStore
-> m RequestTimed
moveItems [CStore]
stores (CStore, [(ItemId, (Int, ItemTimers))])
is CStore
destCStore
    _ -> do
      FailOrCmd (CStore, [(ItemId, (Int, ItemTimers))])
mis <- [CStore]
-> CStore
-> Maybe Text
-> Bool
-> m (FailOrCmd (CStore, [(ItemId, (Int, ItemTimers))]))
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
[CStore]
-> CStore
-> Maybe Text
-> Bool
-> m (FailOrCmd (CStore, [(ItemId, (Int, ItemTimers))]))
selectItemsToMove [CStore]
stores CStore
destCStore Maybe Text
mverb Bool
auto
      case FailOrCmd (CStore, [(ItemId, (Int, ItemTimers))])
mis of
        Left err :: 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 (fromCStore :: CStore
fromCStore, [(iid :: ItemId
iid, _)]) | [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
$ \sess :: 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)}
          [CStore]
-> CStore -> Maybe Text -> Bool -> m (FailOrCmd RequestTimed)
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
[CStore]
-> CStore -> Maybe Text -> Bool -> m (FailOrCmd RequestTimed)
moveOrSelectItem [CStore]
stores CStore
destCStore Maybe Text
mverb Bool
auto
        Right is :: (CStore, [(ItemId, (Int, ItemTimers))])
is@(fromCStore :: CStore
fromCStore, _) ->
          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
<$> [CStore]
-> (CStore, [(ItemId, (Int, ItemTimers))])
-> CStore
-> m RequestTimed
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
[CStore]
-> (CStore, [(ItemId, (Int, ItemTimers))])
-> CStore
-> m RequestTimed
moveItems [CStore]
stores (CStore, [(ItemId, (Int, ItemTimers))])
is CStore
destCStore

selectItemsToMove :: forall m. (MonadClient m, MonadClientUI m)
                  => [CStore] -> CStore -> Maybe Text -> Bool
                  -> m (FailOrCmd (CStore, [(ItemId, ItemQuant)]))
selectItemsToMove :: [CStore]
-> CStore
-> Maybe Text
-> Bool
-> m (FailOrCmd (CStore, [(ItemId, (Int, ItemTimers))]))
selectItemsToMove stores :: [CStore]
stores destCStore :: CStore
destCStore mverb :: Maybe Text
mverb auto :: 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
  ActorId
leader <- m ActorId
forall (m :: * -> *). MonadClientUI m => m ActorId
getLeaderUI
  Skills
actorCurAndMaxSk <- m Skills
forall (m :: * -> *). MonadClientUI m => m Skills
leaderSkillsClientUI
  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
$ \s :: 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 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 (lastFrom :: CStore
lastFrom, lastDest :: 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
             _ -> [CStore]
stores
           prompt :: Text
prompt = "What to"
           promptEqp :: Text
promptEqp = "What consumable to"
           eqpItemsN :: Actor -> Text
eqpItemsN body :: 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
forall a. Semigroup a => a -> a -> a
<> [Part] -> Text
makePhrase [Int -> Part -> Part
MU.CarWs Int
n "item"]
           ppItemDialogBody :: Actor -> Skills -> ItemDialogMode -> Text
ppItemDialogBody body :: Actor
body actorSk :: Skills
actorSk cCur :: ItemDialogMode
cCur = case ItemDialogMode
cCur of
             MStore CEqp | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Actor -> Skills -> Bool
calmEnough Actor
body Skills
actorSk ->
               "distractedly paw at" Text -> Text -> Text
<+> ItemDialogMode -> Text
ppItemDialogModeIn ItemDialogMode
cCur
             MStore 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) ->
               "greedily fondle" Text -> Text -> Text
<+> ItemDialogMode -> Text
ppItemDialogModeIn ItemDialogMode
cCur
             _ -> case CStore
destCStore of
               CEqp | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Actor -> Skills -> Bool
calmEnough Actor
body Skills
actorSk ->
                 "distractedly attempt to" Text -> Text -> Text
<+> Text
verb
                 Text -> Text -> Text
<+> ItemDialogMode -> Text
ppItemDialogModeFrom ItemDialogMode
cCur
               CEqp | Actor -> Int -> Bool
eqpOverfull Actor
body 1 ->
                 "attempt to fit into equipment" Text -> Text -> Text
<+> ItemDialogMode -> Text
ppItemDialogModeFrom ItemDialogMode
cCur
               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) ->
                 "greedily attempt to" Text -> Text -> Text
<+> Text
verb Text -> Text -> Text
<+> ItemDialogMode -> Text
ppItemDialogModeFrom ItemDialogMode
cCur
               CEqp -> Text
verb
                       Text -> Text -> Text
<+> Actor -> Text
eqpItemsN Actor
body Text -> Text -> Text
<+> "so far)"
                       Text -> Text -> Text
<+> ItemDialogMode -> Text
ppItemDialogModeFrom ItemDialogMode
cCur
               _ -> 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
<+> "now)"
                        else ""
           (promptGeneric :: Text
promptGeneric, psuit :: 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
$ \_ itemFull :: ItemFull
itemFull _kit :: (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 <-
         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 :: * -> *).
(MonadClient m, MonadClientUI m) =>
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 m Suitability
psuit
                 (\body :: Actor
body _ actorSk :: Skills
actorSk cCur :: ItemDialogMode
cCur _ ->
                    Text
prompt Text -> Text -> Text
<+> Actor -> Skills -> ItemDialogMode -> Text
ppItemDialogBody Actor
body Skills
actorSk ItemDialogMode
cCur)
                 (\body :: Actor
body _ actorSk :: Skills
actorSk cCur :: ItemDialogMode
cCur _ ->
                    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 (fromCStore :: CStore
fromCStore, l :: [(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
$ \sess :: 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 err :: Text
err -> Text -> m (FailOrCmd (CStore, [(ItemId, (Int, ItemTimers))]))
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith Text
err

moveItems :: forall m. (MonadClient m, MonadClientUI m)
          => [CStore] -> (CStore, [(ItemId, ItemQuant)]) -> CStore
          -> m RequestTimed
moveItems :: [CStore]
-> (CStore, [(ItemId, (Int, ItemTimers))])
-> CStore
-> m RequestTimed
moveItems stores :: [CStore]
stores (fromCStore :: CStore
fromCStore, l :: [(ItemId, (Int, ItemTimers))]
l) destCStore :: 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) ()
  ActorId
leader <- m ActorId
forall (m :: * -> *). MonadClientUI m => m ActorId
getLeaderUI
  Skills
actorCurAndMaxSk <- m Skills
forall (m :: * -> *). MonadClientUI m => m Skills
leaderSkillsClientUI
  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 [] _ = [(ItemId, Int, CStore, CStore)]
-> m [(ItemId, Int, CStore, CStore)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
      ret4 ((iid :: ItemId
iid, (k :: Int
k, _)) : rest :: [(ItemId, (Int, ItemTimers))]
rest) oldN :: 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
> 0) ()
            retRec :: CStore -> m [(ItemId, Int, CStore, CStore)]
retRec toCStore :: 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 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
+ 1) -> do
                  -- Action goes through, but changed, so keep in history.
                  MsgClassShowAndSave -> Text -> m ()
forall (m :: * -> *) a.
(MonadClient m, MonadClientUI m, MsgShared a) =>
a -> Text -> m ()
msgAdd MsgClassShowAndSave
MsgActionWarning (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
                    "Warning:" Text -> Text -> Text
<+> ReqFailure -> Text
showReqFailure ReqFailure
EqpOverfull Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "."
                  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.
(MonadClient m, MonadClientUI m, MsgShared a) =>
a -> Text -> m ()
msgAdd MsgClassShowAndSave
MsgActionWarning (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
                    "Warning:" Text -> Text -> Text
<+> ReqFailure -> Text
showReqFailure ReqFailure
EqpStackFull Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "."
                  CStore -> m [(ItemId, Int, CStore, CStore)]
retRec CStore
CStash
                | Bool -> Bool
not Bool
calmE -> do
                  MsgClassShowAndSave -> Text -> m ()
forall (m :: * -> *) a.
(MonadClient m, MonadClientUI m, MsgShared a) =>
a -> Text -> m ()
msgAdd MsgClassShowAndSave
MsgActionWarning (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
                    "Warning:" Text -> Text -> Text
<+> ReqFailure -> Text
showReqFailure ReqFailure
ItemNotCalm Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "."
                  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
          CEqp | Actor -> Int -> Bool
eqpOverfull Actor
b (Int
oldN Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) -> do
            -- Action aborted, so different colour and not in history.
            MsgClassShow -> Text -> m ()
forall (m :: * -> *) a.
(MonadClient m, MonadClientUI m, MsgShared a) =>
a -> Text -> m ()
msgAdd MsgClassShow
MsgPromptItems (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
              "Failure:" Text -> Text -> Text
<+> ReqFailure -> Text
showReqFailure ReqFailure
EqpOverfull Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "."
            -- 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 []
          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.
(MonadClient m, MonadClientUI m, MsgShared a) =>
a -> Text -> m ()
msgAdd MsgClassShow
MsgPromptItems (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
              "Failure:" Text -> Text -> Text
<+> ReqFailure -> Text
showReqFailure ReqFailure
EqpStackFull Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "."
            [(ItemId, Int, CStore, CStore)]
-> m [(ItemId, Int, CStore, CStore)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
          _ -> 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 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
-> ([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) => m (FailOrCmd RequestTimed)
projectHuman :: m (FailOrCmd RequestTimed)
projectHuman = do
  Challenge
curChal <- (StateClient -> Challenge) -> m Challenge
forall (m :: * -> *) a.
MonadClientRead m =>
(StateClient -> a) -> m a
getsClient StateClient -> Challenge
scurChal
  Skills
actorCurAndMaxSk <- m Skills
forall (m :: * -> *). MonadClientUI m => m Skills
leaderSkillsClientUI
  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
<= 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 (_, COrgan, _) -> Text -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith "can't fling an organ"
         Just (iid :: ItemId
iid, fromCStore :: CStore
fromCStore, _) -> do
           ActorId
leader <- m ActorId
forall (m :: * -> *). MonadClientUI m => m ActorId
getLeaderUI
           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
             Nothing -> Text -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith "no item to fling"
             Just _kit :: (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))
               (CStore, (ItemId, ItemFull)) -> m (FailOrCmd RequestTimed)
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
(CStore, (ItemId, ItemFull)) -> m (FailOrCmd RequestTimed)
projectItem (CStore, (ItemId, ItemFull))
i
         Nothing -> Text -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith "no item to fling"

projectItem :: (MonadClient m, MonadClientUI m)
            => (CStore, (ItemId, ItemFull))
            -> m (FailOrCmd RequestTimed)
projectItem :: (CStore, (ItemId, ItemFull)) -> m (FailOrCmd RequestTimed)
projectItem (fromCStore :: CStore
fromCStore, (iid :: ItemId
iid, itemFull :: ItemFull
itemFull)) = do
  ActorId
leader <- m ActorId
forall (m :: * -> *). MonadClientUI m => m ActorId
getLeaderUI
  Skills
actorCurAndMaxSk <- m Skills
forall (m :: * -> *). MonadClientUI m => m Skills
leaderSkillsClientUI
  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 <- m (Either Text (ItemFull -> Either ReqFailure (Point, Bool)))
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
m (Either Text (ItemFull -> Either ReqFailure (Point, Bool)))
psuitReq
    case Either Text (ItemFull -> Either ReqFailure (Point, Bool))
mpsuitReq of
      Left err :: Text
err -> Text -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith Text
err
      Right psuitReqFun :: ItemFull -> Either ReqFailure (Point, Bool)
psuitReqFun ->
        case ItemFull -> Either ReqFailure (Point, Bool)
psuitReqFun ItemFull
itemFull of
          Left reqFail :: ReqFailure
reqFail -> ReqFailure -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a.
MonadClientUI m =>
ReqFailure -> m (FailOrCmd a)
failSer ReqFailure
reqFail
          Right (pos :: Point
pos, _) -> 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
>= 0
                  then ColorMode -> Text -> m Bool
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
ColorMode -> Text -> m Bool
displayYesNo ColorMode
ColorFull
                         "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
$ \sess :: 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 "never mind"

-- * Apply

applyHuman :: (MonadClient m, MonadClientUI m) => m (FailOrCmd RequestTimed)
applyHuman :: m (FailOrCmd RequestTimed)
applyHuman = do
  Skills
actorCurAndMaxSk <- m Skills
forall (m :: * -> *). MonadClientUI m => m Skills
leaderSkillsClientUI
  if Skill -> Skills -> Int
Ability.getSk Skill
Ability.SkApply
                   Skills
actorCurAndMaxSk Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 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 (iid :: ItemId
iid, fromCStore :: CStore
fromCStore, _) -> do
        ActorId
leader <- m ActorId
forall (m :: * -> *). MonadClientUI m => m ActorId
getLeaderUI
        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
          Nothing -> Text -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith "no item to trigger"
          Just kit :: (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
            (CStore, (ItemId, ItemFullKit)) -> m (FailOrCmd RequestTimed)
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
(CStore, (ItemId, ItemFullKit)) -> m (FailOrCmd RequestTimed)
applyItem (CStore
fromCStore, (ItemId
iid, (ItemFull
itemFull, (Int, ItemTimers)
kit)))
      Nothing -> Text -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith "no item to trigger"

applyItem :: (MonadClient m, MonadClientUI m)
          => (CStore, (ItemId, ItemFullKit))
          -> m (FailOrCmd RequestTimed)
applyItem :: (CStore, (ItemId, ItemFullKit)) -> m (FailOrCmd RequestTimed)
applyItem (fromCStore :: CStore
fromCStore, (iid :: ItemId
iid, (itemFull :: ItemFull
itemFull, kit :: (Int, ItemTimers)
kit))) = do
  ActorId
leader <- m ActorId
forall (m :: * -> *). MonadClientUI m => m ActorId
getLeaderUI
  Skills
actorCurAndMaxSk <- m Skills
forall (m :: * -> *). MonadClientUI m => m Skills
leaderSkillsClientUI
  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 Time
-> Int
-> Bool
-> Maybe CStore
-> ItemFull
-> (Int, ItemTimers)
-> Either ReqFailure Bool
permittedApply Time
localTime Int
skill Bool
calmE (CStore -> Maybe CStore
forall a. a -> Maybe a
Just CStore
fromCStore)
                           ItemFull
itemFull (Int, ItemTimers)
kit of
    Left reqFail :: ReqFailure
reqFail -> ReqFailure -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a.
MonadClientUI m =>
ReqFailure -> m (FailOrCmd a)
failSer ReqFailure
reqFail
    Right _ -> 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 :: * -> *).
(MonadClient m, MonadClientUI m) =>
ColorMode -> Text -> m Bool
displayYesNo ColorMode
ColorFull
                          "Triggering this periodic item may not produce all its effects (check item description) and moreover, because it's not durable, will destroy it. Are you sure?"
           | Double
benApply Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< 0 ->
             ColorMode -> Text -> m Bool
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
ColorMode -> Text -> m Bool
displayYesNo ColorMode
ColorFull
                          "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
$ \sess :: 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 "never mind"

-- * AlterDir

-- | Ask for a direction and alter a tile, if possible.
alterDirHuman :: (MonadClient m, MonadClientUI m)
              => m (FailOrCmd RequestTimed)
alterDirHuman :: m (FailOrCmd RequestTimed)
alterDirHuman = Text -> m (Maybe Point)
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
Text -> m (Maybe Point)
pickPoint "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 p :: Point
p -> Point -> m (FailOrCmd RequestTimed)
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
Point -> m (FailOrCmd RequestTimed)
alterTileAtPos Point
p
  Nothing -> Text -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith "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 :: (MonadClient m, MonadClientUI m)
               => Point
               -> m (FailOrCmd RequestTimed)
alterTileAtPos :: Point -> m (FailOrCmd RequestTimed)
alterTileAtPos pos :: Point
pos = do
  ActorId
leader <- m ActorId
forall (m :: * -> *). MonadClientUI m => m ActorId
getLeaderUI
  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
  Bool -> Point -> m (FailOrCmd RequestTimed)
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
Bool -> Point -> m (FailOrCmd RequestTimed)
alterCommon 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. (MonadClient m, MonadClientUI m)
             => Bool -> ActorId -> Point -> m (FailOrCmd ())
verifyAlters :: Bool -> ActorId -> Point -> m (FailOrCmd ())
verifyAlters bumping :: Bool
bumping source :: ActorId
source tpos :: 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
source
  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 (\(iid :: ItemId
iid, kit :: (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
Tile.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 Bool -> ActorId -> Point -> [TileAction] -> m (FailOrCmd ())
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
Bool -> ActorId -> Point -> [TileAction] -> m (FailOrCmd ())
processTileActions Bool
bumping ActorId
source Point
tpos [TileAction]
tileActions

processTileActions :: forall m. (MonadClient m, MonadClientUI m)
                   => Bool -> ActorId -> Point -> [Tile.TileAction]
                   -> m (FailOrCmd ())
processTileActions :: Bool -> ActorId -> Point -> [TileAction] -> m (FailOrCmd ())
processTileActions bumping :: Bool
bumping source :: ActorId
source tpos :: Point
tpos tas :: [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
source
  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 sourceIsMist :: Bool
sourceIsMist = 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
<= 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 -> [Tile.TileAction] -> Bool
                -> m (FailOrCmd (Maybe (Bool, Bool)))
      processTA :: Maybe Bool
-> [TileAction] -> Bool -> m (FailOrCmd (Maybe (Bool, Bool)))
processTA museResult :: Maybe Bool
museResult [] bumpFailed :: 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 museResult :: Maybe Bool
museResult (ta :: TileAction
ta : rest :: [TileAction]
rest) bumpFailed :: Bool
bumpFailed = case TileAction
ta of
        Tile.EmbedAction (iid :: ItemId
iid, _) -> 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
sourceIsMist
               Bool -> Bool -> Bool
|| Actor -> Bool
bproj Actor
sb Bool -> Bool -> Bool
&& Int
tileMinSkill Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 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
             | (Effect -> Bool) -> [Effect] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> Bool
not (Bool -> Bool) -> (Effect -> Bool) -> Effect -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: * -> *).
(MonadClient m, MonadClientUI m) =>
m (FailOrCmd ())
verifyEscape
               case FailOrCmd ()
mfail of
                 Left err :: 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
        Tile.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
> 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
        Tile.WithAction tools0 :: [(Int, GroupName ItemKind)]
tools0 _ ->
          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
source [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
source [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 (\(x :: Int
x, y :: GroupName ItemKind
y) -> (Bool
False, Int
x, GroupName ItemKind
y)) [(Int, GroupName ItemKind)]
tools0
                    -- apply if durable
                  (_, iidsToApply :: [(CStore, (ItemId, ItemFull))]
iidsToApply, grps :: [(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 (_, (_, ItemFull{ItemKind
itemKind :: ItemFull -> ItemKind
itemKind :: ItemKind
itemKind})) =
                      ItemKind -> Dice
IK.idamage ItemKind
itemKind Dice -> Dice -> Bool
forall a. Eq a => a -> a -> Bool
/= 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 ()
                  (store :: CStore
store, (_, itemFull :: ItemFull
itemFull)) : _ ->
                    LevelId -> CStore -> ItemFull -> m (FailOrCmd ())
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
LevelId -> CStore -> ItemFull -> m (FailOrCmd ())
verifyToolEffect (Actor -> LevelId
blid Actor
sb) CStore
store ItemFull
itemFull
                case FailOrCmd ()
mfail of
                  Left err :: 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 err :: 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 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 (useResult :: Bool
useResult, bumpFailed :: 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 <- LevelId -> Point -> m [(MsgClassShow, Text)]
forall (m :: * -> *).
MonadClientUI m =>
LevelId -> Point -> m [(MsgClassShow, Text)]
lookAtPosition (Actor -> LevelId
blid Actor
sb) Point
tpos
      ((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.
(MonadClient m, 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 = "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
<> "' 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.
(MonadClient m, 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 "unable to activate nor modify at this time"
        -- related to, among others, @SfxNoItemsForTile@ on the server

verifyEscape :: (MonadClient m, 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 (Player -> Bool
MK.fcanEscape (Player -> Bool) -> Player -> Bool
forall a b. (a -> b) -> a -> b
$ Faction -> Player
gplayer Faction
fact)
  then Text -> m (FailOrCmd ())
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith
         "This is the way out, but where would you go in this alien world?"
           -- exceptionally a full sentence, because a real question
  else do
    (_, total :: 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
== 0 =
                 "You finally reached the way out. Really leave now?"
               | Int
total Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 =
                 "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 =
                 "You've finally found the way out, but you didn't gather all valuables rumoured to be laying around. Really leave already?"
               | Bool
otherwise =
                 "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 :: * -> *).
(MonadClient 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 "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 :: (MonadClient m, MonadClientUI m)
                 => LevelId -> CStore -> ItemFull -> m (FailOrCmd ())
verifyToolEffect :: LevelId -> CStore -> ItemFull -> m (FailOrCmd ())
verifyToolEffect lid :: LevelId
lid store :: CStore
store itemFull :: 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 (name1 :: Part
name1, powers :: 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]
      prompt :: Text
prompt = "Do you really want to transform the terrain using"
               Text -> Text -> Text
<+> Text
objectA Text -> Text -> Text
<+> CStore -> Text
ppCStoreIn CStore
store
               Text -> Text -> Text
<+> "that may cause substantial side-effects?"
      objectThe :: Text
objectThe = [Part] -> Text
makePhrase ["the", Part
name1]
  Bool
go <- ColorMode -> Text -> m Bool
forall (m :: * -> *).
(MonadClient 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
$ "replace" Text -> Text -> Text
<+> Text
objectThe 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 :: (MonadClient m, MonadClientUI m)
                      => m (FailOrCmd RequestTimed)
alterWithPointerHuman :: m (FailOrCmd RequestTimed)
alterWithPointerHuman = do
  COps{corule :: COps -> RuleContent
corule=RuleContent{Int
rXmax :: RuleContent -> Int
rXmax :: Int
rXmax, Int
rYmax :: RuleContent -> Int
rYmax :: Int
rYmax}} <- (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@(Point px :: Int
px py :: Int
py) = PointSquare -> Point
squareToMap (PointSquare -> Point) -> PointSquare -> Point
forall a b. (a -> b) -> a -> b
$ PointUI -> PointSquare
uiToSquare PointUI
pUI
  if Int
px Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 0 Bool -> Bool -> Bool
&& Int
py Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 0 Bool -> Bool -> Bool
&& Int
px Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
rXmax Bool -> Bool -> Bool
&& Int
py Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
rYmax
  then Point -> m (FailOrCmd RequestTimed)
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
Point -> m (FailOrCmd RequestTimed)
alterTileAtPos Point
p
  else Text -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith "never mind"

-- * CloseDir

-- | Close nearby open tile; ask for direction, if there is more than one.
closeDirHuman :: (MonadClient m, MonadClientUI m)
              => m (FailOrCmd RequestTimed)
closeDirHuman :: m (FailOrCmd RequestTimed)
closeDirHuman = 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
  ActorId
leader <- m ActorId
forall (m :: * -> *). MonadClientUI m => m ActorId
getLeaderUI
  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
    [o :: Point
o] -> Point -> m (FailOrCmd RequestTimed)
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
Point -> m (FailOrCmd RequestTimed)
closeTileAtPos Point
o
    _   -> Text -> m (Maybe Point)
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
Text -> m (Maybe Point)
pickPoint "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
      Nothing -> Text -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith "never mind"
      Just p :: Point
p -> Point -> m (FailOrCmd RequestTimed)
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
Point -> m (FailOrCmd RequestTimed)
closeTileAtPos Point
p

-- | Close tile at given position.
closeTileAtPos :: (MonadClient m, MonadClientUI m)
               => Point -> m (FailOrCmd RequestTimed)
closeTileAtPos :: Point -> m (FailOrCmd RequestTimed)
closeTileAtPos tpos :: 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
  ActorId
leader <- m ActorId
forall (m :: * -> *). MonadClientUI m => m ActorId
getLeaderUI
  Skills
actorCurAndMaxSk <- m Skills
forall (m :: * -> *). MonadClientUI m => m Skills
leaderSkillsClientUI
  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
    (False, _, _) -> ReqFailure -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a.
MonadClientUI m =>
ReqFailure -> m (FailOrCmd a)
failSer ReqFailure
CloseNothing
    (True, False, False) -> ReqFailure -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a.
MonadClientUI m =>
ReqFailure -> m (FailOrCmd a)
failSer ReqFailure
CloseNonClosable
    (True, True,  False) -> ReqFailure -> m (FailOrCmd RequestTimed)
forall (m :: * -> *) a.
MonadClientUI m =>
ReqFailure -> m (FailOrCmd a)
failSer ReqFailure
CloseClosed
    (True, True,  True) -> String -> m (FailOrCmd RequestTimed)
forall a. (?callStack::CallStack) => String -> a
error "TileKind content validation"
    (True, False, True) ->
      if | Point
tpos Point -> Point -> Int
`chessDist` Actor -> Point
bpos Actor
b Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 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
<= 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
             Point -> Text -> m ()
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
Point -> Text -> m ()
msgAddDone Point
tpos "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 :: (MonadClient m, MonadClientUI m) => Point -> Text -> m ()
msgAddDone :: Point -> Text -> m ()
msgAddDone p :: Point
p verb :: 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
  ActorId
leader <- m ActorId
forall (m :: * -> *). MonadClientUI m => m ActorId
getLeaderUI
  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
            [] -> "thing"
            ("open" : xs :: [Text]
xs) -> [Text] -> Text
T.unwords [Text]
xs
            _ -> Text
tname
      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 0 0 = "underneath"
          | Bool
otherwise = Vector -> Text
compassText Vector
v
  MsgClassShowAndSave -> Text -> m ()
forall (m :: * -> *) a.
(MonadClient m, MonadClientUI m, MsgShared a) =>
a -> Text -> m ()
msgAdd MsgClassShowAndSave
MsgActionComplete (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ "You" Text -> Text -> Text
<+> Text
verb Text -> Text -> Text
<+> "the" Text -> Text -> Text
<+> Text
s Text -> Text -> Text
<+> Text
dir Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "."

-- | Prompts user to pick a point.
pickPoint :: (MonadClient m, MonadClientUI m) => Text -> m (Maybe Point)
pickPoint :: Text -> m (Maybe Point)
pickPoint verb :: Text
verb = do
  ActorId
leader <- m ActorId
forall (m :: * -> *). MonadClientUI m => m ActorId
getLeaderUI
  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.
(MonadClient m, MonadClientUI m, MsgShared a) =>
a -> Text -> m ()
msgAdd MsgClassShow
MsgPromptGeneric (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ "Where to" Text -> Text -> Text
<+> Text
verb Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "? [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 :: * -> *).
(MonadClient m, MonadClientUI m) =>
ColorMode -> [KM] -> Slideshow -> m KM
getConfirms ColorMode
ColorFull [KM]
keys Slideshow
slides
  case KM -> Key
K.key KM
km of
    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
    _ -> 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 :: (MonadClient m, 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 cmdSemInCxtOfKM :: 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{..} <- 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
  let modeH :: (Text, (EnumMap DisplayFont Overlay, [KYX]))
modeH = ( "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 [] acc :: [[String]]
acc _ = [[String] -> [[String]] -> [String]
forall a. [a] -> [[a]] -> [a]
intercalate [""] ([[String]] -> [[String]]
forall a. [a] -> [a]
reverse [[String]]
acc)]
      packIntoScreens ([] : ls :: [[String]]
ls) [] _  =
        -- Ignore empty paragraphs at the start of screen.
        [[String]] -> [[String]] -> Int -> [[String]]
packIntoScreens [[String]]
ls [] 0
      packIntoScreens (l :: [String]
l : ls :: [[String]]
ls) [] h :: 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
== 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
- 3
        then [[String]] -> [[String]] -> Int -> [[String]]
packIntoScreens [[String]]
ls [[String]
l] ([String] -> Int
forall a. [a] -> Int
length [String]
l)
        else let (screen :: [String]
screen, rest :: [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
- 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) [] 0
      packIntoScreens (l :: [String]
l : ls :: [[String]]
ls) acc :: [[String]]
acc h :: 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
+ 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
- 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
+ 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]]
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) [] 0
      manualScreens :: [[String]]
manualScreens = [[String]] -> [[String]] -> Int -> [[String]]
packIntoScreens (([String], [[String]]) -> [[String]]
forall a b. (a, b) -> b
snd ([String], [[String]])
rintroScreen) [] 0
      shiftPointUI :: Int -> PointUI -> PointUI
shiftPointUI x :: Int
x (PointUI x0 :: Int
x0 y0 :: Int
y0) = Int -> Int -> PointUI
PointUI (Int
x0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
x) Int
y0
      sideBySide :: ([AttrLine], [AttrLine]) -> [Overlay]
sideBySide =
        if DisplayFont -> Bool
isSquareFont DisplayFont
monoFont
        then \(screen1 :: [AttrLine]
screen1, screen2 :: [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 \(screen1 :: [AttrLine]
screen1, screen2 :: [AttrLine]
screen2) ->  -- two columns, single screen
          [[AttrLine] -> Overlay
offsetOverlay [AttrLine]
screen1
           Overlay -> Overlay -> Overlay
forall a. [a] -> [a] -> [a]
++ ((PointUI, AttrLine) -> (PointUI, AttrLine)) -> Overlay -> Overlay
forall a b. (a -> b) -> [a] -> [b]
map ((PointUI -> PointUI) -> (PointUI, AttrLine) -> (PointUI, AttrLine)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((PointUI -> PointUI)
 -> (PointUI, AttrLine) -> (PointUI, AttrLine))
-> (PointUI -> PointUI)
-> (PointUI, AttrLine)
-> (PointUI, AttrLine)
forall a b. (a -> b) -> a -> b
$ Int -> PointUI -> PointUI
shiftPointUI Int
rwidth) ([AttrLine] -> Overlay
offsetOverlay [AttrLine]
screen2)]
      listPairs :: [[a]] -> [([a], [a])]
listPairs (a :: [a]
a : b :: [a]
b : rest :: [[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]
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 ov :: a
ov =
        ( "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 (t :: Text
t, okx :: (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.escKM] (EnumMap DisplayFont Overlay, [KYX])
okx
      sli :: Slideshow
sli = FontSetup -> [(EnumMap DisplayFont Overlay, [KYX])] -> Slideshow
toSlideshow FontSetup
fontSetup ([(EnumMap DisplayFont Overlay, [KYX])] -> Slideshow)
-> [(EnumMap DisplayFont Overlay, [KYX])] -> Slideshow
forall a b. (a -> b) -> a -> b
$ [[(EnumMap DisplayFont Overlay, [KYX])]]
-> [(EnumMap DisplayFont Overlay, [KYX])]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(EnumMap DisplayFont Overlay, [KYX])]]
 -> [(EnumMap DisplayFont Overlay, [KYX])])
-> [[(EnumMap DisplayFont Overlay, [KYX])]]
-> [(EnumMap DisplayFont Overlay, [KYX])]
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 a b. (a -> b) -> [a] -> [b]
map (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.
  Either KM SlotChar
ekm <- String
-> ColorMode -> Bool -> Slideshow -> [KM] -> m (Either KM SlotChar)
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
String
-> ColorMode -> Bool -> Slideshow -> [KM] -> m (Either KM SlotChar)
displayChoiceScreen "help" ColorMode
ColorFull Bool
True Slideshow
sli [KM
K.spaceKM, KM
K.escKM]
  case Either KM SlotChar
ekm of
    Left km :: 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 -> 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 (_desc :: [CmdCategory]
_desc, _cats :: Text
_cats, cmd :: HumanCmd
cmd) -> KM -> HumanCmd -> m (Either MError ReqUI)
cmdSemInCxtOfKM KM
km HumanCmd
cmd
      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 "never mind"
    Right _slot :: SlotChar
_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 -> Either KM SlotChar -> String
forall v. Show v => String -> v -> String
`showFailure` Either KM SlotChar
ekm

-- * Hint

-- | Display hint or, if already displayed, display help.
hintHuman :: (MonadClient m, 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 cmdSemInCxtOfKM :: 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 :: * -> *). (MonadClient 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 :: * -> *).
(MonadClient 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 :: (MonadClient m, 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 cmdSemInCxtOfKM :: 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{..} <- m FontSetup
forall (m :: * -> *). MonadClientUI m => m FontSetup
getFontSetup
  let offsetCol2 :: Int
offsetCol2 = 2
      (ov0 :: EnumMap DisplayFont Overlay
ov0, kxs0 :: [KYX]
kxs0) = InputContent
-> DisplayFont
-> DisplayFont
-> Int
-> Int
-> (HumanCmd -> Bool)
-> Bool
-> CmdCategory
-> ([Text], [Text], [Text])
-> ([Text], [Text])
-> (EnumMap DisplayFont Overlay, [KYX])
okxsN InputContent
coinput DisplayFont
monoFont DisplayFont
propFont 0 Int
offsetCol2 (Bool -> HumanCmd -> Bool
forall a b. a -> b -> a
const Bool
False)
                          Bool
False CmdCategory
CmdDashboard ([], [], []) ([], [])
      al1 :: AttrString
al1 = Text -> AttrString
textToAS "Dashboard"
  let splitHelp :: (AttrString, (EnumMap DisplayFont Overlay, [KYX]))
-> [(EnumMap DisplayFont Overlay, [KYX])]
splitHelp (al :: AttrString
al, okx :: (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
- 2) Int
rwidth
                                     AttrString
al [KM
K.escKM] (EnumMap DisplayFont Overlay, [KYX])
okx
      sli :: Slideshow
sli = FontSetup -> [(EnumMap DisplayFont Overlay, [KYX])] -> Slideshow
toSlideshow FontSetup
fontSetup ([(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.escKM]
  Either KM SlotChar
ekm <- String
-> ColorMode -> Bool -> Slideshow -> [KM] -> m (Either KM SlotChar)
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
String
-> ColorMode -> Bool -> Slideshow -> [KM] -> m (Either KM SlotChar)
displayChoiceScreen "dashboard" ColorMode
ColorFull Bool
False Slideshow
sli [KM]
extraKeys
  case Either KM SlotChar
ekm of
    Left km :: 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
      _ | 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 "never mind"
      Just (_desc :: [CmdCategory]
_desc, _cats :: Text
_cats, cmd :: HumanCmd
cmd) -> KM -> HumanCmd -> m (Either MError ReqUI)
cmdSemInCxtOfKM KM
km HumanCmd
cmd
      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 "never mind"
    Right _slot :: SlotChar
_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 -> Either KM SlotChar -> String
forall v. Show v => String -> v -> String
`showFailure` Either KM SlotChar
ekm

-- * ItemMenu

itemMenuHuman :: (MonadClient m, MonadClientUI m)
              => (K.KM -> HumanCmd -> m (Either MError ReqUI))
              -> m (Either MError ReqUI)
itemMenuHuman :: (KM -> HumanCmd -> m (Either MError ReqUI))
-> m (Either MError ReqUI)
itemMenuHuman cmdSemInCxtOfKM :: KM -> HumanCmd -> m (Either MError ReqUI)
cmdSemInCxtOfKM = 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
  fontSetup :: FontSetup
fontSetup@FontSetup{..} <- m FontSetup
forall (m :: * -> *). MonadClientUI m => m FontSetup
getFontSetup
  case Maybe (ItemId, CStore, Bool)
itemSel of
    Just (iid :: ItemId
iid, fromCStore :: CStore
fromCStore, _) -> do
      ActorId
leader <- m ActorId
forall (m :: * -> *). MonadClientUI m => m ActorId
getLeaderUI
      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
        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 "no item to open item menu for"
        Just kit :: (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 <- m Skills
forall (m :: * -> *). MonadClientUI m => m Skills
leaderSkillsClientUI
          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 (Actor -> FactionId
bfid Actor
b) ItemId
iid
          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
          LevelId
jlid <- (SessionUI -> LevelId) -> m LevelId
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession ((SessionUI -> LevelId) -> m LevelId)
-> (SessionUI -> LevelId) -> m LevelId
forall a b. (a -> b) -> a -> b
$ (EnumMap ItemId LevelId -> ItemId -> LevelId
forall k a. Enum k => EnumMap k a -> k -> a
EM.! ItemId
iid) (EnumMap ItemId LevelId -> LevelId)
-> (SessionUI -> EnumMap ItemId LevelId) -> SessionUI -> LevelId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SessionUI -> EnumMap ItemId LevelId
sitemUI
          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 (aid :: ActorId
aid, (_, store :: 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
              partRawActor :: ActorId -> m Part
partRawActor aid :: 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 aid :: ActorId
aid store :: 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
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack ([Part] -> Text
makePhrase [Part]
parts) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "]"
          [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 (\(aid :: ActorId
aid, (_, store :: CStore
store)) -> ActorId -> CStore -> m String
forall (m :: * -> *).
MonadClientUI m =>
ActorId -> CStore -> m String
ppLoc ActorId
aid CStore
store) [(ActorId, (Actor, CStore))]
foundAlt
          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 "" else "The item is also in:"
              markParagraphs :: Bool
markParagraphs = Int
rheight Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 45
              descAl :: AttrString
descAl = Int
-> Bool
-> FactionId
-> EnumMap FactionId Faction
-> Int
-> CStore
-> Time
-> LevelId
-> ItemFull
-> (Int, ItemTimers)
-> AttrString
itemDesc Int
rwidth Bool
markParagraphs (Actor -> FactionId
bfid Actor
b) EnumMap FactionId Faction
factionD
                                (Skill -> Skills -> Int
Ability.getSk Skill
Ability.SkHurtMelee
                                               Skills
actorCurAndMaxSk)
                                CStore
fromCStore Time
localTime LevelId
jlid ItemFull
itemFull (Int, ItemTimers)
kit
              (descSymAl :: AttrString
descSymAl, descBlurbAl :: AttrString
descBlurbAl) = (AttrCharW32 -> Bool) -> AttrString -> (AttrString, AttrString)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (AttrCharW32 -> AttrCharW32 -> Bool
forall a. Eq a => a -> a -> Bool
/= AttrCharW32
Color.spaceAttrW32) AttrString
descAl
              descSym :: Overlay
descSym = [AttrLine] -> Overlay
offsetOverlay ([AttrLine] -> Overlay) -> [AttrLine] -> Overlay
forall a b. (a -> b) -> a -> b
$ Int -> Int -> AttrString -> [AttrLine]
splitAttrString Int
rwidth Int
rwidth AttrString
descSymAl
              descBlurb :: Overlay
descBlurb = [(Int, AttrLine)] -> Overlay
offsetOverlayX ([(Int, AttrLine)] -> Overlay) -> [(Int, AttrLine)] -> Overlay
forall a b. (a -> b) -> a -> b
$
                case Int -> Int -> AttrString -> [AttrLine]
splitAttrString Int
rwidth Int
rwidth
                     (AttrString -> [AttrLine]) -> AttrString -> [AttrLine]
forall a b. (a -> b) -> a -> b
$ String -> AttrString
stringToAS "xx" AttrString -> AttrString -> AttrString
forall a. [a] -> [a] -> [a]
++ AttrString
descBlurbAl of
                  [] -> String -> [(Int, AttrLine)]
forall a. (?callStack::CallStack) => String -> a
error "splitting AttrString loses characters"
                  al1 :: AttrLine
al1 : rest :: [AttrLine]
rest ->
                    (2, AttrString -> AttrLine
attrStringToAL (AttrString -> AttrLine) -> AttrString -> AttrLine
forall a b. (a -> b) -> a -> b
$ Int -> AttrString -> AttrString
forall a. Int -> [a] -> [a]
drop 2 (AttrString -> AttrString) -> AttrString -> AttrString
forall a b. (a -> b) -> a -> b
$ AttrLine -> AttrString
attrLine AttrLine
al1) (Int, AttrLine) -> [(Int, AttrLine)] -> [(Int, AttrLine)]
forall a. a -> [a] -> [a]
: (AttrLine -> (Int, AttrLine)) -> [AttrLine] -> [(Int, AttrLine)]
forall a b. (a -> b) -> [a] -> [b]
map (0,) [AttrLine]
rest
              alPrefix :: Overlay
alPrefix = ((PointUI, AttrLine) -> (PointUI, AttrLine)) -> Overlay -> Overlay
forall a b. (a -> b) -> [a] -> [b]
map (\(PointUI x :: Int
x y :: Int
y, al :: AttrLine
al) ->
                                (Int -> Int -> PointUI
PointUI Int
x (Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Overlay -> Int
forall a. [a] -> Int
length Overlay
descBlurb), AttrLine
al))
                         (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
descBlurb Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Overlay -> Int
forall a. [a] -> Int
length Overlay
alPrefix Int -> Int -> Int
forall a. Num a => a -> a -> a
- 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
alPrefix))
              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)
                              [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 2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
rwidth else Int
rwidth
              (ovFoundRaw :: Overlay
ovFoundRaw, kxsFound :: [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
alPrefix 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
$ \s :: 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
              greyedOut :: HumanCmd -> Bool
greyedOut cmd :: 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 -> Bool
greyedOut HumanCmd
exploration Bool -> Bool -> Bool
|| HumanCmd -> Bool
greyedOut HumanCmd
aiming
                ComposeIfLocal cmd1 :: HumanCmd
cmd1 cmd2 :: HumanCmd
cmd2 -> HumanCmd -> Bool
greyedOut HumanCmd
cmd1 Bool -> Bool -> Bool
|| HumanCmd -> Bool
greyedOut HumanCmd
cmd2
                ComposeUnlessError cmd1 :: HumanCmd
cmd1 cmd2 :: HumanCmd
cmd2 -> HumanCmd -> Bool
greyedOut HumanCmd
cmd1 Bool -> Bool -> Bool
|| HumanCmd -> Bool
greyedOut HumanCmd
cmd2
                Compose2ndLocal cmd1 :: HumanCmd
cmd1 cmd2 :: HumanCmd
cmd2 -> HumanCmd -> Bool
greyedOut HumanCmd
cmd1 Bool -> Bool -> Bool
|| HumanCmd -> Bool
greyedOut HumanCmd
cmd2
                MoveItem stores :: [CStore]
stores destCStore :: CStore
destCStore _ _ ->
                  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 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
$ (ReqFailure -> Bool)
-> (Bool -> Bool) -> Either ReqFailure Bool -> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Bool -> ReqFailure -> Bool
forall a b. a -> b -> a
const Bool
False) Bool -> Bool
forall a. a -> a
id
                     (Either ReqFailure Bool -> Bool) -> Either ReqFailure Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Time
-> Int
-> Bool
-> Maybe CStore
-> ItemFull
-> (Int, ItemTimers)
-> Either ReqFailure Bool
permittedApply 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
$ (ReqFailure -> Bool)
-> (Bool -> Bool) -> Either ReqFailure Bool -> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Bool -> ReqFailure -> Bool
forall a b. a -> b -> a
const Bool
False) Bool -> Bool
forall a. a -> a
id
                     (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
                _ -> Bool
False
              fmt :: Int -> Text -> Text -> Text
fmt n :: Int
n k :: Text
k h :: Text
h = " " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Char -> Text -> Text
T.justifyLeft Int
n ' ' Text
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
h
              offsetCol2 :: Int
offsetCol2 = 11
              keyCaption :: Text
keyCaption = Int -> Text -> Text -> Text
fmt Int
offsetCol2 "keys" "command"
              offset :: Int
offset = 1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Overlay -> Int
maxYofOverlay (Overlay
descBlurb Overlay -> Overlay -> Overlay
forall a. [a] -> [a] -> [a]
++ Overlay
ovFound)
              (ov0 :: EnumMap DisplayFont Overlay
ov0, kxs0 :: [KYX]
kxs0) = InputContent
-> DisplayFont
-> DisplayFont
-> Int
-> Int
-> (HumanCmd -> Bool)
-> Bool
-> CmdCategory
-> ([Text], [Text], [Text])
-> ([Text], [Text])
-> (EnumMap DisplayFont Overlay, [KYX])
okxsN InputContent
coinput DisplayFont
monoFont DisplayFont
propFont Int
offset Int
offsetCol2
                                  HumanCmd -> Bool
greyedOut Bool
True CmdCategory
CmdItemMenu
                                  ([], [], ["", Text
keyCaption]) ([], [])
              t0 :: Text
t0 = [Part] -> Text
makeSentence [ Part -> Part -> Part
MU.SubjectVerbSg (ActorUI -> Part
partActor ActorUI
bUI) "choose"
                                , "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 "\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 (al :: AttrString
al, okx :: (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
- 2) Int
rwidth AttrString
al
                         [KM
K.spaceKM, KM
K.escKM] (EnumMap DisplayFont Overlay, [KYX])
okx
              sli :: Slideshow
sli = FontSetup -> [(EnumMap DisplayFont Overlay, [KYX])] -> Slideshow
toSlideshow FontSetup
fontSetup
                    ([(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
descSym
                                    (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
descBlurb
                                    (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
          Either KM SlotChar
ekm <- String
-> ColorMode -> Bool -> Slideshow -> [KM] -> m (Either KM SlotChar)
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
String
-> ColorMode -> Bool -> Slideshow -> [KM] -> m (Either KM SlotChar)
displayChoiceScreen "item menu" ColorMode
ColorFull Bool
False Slideshow
sli [KM]
extraKeys
          case Either KM SlotChar
ekm of
            Left km :: 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
              _ | 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 "never mind"
              _ | KM
km KM -> KM -> Bool
forall a. Eq a => a -> a -> Bool
== KM
K.spaceKM -> 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 "back to list"
              _ | 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 n :: Int
n} -> do
                  let (newAid :: ActorId
newAid, (bNew :: Actor
bNew, newCStore :: 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
- 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.! Actor -> FactionId
bfid Actor
bNew) (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 (autoDun :: Bool
autoDun, _) = Faction -> (Bool, Bool)
autoDungeonLevel 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
autoDun ->
                       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
                     | Bool
otherwise -> do
                       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 :: * -> *).
(MonadClient m, MonadClientUI m) =>
Bool -> ActorId -> m Bool
pickLeader Bool
True 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
$ \sess :: 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)}
                       (KM -> HumanCmd -> m (Either MError ReqUI))
-> m (Either MError ReqUI)
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
(KM -> HumanCmd -> m (Either MError ReqUI))
-> m (Either MError ReqUI)
itemMenuHuman KM -> HumanCmd -> m (Either MError ReqUI)
cmdSemInCxtOfKM
                _ -> 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 -> KM -> String
forall v. Show v => String -> v -> String
`showFailure` KM
km
              Just (_desc :: [CmdCategory]
_desc, _cats :: Text
_cats, cmd :: 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
$ \sess :: 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
              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 "never mind"
            Right _slot :: SlotChar
_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 -> Either KM SlotChar -> String
forall v. Show v => String -> v -> String
`showFailure` Either KM SlotChar
ekm
    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 "no item to open item menu for"

-- * ChooseItemMenu

chooseItemMenuHuman :: (MonadClient m, MonadClientUI m)
                    => (K.KM -> HumanCmd -> m (Either MError ReqUI))
                    -> ItemDialogMode
                    -> m (Either MError ReqUI)
chooseItemMenuHuman :: (KM -> HumanCmd -> m (Either MError ReqUI))
-> ItemDialogMode -> m (Either MError ReqUI)
chooseItemMenuHuman cmdSemInCxtOfKM :: KM -> HumanCmd -> m (Either MError ReqUI)
cmdSemInCxtOfKM c0 :: ItemDialogMode
c0 = do
  let chooseItemMenu :: ItemDialogMode -> m (Either MError ReqUI)
chooseItemMenu c1 :: ItemDialogMode
c1 = do
        FailOrCmd ItemDialogMode
res <- Bool -> ItemDialogMode -> m (FailOrCmd ItemDialogMode)
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
Bool -> ItemDialogMode -> m (FailOrCmd ItemDialogMode)
chooseItemDialogMode Bool
True ItemDialogMode
c1
        case FailOrCmd ItemDialogMode
res of
          Right c2 :: ItemDialogMode
c2 -> do
            Either MError ReqUI
res2 <- (KM -> HumanCmd -> m (Either MError ReqUI))
-> m (Either MError ReqUI)
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
(KM -> HumanCmd -> m (Either MError ReqUI))
-> m (Either MError ReqUI)
itemMenuHuman KM -> HumanCmd -> m (Either MError ReqUI)
cmdSemInCxtOfKM
            MError
backToList <- Text -> m MError
forall (m :: * -> *). MonadClientUI m => Text -> m MError
failMsg "back to list"
            case Either MError ReqUI
res2 of
              Left err :: MError
err | MError
err MError -> MError -> Bool
forall a. Eq a => a -> a -> Bool
== MError
backToList -> ItemDialogMode -> m (Either MError ReqUI)
chooseItemMenu ItemDialogMode
c2
              _ -> Either MError ReqUI -> m (Either MError ReqUI)
forall (m :: * -> *) a. Monad m => a -> m a
return Either MError ReqUI
res2
          Left err :: 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
  ItemDialogMode -> m (Either MError ReqUI)
chooseItemMenu ItemDialogMode
c0

-- * MainMenu

generateMenu :: (MonadClient m, MonadClientUI m)
             => (K.KM -> HumanCmd -> m (Either MError ReqUI))
             -> [(DisplayFont, [AttrLine])]
             -> [(K.KM, (Text, HumanCmd))]
             -> [String]
             -> String
             -> m (Either MError ReqUI)
generateMenu :: (KM -> HumanCmd -> m (Either MError ReqUI))
-> [(DisplayFont, [AttrLine])]
-> [(KM, (Text, HumanCmd))]
-> [String]
-> String
-> m (Either MError ReqUI)
generateMenu cmdSemInCxtOfKM :: KM -> HumanCmd -> m (Either MError ReqUI)
cmdSemInCxtOfKM blurb :: [(DisplayFont, [AttrLine])]
blurb kds :: [(KM, (Text, HumanCmd))]
kds gameInfo :: [String]
gameInfo menuName :: 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{coscreen :: CCUI -> ScreenContent
coscreen=ScreenContent{Int
rwidth :: Int
rwidth :: ScreenContent -> Int
rwidth, 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{..} <- m FontSetup
forall (m :: * -> *). MonadClientUI m => m FontSetup
getFontSetup
  let bindings :: [(Maybe KM, String)]
bindings =  -- key bindings to display
        let fmt :: (KM, (Text, b)) -> (Maybe KM, String)
fmt (k :: KM
k, (d :: Text
d, _)) =
              ( KM -> Maybe KM
forall a. a -> Maybe a
Just KM
k
              , Text -> String
T.unpack
                (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$  Int -> Char -> Text -> Text
T.justifyLeft 3 ' ' (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ KM -> String
K.showKM KM
k) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
d )
        in ((KM, (Text, HumanCmd)) -> (Maybe KM, String))
-> [(KM, (Text, HumanCmd))] -> [(Maybe KM, String)]
forall a b. (a -> b) -> [a] -> [b]
map (KM, (Text, HumanCmd)) -> (Maybe KM, String)
forall b. (KM, (Text, b)) -> (Maybe KM, String)
fmt [(KM, (Text, HumanCmd))]
kds
      generate :: Int -> (Maybe K.KM, String) -> ((Int, AttrLine), Maybe KYX)
      generate :: Int -> (Maybe KM, String) -> ((Int, AttrLine), Maybe KYX)
generate y :: Int
y (mkey :: Maybe KM
mkey, binding :: String
binding) =
        let lenB :: Int
lenB = String -> Int
forall a. [a] -> Int
length String
binding
            yxx :: KM -> KYX
yxx key :: KM
key = ([KM] -> Either [KM] SlotChar
forall a b. a -> Either a b
Left [KM
key], ( Int -> Int -> PointUI
PointUI 2 Int
y
                                   , DisplayFont -> Int -> ButtonWidth
ButtonWidth DisplayFont
squareFont Int
lenB ))
            myxx :: Maybe KYX
myxx = KM -> KYX
yxx (KM -> KYX) -> Maybe KM -> Maybe KYX
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe KM
mkey
        in ((2, String -> AttrLine
stringToAL String
binding), Maybe KYX
myxx)
      titleLine :: String
titleLine = RuleContent -> String
rtitle RuleContent
corule String -> String -> String
forall a. [a] -> [a] -> [a]
++ " "
                  String -> String -> String
forall a. [a] -> [a] -> [a]
++ Version -> String
showVersion (RuleContent -> Version
rexeVersion RuleContent
corule) String -> String -> String
forall a. [a] -> [a] -> [a]
++ " "
      rawLines :: [(Maybe KM, String)]
rawLines = [Maybe KM] -> [String] -> [(Maybe KM, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Maybe KM -> [Maybe KM]
forall a. a -> [a]
repeat Maybe KM
forall a. Maybe a
Nothing)
                     (["", String
titleLine String -> String -> String
forall a. [a] -> [a] -> [a]
++ "[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
rwebAddress String -> String -> String
forall a. [a] -> [a] -> [a]
++ "]", ""]
                      [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
gameInfo)
                 [(Maybe KM, String)]
-> [(Maybe KM, String)] -> [(Maybe KM, String)]
forall a. [a] -> [a] -> [a]
++ [(Maybe KM, String)]
bindings
      (menuOvLines :: [(Int, AttrLine)]
menuOvLines, mkyxs :: [Maybe KYX]
mkyxs) = [((Int, AttrLine), Maybe KYX)] -> ([(Int, AttrLine)], [Maybe KYX])
forall a b. [(a, b)] -> ([a], [b])
unzip ([((Int, AttrLine), Maybe KYX)]
 -> ([(Int, AttrLine)], [Maybe KYX]))
-> [((Int, AttrLine), Maybe KYX)]
-> ([(Int, AttrLine)], [Maybe KYX])
forall a b. (a -> b) -> a -> b
$ (Int -> (Maybe KM, String) -> ((Int, AttrLine), Maybe KYX))
-> [Int] -> [(Maybe KM, String)] -> [((Int, AttrLine), Maybe KYX)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> (Maybe KM, String) -> ((Int, AttrLine), Maybe KYX)
generate [0..] [(Maybe KM, String)]
rawLines
      browserKey :: KYX
browserKey = ( SlotChar -> Either [KM] SlotChar
forall a b. b -> Either a b
Right (SlotChar -> Either [KM] SlotChar)
-> SlotChar -> Either [KM] SlotChar
forall a b. (a -> b) -> a -> b
$ Int -> Char -> SlotChar
SlotChar 1042 'a'
                   , ( Int -> Int -> PointUI
PointUI (2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* String -> Int
forall a. [a] -> Int
length String
titleLine) 1
                     , DisplayFont -> Int -> ButtonWidth
ButtonWidth DisplayFont
squareFont (2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ String -> Int
forall a. [a] -> Int
length String
rwebAddress) ) )
      kyxs :: [KYX]
kyxs = KYX
browserKey KYX -> [KYX] -> [KYX]
forall a. a -> [a] -> [a]
: [Maybe KYX] -> [KYX]
forall a. [Maybe a] -> [a]
catMaybes [Maybe KYX]
mkyxs
      introLen :: Int
introLen = [Int] -> Int
forall a. Num a => [a] -> a
sum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ ((DisplayFont, [AttrLine]) -> Int)
-> [(DisplayFont, [AttrLine])] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ([AttrLine] -> Int
forall a. [a] -> Int
length ([AttrLine] -> Int)
-> ((DisplayFont, [AttrLine]) -> [AttrLine])
-> (DisplayFont, [AttrLine])
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DisplayFont, [AttrLine]) -> [AttrLine]
forall a b. (a, b) -> b
snd) [(DisplayFont, [AttrLine])]
blurb
      start0 :: Int
start0 = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max 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 1 else 2)
      shiftPointUI :: PointUI -> PointUI
shiftPointUI (PointUI x0 :: Int
x0 y0 :: Int
y0) = Int -> Int -> PointUI
PointUI (Int
x0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
rwidth) Int
y0
      ov0 :: EnumMap DisplayFont Overlay
ov0 = (Overlay -> Overlay)
-> EnumMap DisplayFont Overlay -> EnumMap DisplayFont Overlay
forall a b k. (a -> b) -> EnumMap k a -> EnumMap k b
EM.map (((PointUI, AttrLine) -> (PointUI, AttrLine)) -> Overlay -> Overlay
forall a b. (a -> b) -> [a] -> [b]
map ((PointUI -> PointUI) -> (PointUI, AttrLine) -> (PointUI, AttrLine)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first PointUI -> PointUI
shiftPointUI)) (EnumMap DisplayFont Overlay -> EnumMap DisplayFont Overlay)
-> EnumMap DisplayFont Overlay -> EnumMap DisplayFont Overlay
forall a b. (a -> b) -> a -> b
$ Int -> [(DisplayFont, [AttrLine])] -> EnumMap DisplayFont Overlay
attrLinesToFontMap Int
start0 [(DisplayFont, [AttrLine])]
blurb
      ov :: EnumMap DisplayFont Overlay
ov = (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 ([(Int, AttrLine)] -> Overlay
offsetOverlayX [(Int, AttrLine)]
menuOvLines) EnumMap DisplayFont Overlay
ov0
  Map String Int
menuIxMap <- (SessionUI -> Map String Int) -> m (Map String Int)
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> Map String Int
smenuIxMap
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String
menuName String -> Map String Int -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.member` Map String Int
menuIxMap) (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
$ \sess :: SessionUI
sess -> SessionUI
sess {smenuIxMap :: Map String Int
smenuIxMap = String -> Int -> Map String Int -> Map String Int
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
menuName 1 Map String Int
menuIxMap}
  Either KM SlotChar
ekm <- String
-> ColorMode -> Bool -> Slideshow -> [KM] -> m (Either KM SlotChar)
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
String
-> ColorMode -> Bool -> Slideshow -> [KM] -> m (Either KM SlotChar)
displayChoiceScreen String
menuName ColorMode
ColorFull Bool
True
                             ((EnumMap DisplayFont Overlay, [KYX]) -> Slideshow
menuToSlideshow (EnumMap DisplayFont Overlay
ov, [KYX]
kyxs)) [KM
K.escKM]
  case Either KM SlotChar
ekm of
    Left km :: KM
km -> case KM
km KM -> [(KM, (Text, HumanCmd))] -> Maybe (Text, HumanCmd)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` [(KM, (Text, HumanCmd))]
kds of
      Just (_desc :: Text
_desc, cmd :: HumanCmd
cmd) -> KM -> HumanCmd -> m (Either MError ReqUI)
cmdSemInCxtOfKM KM
km HumanCmd
cmd
      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 "never mind"
    Right (SlotChar 1042 'a') -> 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))
-> [(DisplayFont, [AttrLine])]
-> [(KM, (Text, HumanCmd))]
-> [String]
-> String
-> m (Either MError ReqUI)
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
(KM -> HumanCmd -> m (Either MError ReqUI))
-> [(DisplayFont, [AttrLine])]
-> [(KM, (Text, HumanCmd))]
-> [String]
-> String
-> m (Either MError ReqUI)
generateMenu KM -> HumanCmd -> m (Either MError ReqUI)
cmdSemInCxtOfKM [(DisplayFont, [AttrLine])]
blurb [(KM, (Text, HumanCmd))]
kds [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 "failed to open web browser"
    Right _slot :: SlotChar
_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 -> Either KM SlotChar -> String
forall v. Show v => String -> v -> String
`showFailure` Either KM SlotChar
ekm

-- | Display the main menu.
mainMenuHuman :: (MonadClient m, 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 cmdSemInCxtOfKM :: KM -> HumanCmd -> m (Either MError ReqUI)
cmdSemInCxtOfKM = do
  CCUI{ coinput :: CCUI -> InputContent
coinput=InputContent{[(KM, CmdTriple)]
bcmdList :: InputContent -> [(KM, CmdTriple)]
bcmdList :: [(KM, CmdTriple)]
bcmdList}
      , 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
  Challenge
curChal <- (StateClient -> Challenge) -> m Challenge
forall (m :: * -> *) a.
MonadClientRead m =>
(StateClient -> a) -> m a
getsClient StateClient -> Challenge
scurChal
  let offOn :: Bool -> p
offOn b :: Bool
b = if Bool
b then "on" else "off"
      tcurDiff :: Text
tcurDiff   = "   with difficulty:" Text -> Text -> Text
<+> Int -> Text
forall a. Show a => a -> Text
tshow (Challenge -> Int
cdiff Challenge
curChal)
      tcurFish :: Text
tcurFish   = "       cold fish:" Text -> Text -> Text
<+> Bool -> Text
forall p. IsString p => Bool -> p
offOn (Challenge -> Bool
cfish Challenge
curChal)
      tcurGoods :: Text
tcurGoods  = "     ready goods:" Text -> Text -> Text
<+> Bool -> Text
forall p. IsString p => Bool -> p
offOn (Challenge -> Bool
cgoods Challenge
curChal)
      tcurWolf :: Text
tcurWolf   = "       lone wolf:" Text -> Text -> Text
<+> Bool -> Text
forall p. IsString p => Bool -> p
offOn (Challenge -> Bool
cwolf Challenge
curChal)
      tcurKeeper :: Text
tcurKeeper = "   finder keeper:" Text -> Text -> Text
<+> Bool -> Text
forall p. IsString p => Bool -> p
offOn (Challenge -> Bool
ckeeper Challenge
curChal)
      -- Key-description-command tuples.
      kds :: [(KM, (Text, HumanCmd))]
kds = [(KM
km, (Text
desc, HumanCmd
cmd)) | (km :: KM
km, ([CmdMainMenu], desc :: Text
desc, cmd :: HumanCmd
cmd)) <- [(KM, CmdTriple)]
bcmdList]
      gameName :: Text
gameName = ModeKind -> Text
MK.mname ModeKind
gameMode
      gameInfo :: [String]
gameInfo = (Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
T.unpack
                   [ "Now playing:" Text -> Text -> Text
<+> Text
gameName
                   , ""
                   , Text
tcurDiff
                   , Text
tcurFish
                   , Text
tcurGoods
                   , Text
tcurWolf
                   , Text
tcurKeeper
                   , "" ]
      glueLines :: [[a]] -> [[a]]
glueLines (l1 :: [a]
l1 : l2 :: [a]
l2 : rest :: [[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 ll :: [[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] -> [AttrLine]
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ' ')) [String]
backstory
  (KM -> HumanCmd -> m (Either MError ReqUI))
-> [(DisplayFont, [AttrLine])]
-> [(KM, (Text, HumanCmd))]
-> [String]
-> String
-> m (Either MError ReqUI)
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
(KM -> HumanCmd -> m (Either MError ReqUI))
-> [(DisplayFont, [AttrLine])]
-> [(KM, (Text, HumanCmd))]
-> [String]
-> String
-> m (Either MError ReqUI)
generateMenu KM -> HumanCmd -> m (Either MError ReqUI)
cmdSemInCxtOfKM [(DisplayFont
propFont, [AttrLine]
backstoryAL)] [(KM, (Text, HumanCmd))]
kds [String]
gameInfo "main"

-- * MainMenuAutoOn

-- | Display the main menu and set @swasAutomated@.
mainMenuAutoOnHuman :: (MonadClient m, 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 cmdSemInCxtOfKM :: 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
$ \sess :: SessionUI
sess -> SessionUI
sess {swasAutomated :: Bool
swasAutomated = Bool
True}
  (KM -> HumanCmd -> m (Either MError ReqUI))
-> m (Either MError ReqUI)
forall (m :: * -> *).
(MonadClient 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 :: (MonadClient m, 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 cmdSemInCxtOfKM :: 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
$ \sess :: SessionUI
sess -> SessionUI
sess {swasAutomated :: Bool
swasAutomated = Bool
False}
  (KM -> HumanCmd -> m (Either MError ReqUI))
-> m (Either MError ReqUI)
forall (m :: * -> *).
(MonadClient 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 :: (MonadClient m, 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 cmdSemInCxtOfKM :: KM -> HumanCmd -> m (Either MError ReqUI)
cmdSemInCxtOfKM = do
  Int
markSuspect <- (StateClient -> Int) -> m Int
forall (m :: * -> *) a.
MonadClientRead m =>
(StateClient -> a) -> m a
getsClient StateClient -> Int
smarkSuspect
  Bool
markVision <- (SessionUI -> Bool) -> m Bool
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> Bool
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
$ Player -> Doctrine
MK.fdoctrine (Player -> Doctrine) -> (State -> Player) -> State -> Doctrine
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Faction -> Player
gplayer (Faction -> Player) -> (State -> Faction) -> State -> Player
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 b :: Bool
b = if Bool
b then "on" else "off"
      offOnUnset :: Maybe Bool -> p
offOnUnset mb :: Maybe Bool
mb = case Maybe Bool
mb of
        Nothing -> "no override"
        Just b :: Bool
b -> if Bool
b then "force on" else "force off"
      offOnAll :: v -> p
offOnAll n :: v
n = case v
n of
        0 -> "none"
        1 -> "untried"
        2 -> "all"
        _ -> String -> p
forall a. (?callStack::CallStack) => String -> a
error (String -> p) -> String -> p
forall a b. (a -> b) -> a -> b
$ "" String -> v -> String
forall v. Show v => String -> v -> String
`showFailure` v
n
      tsuspect :: Text
tsuspect = "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 = "show visible zone:" Text -> Text -> Text
<+> Bool -> Text
forall p. IsString p => Bool -> p
offOn Bool
markVision
      tsmell :: Text
tsmell = "display smell clues:" Text -> Text -> Text
<+> Bool -> Text
forall p. IsString p => Bool -> p
offOn Bool
markSmell
      tanim :: Text
tanim = "play animations:" Text -> Text -> Text
<+> Bool -> Text
forall p. IsString p => Bool -> p
offOn (Bool -> Bool
not Bool
noAnim)
      tdoctrine :: Text
tdoctrine = "squad doctrine:" Text -> Text -> Text
<+> Doctrine -> Text
Ability.nameDoctrine Doctrine
factDoctrine
      toverride :: Text
toverride = "override tutorial hints:" Text -> Text -> Text
<+> Maybe Bool -> Text
forall p. IsString p => Maybe Bool -> p
offOnUnset Maybe Bool
overrideTut
      -- Key-description-command tuples.
      kds :: [(KM, (Text, HumanCmd))]
kds = [ (String -> KM
K.mkKM "s", (Text
tsuspect, HumanCmd
MarkSuspect))
            , (String -> KM
K.mkKM "v", (Text
tvisible, HumanCmd
MarkVision))
            , (String -> KM
K.mkKM "c", (Text
tsmell, HumanCmd
MarkSmell))
            , (String -> KM
K.mkKM "a", (Text
tanim, HumanCmd
MarkAnim))
            , (String -> KM
K.mkKM "t", (Text
tdoctrine, HumanCmd
Doctrine))
            , (String -> KM
K.mkKM "o", (Text
toverride, HumanCmd
OverrideTut))
            , (String -> KM
K.mkKM "Escape", ("back to main menu", HumanCmd
MainMenu)) ]
      gameInfo :: [String]
gameInfo = (Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
T.unpack
                   [ "Tweak convenience settings:"
                   , "" ]
  (KM -> HumanCmd -> m (Either MError ReqUI))
-> [(DisplayFont, [AttrLine])]
-> [(KM, (Text, HumanCmd))]
-> [String]
-> String
-> m (Either MError ReqUI)
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
(KM -> HumanCmd -> m (Either MError ReqUI))
-> [(DisplayFont, [AttrLine])]
-> [(KM, (Text, HumanCmd))]
-> [String]
-> String
-> m (Either MError ReqUI)
generateMenu KM -> HumanCmd -> m (Either MError ReqUI)
cmdSemInCxtOfKM [] [(KM, (Text, HumanCmd))]
kds [String]
gameInfo "settings"

-- * ChallengeMenu

-- | Display the challenge menu.
challengeMenuHuman :: (MonadClient m, 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 cmdSemInCxtOfKM :: 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, Int
rwrap :: ScreenContent -> Int
rwrap :: Int
rwrap}} <- (SessionUI -> CCUI) -> m CCUI
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> CCUI
sccui
  FontSetup{..} <- m FontSetup
forall (m :: * -> *). MonadClientUI m => m FontSetup
getFontSetup
  EnumMap (ContentId ModeKind) (Map Challenge Int)
svictories <- (StateClient -> EnumMap (ContentId ModeKind) (Map Challenge Int))
-> m (EnumMap (ContentId ModeKind) (Map Challenge Int))
forall (m :: * -> *) a.
MonadClientRead m =>
(StateClient -> a) -> m a
getsClient StateClient -> 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
  Bool
nxtTutorial <- (SessionUI -> Bool) -> m Bool
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> Bool
snxtTutorial
  Maybe Bool
overrideTut <- (SessionUI -> Maybe Bool) -> m (Maybe Bool)
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> Maybe Bool
soverrideTut
  Challenge
nxtChal <- (StateClient -> Challenge) -> m Challenge
forall (m :: * -> *) a.
MonadClientRead m =>
(StateClient -> a) -> m a
getsClient StateClient -> Challenge
snxtChal
  let (gameModeId :: ContentId ModeKind
gameModeId, gameMode :: 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
        Nothing -> 0
        Just cm :: Map Challenge Int
cm -> Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe 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 t :: Text
t = if Int
victories Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0 then "*" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t else Text
t
      tnextScenario :: Text
tnextScenario = "adventure:" Text -> Text -> Text
<+> Text -> Text
star (ModeKind -> Text
MK.mname ModeKind
gameMode)
      offOn :: Bool -> p
offOn b :: Bool
b = if Bool
b then "on" else "off"
      starTut :: Text -> Text
starTut t :: Text
t = if Maybe Bool -> Bool
forall a. Maybe a -> Bool
isJust Maybe Bool
overrideTut then "*" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t else Text
t
      displayTutorialHints :: Bool
displayTutorialHints = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
nxtTutorial Maybe Bool
overrideTut
      tnextTutorial :: Text
tnextTutorial = "tutorial hints (in pink):"
                      Text -> Text -> Text
<+> Text -> Text
starTut (Bool -> Text
forall p. IsString p => Bool -> p
offOn Bool
displayTutorialHints)
      tnextDiff :: Text
tnextDiff = "difficulty (lower easier):" Text -> Text -> Text
<+> Int -> Text
forall a. Show a => a -> Text
tshow (Challenge -> Int
cdiff Challenge
nxtChal)
      tnextFish :: Text
tnextFish   = "cold fish (rather hard):"
                    Text -> Text -> Text
<+> Bool -> Text
forall p. IsString p => Bool -> p
offOn (Challenge -> Bool
cfish Challenge
nxtChal)
      tnextGoods :: Text
tnextGoods  = "ready goods (hard):"
                    Text -> Text -> Text
<+> Bool -> Text
forall p. IsString p => Bool -> p
offOn (Challenge -> Bool
cgoods Challenge
nxtChal)
      tnextWolf :: Text
tnextWolf   = "lone wolf (very hard):"
                    Text -> Text -> Text
<+> Bool -> Text
forall p. IsString p => Bool -> p
offOn (Challenge -> Bool
cwolf Challenge
nxtChal)
      tnextKeeper :: Text
tnextKeeper = "finder keeper (hard):"
                    Text -> Text -> Text
<+> Bool -> Text
forall p. IsString p => Bool -> p
offOn (Challenge -> Bool
ckeeper Challenge
nxtChal)
      -- Key-description-command tuples.
      kds :: [(KM, (Text, HumanCmd))]
kds = [ (String -> KM
K.mkKM "s", (Text
tnextScenario, HumanCmd
GameScenarioIncr))
            , (String -> KM
K.mkKM "t", (Text
tnextTutorial, HumanCmd
GameTutorialToggle))
            , (String -> KM
K.mkKM "d", (Text
tnextDiff, HumanCmd
GameDifficultyIncr))
            , (String -> KM
K.mkKM "f", (Text
tnextFish, HumanCmd
GameFishToggle))
            , (String -> KM
K.mkKM "r", (Text
tnextGoods, HumanCmd
GameGoodsToggle))
            , (String -> KM
K.mkKM "w", (Text
tnextWolf, HumanCmd
GameWolfToggle))
            , (String -> KM
K.mkKM "k", (Text
tnextKeeper, HumanCmd
GameKeeperToggle))
            , (String -> KM
K.mkKM "g", ("start new game", HumanCmd
GameRestart))
            , (String -> KM
K.mkKM "Escape", ("back to main menu", HumanCmd
MainMenu)) ]
      gameInfo :: [String]
gameInfo = (Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
T.unpack [ "Setup and start new game:"
                              , "" ]
      widthProp :: Int
widthProp = if DisplayFont -> Bool
isSquareFont DisplayFont
propFont
                  then Int
rwidth Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 2
                  else Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
rwrap (Int
rwidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- 2)
      widthMono :: Int
widthMono = if DisplayFont -> Bool
isSquareFont DisplayFont
propFont
                  then Int
rwidth Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 2
                  else Int
rwidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- 2
      duplicateEOL :: Char -> Text
duplicateEOL '\n' = "\n\n"
      duplicateEOL c :: Char
c = Char -> Text
T.singleton Char
c
      blurb :: [(DisplayFont, [AttrLine])]
blurb =
        [ ( DisplayFont
propFont
          , Int -> Int -> AttrString -> [AttrLine]
splitAttrString Int
widthProp Int
widthProp
            (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
<> "\n\n" )
        , ( DisplayFont
monoFont
          , Int -> Int -> AttrString -> [AttrLine]
splitAttrString Int
widthMono Int
widthMono
            (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
<> "\n\n" )
        , ( DisplayFont
propFont
          , Int -> Int -> AttrString -> [AttrLine]
splitAttrString Int
widthProp Int
widthProp
            (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) )
        ]
  (KM -> HumanCmd -> m (Either MError ReqUI))
-> [(DisplayFont, [AttrLine])]
-> [(KM, (Text, HumanCmd))]
-> [String]
-> String
-> m (Either MError ReqUI)
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
(KM -> HumanCmd -> m (Either MError ReqUI))
-> [(DisplayFont, [AttrLine])]
-> [(KM, (Text, HumanCmd))]
-> [String]
-> String
-> m (Either MError ReqUI)
generateMenu KM -> HumanCmd -> m (Either MError ReqUI)
cmdSemInCxtOfKM [(DisplayFont, [AttrLine])]
blurb [(KM, (Text, HumanCmd))]
kds [String]
gameInfo "challenge"

-- * GameTutorialToggle

gameTutorialToggle :: MonadClientUI m  => m ()
gameTutorialToggle :: m ()
gameTutorialToggle = do
  Bool
nxtTutorial <- (SessionUI -> Bool) -> m Bool
forall (m :: * -> *) a. MonadClientUI m => (SessionUI -> a) -> m a
getsSession SessionUI -> Bool
snxtTutorial
  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
nxtTutorial Maybe Bool
overrideTut
  (SessionUI -> SessionUI) -> m ()
forall (m :: * -> *).
MonadClientUI m =>
(SessionUI -> SessionUI) -> m ()
modifySession ((SessionUI -> SessionUI) -> m ())
-> (SessionUI -> SessionUI) -> m ()
forall a b. (a -> b) -> a -> b
$ \sess :: SessionUI
sess -> SessionUI
sess { snxtTutorial :: Bool
snxtTutorial = Bool -> Bool
not Bool
displayTutorialHints
                                , soverrideTut :: Maybe Bool
soverrideTut = Maybe Bool
forall a. Maybe a
Nothing }

-- * GameDifficultyIncr

gameDifficultyIncr :: MonadClient m => m ()
gameDifficultyIncr :: m ()
gameDifficultyIncr = 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 delta :: Int
delta = -1
      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 = 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
< 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
$ \cli :: 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
$ \cli :: 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
$ \cli :: 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
$ \cli :: 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
$ \cli :: 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 :: (MonadClient m, MonadClientUI m) => m ()
gameScenarioIncr :: m ()
gameScenarioIncr = 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
+ 1
      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
$ \sess :: SessionUI
sess -> SessionUI
sess {Int
snxtScenario :: Int
snxtScenario :: Int
snxtScenario, Bool
snxtTutorial :: Bool
snxtTutorial :: Bool
snxtTutorial}

-- * GameRestart

gameRestartHuman :: (MonadClient m, MonadClientUI m) => m (FailOrCmd ReqUI)
gameRestartHuman :: m (FailOrCmd ReqUI)
gameRestartHuman = do
  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
  Bool
b <- if Bool
noConfirmsGame
       then Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
       else ColorMode -> Text -> m Bool
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
ColorMode -> Text -> m Bool
displayYesNo ColorMode
ColorBW
            (Text -> m Bool) -> Text -> m Bool
forall a b. (a -> b) -> a -> b
$ "You just requested a new" Text -> Text -> Text
<+> Text
nxtGameName
              Text -> Text -> Text
<+> "game. The progress of the ongoing" Text -> Text -> Text
<+> ModeKind -> Text
MK.mname ModeKind
gameMode
              Text -> Text -> Text
<+> "game will be lost! Are you sure?"
  if Bool
b
  then do
    Challenge
snxtChal <- (StateClient -> Challenge) -> m Challenge
forall (m :: * -> *) a.
MonadClientRead m =>
(StateClient -> a) -> m a
getsClient StateClient -> Challenge
snxtChal
    -- This ignores all but the first word of game mode names picked
    -- via main menu and assumes the fist word of such game modes
    -- is present in their frequencies.
    let (mainName :: Text
mainName, _) = (Char -> Bool) -> Text -> (Text, Text)
T.span (\c :: Char
c -> Char -> Bool
Char.isAlpha Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ' ') Text
nxtGameName
        nxtGameGroup :: GroupName ModeKind
nxtGameGroup = Text -> GroupName ModeKind
forall a. Text -> GroupName a
GroupName (Text -> GroupName ModeKind) -> Text -> GroupName ModeKind
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate " " ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
take 2 ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.words Text
mainName
    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
nxtGameGroup Challenge
snxtChal
  else do
    Text
msg2 <- Rnd Text -> m Text
forall (m :: * -> *) a. MonadClientUI m => Rnd a -> m a
rndToActionUI (Rnd Text -> m Text) -> Rnd Text -> m Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Rnd Text
forall a. [a] -> Rnd a
oneOf
              [ "yea, would be a pity to leave them to die"
              , "yea, a shame to get your team stranded" ]
    Text -> m (FailOrCmd ReqUI)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith Text
msg2

-- * GameQuit

-- TODO: deduplicate with gameRestartHuman
gameQuitHuman :: (MonadClient m, MonadClientUI m) => m (FailOrCmd ReqUI)
gameQuitHuman :: m (FailOrCmd ReqUI)
gameQuitHuman = do
  Bool
noConfirmsGame <- m Bool
forall (m :: * -> *). MonadStateRead m => m Bool
isNoConfirmsGame
  ModeKind
gameMode <- m ModeKind
forall (m :: * -> *). MonadStateRead m => m ModeKind
getGameMode
  Bool
b <- if Bool
noConfirmsGame
       then Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
       else ColorMode -> Text -> m Bool
forall (m :: * -> *).
(MonadClient m, MonadClientUI m) =>
ColorMode -> Text -> m Bool
displayYesNo ColorMode
ColorBW
            (Text -> m Bool) -> Text -> m Bool
forall a b. (a -> b) -> a -> b
$ "If you quit, the progress of the ongoing" Text -> Text -> Text
<+> ModeKind -> Text
MK.mname ModeKind
gameMode
              Text -> Text -> Text
<+> "game will be lost! Are you sure?"
  if Bool
b
  then do
    Challenge
snxtChal <- (StateClient -> Challenge) -> m Challenge
forall (m :: * -> *) a.
MonadClientRead m =>
(StateClient -> a) -> m a
getsClient StateClient -> Challenge
snxtChal
    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
MK.INSERT_COIN Challenge
snxtChal
  else do
    Text
msg2 <- Rnd Text -> m Text
forall (m :: * -> *) a. MonadClientUI m => Rnd a -> m a
rndToActionUI (Rnd Text -> m Text) -> Rnd Text -> m Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Rnd Text
forall a. [a] -> Rnd a
oneOf
              [ "yea, would be a pity to leave them to die"
              , "yea, a shame to get your team stranded" ]
    Text -> m (FailOrCmd ReqUI)
forall (m :: * -> *) a. MonadClientUI m => Text -> m (FailOrCmd a)
failWith Text
msg2

-- * GameDrop

gameDropHuman :: (MonadClient m, 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
$ \sess :: SessionUI
sess -> SessionUI
sess {sallNframes :: Int
sallNframes = -1}  -- hack, but we crash anyway
  MsgClassShow -> Text -> m ()
forall (m :: * -> *) a.
(MonadClient m, MonadClientUI m, MsgShared a) =>
a -> Text -> m ()
msgAdd MsgClassShow
MsgPromptGeneric "Interrupt! Trashing the unsaved game. The program exits now."
  Text -> m ()
forall (m :: * -> *). MonadClientUI m => Text -> m ()
clientPrintUI "Interrupt! Trashing the unsaved game. The program exits now."
    -- this is not shown by vty 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 :: (MonadClient m, 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.
(MonadClient m, MonadClientUI m, MsgShared a) =>
a -> Text -> m ()
msgAdd MsgClassSave
MsgInnerWorkSpam "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 :: (MonadClient m, 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
$ Player -> Doctrine
MK.fdoctrine (Player -> Doctrine) -> (State -> Player) -> State -> Doctrine
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Faction -> Player
gplayer (Faction -> Player) -> (State -> Faction) -> State -> Player
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 :: * -> *).
(MonadClient m, MonadClientUI m) =>
ColorMode -> Text -> m Bool
displaySpaceEsc ColorMode
ColorFull
        (Text -> m Bool) -> Text -> m Bool
forall a b. (a -> b) -> a -> b
$ "(Beware, work in progress!)"
          Text -> Text -> Text
<+> "Current squad doctrine is" Text -> Text -> Text
<+> Doctrine -> Text
Ability.nameDoctrine Doctrine
fromT
          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
<+> "Switching doctrine to" Text -> Text -> Text
<+> Doctrine -> Text
Ability.nameDoctrine Doctrine
toT
          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
<+> "This clears targets of all non-pointmen teammates."
          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 "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 :: (MonadClient m, 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 :: * -> *).
(MonadClient m, MonadClientUI m) =>
ColorMode -> Text -> m Bool
displayYesNo ColorMode
ColorBW "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 "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 :: (MonadClient m, 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 "automation canceled"
  else m (FailOrCmd ReqUI)
forall (m :: * -> *).
(MonadClient 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