HandleHumanM.hs

-- | Semantics of human player commands.
module Game.LambdaHack.Client.UI.HandleHumanM
  ( cmdSemInCxtOfKM, updateKeyLast
#ifdef EXPOSE_INTERNAL
    -- * Internal operations
  , noRemoteHumanCmd, CmdLeaderNeed, cmdSemantics, cmdSemanticsLeader
  , addNoError, addLeader, weaveLeader
#endif
  ) where

import Prelude ()

import Game.LambdaHack.Core.Prelude

import           Game.LambdaHack.Client.MonadClient
import           Game.LambdaHack.Client.Request
import           Game.LambdaHack.Client.State
import           Game.LambdaHack.Client.UI.HandleHelperM
import           Game.LambdaHack.Client.UI.HandleHumanGlobalM
import           Game.LambdaHack.Client.UI.HandleHumanLocalM
import           Game.LambdaHack.Client.UI.HumanCmd
import qualified Game.LambdaHack.Client.UI.Key as K
import           Game.LambdaHack.Client.UI.MonadClientUI
import           Game.LambdaHack.Client.UI.SessionUI
import           Game.LambdaHack.Common.Types

-- | Commands that are forbidden on a remote level, because they
-- would usually take time when invoked on one, but not necessarily do
-- what the player expects. Note that some commands that normally take time
-- are not included, because they don't take time in aiming mode
-- or their individual sanity conditions include a remote level check.
noRemoteHumanCmd :: HumanCmd -> Bool
noRemoteHumanCmd cmd = case cmd of
  Wait          -> True
  Wait10        -> True
  MoveItem{}    -> True
  Apply{}       -> True
  AlterDir{}    -> True
  AlterWithPointer{} -> True
  MoveOnceToXhair -> True
  RunOnceToXhair -> True
  ContinueToXhair -> True
  _ -> False

updateKeyLast :: K.KM -> HumanCmd -> KeyMacroFrame -> KeyMacroFrame
updateKeyLast km cmd macroFrame = case cmd of
  RepeatLast{} -> macroFrame
  Record{} -> macroFrame
  _ -> macroFrame {keyLast = Just km}

-- | The semantics of human player commands in terms of the client monad,
-- in context of the given @km@ as the last action.
--
-- Some time cosuming commands are enabled even in aiming mode, but cannot be
-- invoked in aiming mode on a remote level (level different than
-- the level of the leader). Commands that require a pointman fail
-- when no leader is designated.
cmdSemInCxtOfKM :: (MonadClient m, MonadClientUI m)
                => K.KM -> HumanCmd -> m (Either MError ReqUI)
cmdSemInCxtOfKM km cmd = do
  modifySession $ \sess ->
    sess {smacroFrame = updateKeyLast km cmd $ smacroFrame sess}
  cmdSemantics cmd

data CmdLeaderNeed m =
    CmdNoNeed (m (Either MError ReqUI))
  | CmdLeader (ActorId -> m (Either MError ReqUI))

cmdSemantics :: (MonadClient m, MonadClientUI m)
             => HumanCmd -> m (Either MError ReqUI)
cmdSemantics cmd = case cmdSemanticsLeader cmd of
  CmdNoNeed mreq -> mreq
  CmdLeader f -> do
    mleader <- getsClient sleader
    case mleader of
      Nothing -> weaveJust <$> failWith
        "command disabled when no pointman designated, choose another command"
      Just leader -> do
        if noRemoteHumanCmd cmd then do
          -- If in aiming mode, check if the current level is the same
          -- as player level and refuse performing the action otherwise.
          arena <- getArenaUI
          lidV <- viewedLevelUI
          if arena /= lidV then
            weaveJust <$> failWith
              "command disabled on a remote level, press ESC to switch back"
          else f leader
        else f leader

cmdSemanticsLeader :: (MonadClient m, MonadClientUI m)
                   => HumanCmd -> CmdLeaderNeed m
cmdSemanticsLeader cmd = case cmd of
  Macro kms -> addNoError $ macroHuman kms
  ByArea l -> CmdNoNeed $ byAreaHuman cmdSemInCxtOfKM l
  ByAimMode AimModeCmd{..} ->
    CmdNoNeed $ byAimModeHuman (cmdSemantics exploration) (cmdSemantics aiming)
  ComposeIfLocal cmd1 cmd2 ->
    CmdNoNeed $ composeIfLocalHuman (cmdSemantics cmd1) (cmdSemantics cmd2)
  ComposeUnlessError cmd1 cmd2 ->
    CmdNoNeed $ composeUnlessErrorHuman (cmdSemantics cmd1) (cmdSemantics cmd2)
  Compose2ndLocal cmd1 cmd2 ->
    CmdNoNeed $ compose2ndLocalHuman (cmdSemantics cmd1) (cmdSemantics cmd2)
  LoopOnNothing cmd1 -> CmdNoNeed $ loopOnNothingHuman (cmdSemantics cmd1)
  ExecuteIfClear cmd1 -> CmdNoNeed $ executeIfClearHuman (cmdSemantics cmd1)

  Wait -> weaveLeader $ \leader -> ReqUITimed <$$> waitHuman leader
  Wait10 -> weaveLeader $ \leader -> ReqUITimed <$$> waitHuman10 leader
  Yell -> weaveLeader $ \leader -> ReqUITimed <$$> yellHuman leader
  MoveDir v -> weaveLeader $ \leader ->
                 ReqUITimed <$$> moveRunHuman leader True True False False v
  RunDir v -> weaveLeader $ \leader ->
                ReqUITimed <$$> moveRunHuman leader True True True True v
  RunOnceAhead ->
    CmdLeader $ \leader -> ReqUITimed <$$> runOnceAheadHuman leader
  MoveOnceToXhair -> weaveLeader $ \leader ->
                       ReqUITimed <$$> moveOnceToXhairHuman leader
  RunOnceToXhair  -> weaveLeader $ \leader ->
                       ReqUITimed <$$> runOnceToXhairHuman leader
  ContinueToXhair -> weaveLeader $ \leader ->
                       ReqUITimed <$$> continueToXhairHuman leader
  MoveItem stores toCStore mverb auto ->
    weaveLeader $ \leader ->
      ReqUITimed <$$> moveItemHuman leader stores toCStore mverb auto
  Project -> weaveLeader $ \leader -> ReqUITimed <$$> projectHuman leader
  Apply -> weaveLeader $ \leader -> ReqUITimed <$$> applyHuman leader
  AlterDir -> weaveLeader $ \leader -> ReqUITimed <$$> alterDirHuman leader
  AlterWithPointer ->
    weaveLeader $ \leader -> ReqUITimed <$$> alterWithPointerHuman leader
  CloseDir -> weaveLeader $ \leader -> ReqUITimed <$$> closeDirHuman leader
  Help -> CmdNoNeed $ helpHuman cmdSemInCxtOfKM
  Hint -> CmdNoNeed $ hintHuman cmdSemInCxtOfKM
  ItemMenu -> CmdLeader $ \leader -> itemMenuHuman leader cmdSemInCxtOfKM
  ChooseItemMenu dialogMode ->
    CmdLeader $ \leader -> chooseItemMenuHuman leader cmdSemInCxtOfKM dialogMode
  MainMenu -> CmdNoNeed $ mainMenuHuman cmdSemInCxtOfKM
  MainMenuAutoOn -> CmdNoNeed $ mainMenuAutoOnHuman cmdSemInCxtOfKM
  MainMenuAutoOff -> CmdNoNeed $ mainMenuAutoOffHuman cmdSemInCxtOfKM
  Dashboard -> CmdNoNeed $ dashboardHuman cmdSemInCxtOfKM
  GameDifficultyIncr delta ->
    CmdNoNeed $ gameDifficultyIncr delta >> challengeMenuHuman cmdSemInCxtOfKM
  GameFishToggle ->
    CmdNoNeed $ gameFishToggle >> challengeMenuHuman cmdSemInCxtOfKM
  GameGoodsToggle ->
    CmdNoNeed $ gameGoodsToggle >> challengeMenuHuman cmdSemInCxtOfKM
  GameWolfToggle ->
    CmdNoNeed $ gameWolfToggle >> challengeMenuHuman cmdSemInCxtOfKM
  GameKeeperToggle ->
    CmdNoNeed $ gameKeeperToggle >> challengeMenuHuman cmdSemInCxtOfKM
  GameScenarioIncr delta ->
    CmdNoNeed $ gameScenarioIncr delta >> challengeMenuHuman cmdSemInCxtOfKM

  GameRestart -> CmdNoNeed $ weaveJust <$> gameExitWithHuman Restart
  GameQuit -> CmdNoNeed $ weaveJust <$> gameExitWithHuman Quit
  GameDrop -> CmdNoNeed $ weaveJust <$> fmap Right gameDropHuman
  GameExit -> CmdNoNeed $ weaveJust <$> fmap Right gameExitHuman
  GameSave -> CmdNoNeed $ weaveJust <$> fmap Right gameSaveHuman
  Doctrine -> CmdNoNeed $ weaveJust <$> doctrineHuman
  Automate -> CmdNoNeed $ weaveJust <$> automateHuman
  AutomateToggle -> CmdNoNeed $ weaveJust <$> automateToggleHuman
  AutomateBack -> CmdNoNeed automateBackHuman

  ChooseItem dialogMode ->
    CmdLeader $ \leader -> Left <$> chooseItemHuman leader dialogMode
  ChooseItemProject ts ->
    CmdLeader $ \leader -> Left <$> chooseItemProjectHuman leader ts
  ChooseItemApply ts ->
    CmdLeader $ \leader -> Left <$> chooseItemApplyHuman leader ts
  PickLeader k -> CmdNoNeed $ Left <$> pickLeaderHuman k
  PickLeaderWithPointer ->
    CmdLeader $ fmap Left . pickLeaderWithPointerHuman
  PointmanCycle direction ->
    CmdLeader $ \leader -> Left <$> pointmanCycleHuman leader direction
  PointmanCycleLevel direction ->
    CmdLeader $ \leader -> Left <$> pointmanCycleLevelHuman leader direction
  SelectActor -> addLeader selectActorHuman
  SelectNone -> addNoError selectNoneHuman
  SelectWithPointer -> CmdNoNeed $ Left <$> selectWithPointerHuman
  Repeat n -> addNoError $ repeatHuman n
  RepeatLast n -> addNoError $ repeatLastHuman n
  Record -> addNoError recordHuman
  AllHistory -> addNoError allHistoryHuman
  MarkVision delta ->
    CmdNoNeed $ markVisionHuman delta >> settingsMenuHuman cmdSemInCxtOfKM
  MarkSmell ->
    CmdNoNeed $ markSmellHuman >> settingsMenuHuman cmdSemInCxtOfKM
  MarkSuspect delta ->
    CmdNoNeed $ markSuspectHuman delta >> settingsMenuHuman cmdSemInCxtOfKM
  MarkAnim ->
    CmdNoNeed $ markAnimHuman >> settingsMenuHuman cmdSemInCxtOfKM
  OverrideTut delta ->
    CmdNoNeed $ overrideTutHuman delta >> settingsMenuHuman cmdSemInCxtOfKM
  SettingsMenu -> CmdNoNeed $ settingsMenuHuman cmdSemInCxtOfKM
  ChallengeMenu -> CmdNoNeed $ challengeMenuHuman cmdSemInCxtOfKM
  PrintScreen -> addNoError printScreenHuman

  Cancel -> addNoError cancelHuman
  Accept -> addLeader acceptHuman
  DetailCycle -> addNoError detailCycleHuman
  ClearTargetIfItemClear -> addLeader clearTargetIfItemClearHuman
  ItemClear -> addNoError itemClearHuman
  MoveXhair v k -> CmdNoNeed $ Left <$> moveXhairHuman v k
  AimTgt -> addNoError aimTgtHuman
  AimFloor -> addNoError aimFloorHuman
  AimEnemy -> addNoError aimEnemyHuman
  AimItem -> addNoError aimItemHuman
  AimAscend k -> CmdNoNeed $ Left <$> aimAscendHuman k
  EpsIncr b -> addNoError $ epsIncrHuman b
  XhairUnknown -> CmdLeader $ fmap Left . xhairUnknownHuman
  XhairItem -> CmdLeader $ fmap Left . xhairItemHuman
  XhairStair up -> CmdLeader $ \leader -> Left <$> xhairStairHuman leader up
  XhairPointerFloor -> addNoError xhairPointerFloorHuman
  XhairPointerMute -> addNoError xhairPointerMuteHuman
  XhairPointerEnemy -> addNoError xhairPointerEnemyHuman
  AimPointerFloor -> addNoError aimPointerFloorHuman
  AimPointerEnemy -> addNoError aimPointerEnemyHuman

addNoError :: Monad m => m () -> CmdLeaderNeed m
addNoError cmdCli = CmdNoNeed $ cmdCli >> return (Left Nothing)

addLeader :: Monad m => (ActorId -> m ()) -> CmdLeaderNeed m
addLeader cmdCli =
  CmdLeader $ \leader -> cmdCli leader >> return (Left Nothing)

weaveLeader :: Monad m => (ActorId -> m (FailOrCmd ReqUI)) -> CmdLeaderNeed m
weaveLeader cmdCli = CmdLeader $ fmap weaveJust . cmdCli