{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module Swarm.TUI.Model.StateUpdate (
  initAppState,
  startGame,
  restartGame,
  attainAchievement,
  attainAchievement',
  scenarioToAppState,
) where

import Brick.AttrMap (applyAttrMappings)
import Control.Applicative ((<|>))
import Control.Lens hiding (from, (<.>))
import Control.Monad.Except
import Control.Monad.State
import Data.List qualified as List
import Data.Map qualified as M
import Data.Maybe (fromMaybe, isJust)
import Data.Text (Text)
import Data.Time (ZonedTime, getZonedTime)
import Swarm.Game.Log (ErrorLevel (..), LogSource (ErrorTrace))
import Swarm.Game.Scenario (loadScenario, scenarioAttrs)
import Swarm.Game.Scenario.Objective.Presentation.Model (emptyGoalDisplay)
import Swarm.Game.ScenarioInfo (
  ScenarioInfo (..),
  ScenarioInfoPair,
  ScenarioStatus (..),
  normalizeScenarioPath,
  scenarioItemByPath,
  scenarioPath,
  scenarioSolution,
  scenarioStatus,
  _SISingle,
 )
import Swarm.Game.State
import Swarm.TUI.Attr (swarmAttrMap)
import Swarm.TUI.Inventory.Sorting
import Swarm.TUI.Model
import Swarm.TUI.Model.Achievement.Attainment
import Swarm.TUI.Model.Achievement.Definitions
import Swarm.TUI.Model.Achievement.Persistence
import Swarm.TUI.Model.Failure (prettyFailure)
import Swarm.TUI.Model.Repl
import Swarm.TUI.Model.UI
import Swarm.TUI.View.CustomStyling (toAttrPair)
import System.Clock

-- | Initialize the 'AppState'.
initAppState :: AppOpts -> ExceptT Text IO AppState
initAppState :: AppOpts -> ExceptT Text IO AppState
initAppState AppOpts {Bool
Maybe Port
Maybe String
Maybe GitInfo
Maybe ColorMode
repoGitInfo :: AppOpts -> Maybe GitInfo
userWebPort :: AppOpts -> Maybe Port
colorMode :: AppOpts -> Maybe ColorMode
cheatMode :: AppOpts -> Bool
autoPlay :: AppOpts -> Bool
scriptToRun :: AppOpts -> Maybe String
userScenario :: AppOpts -> Maybe String
userSeed :: AppOpts -> Maybe Port
repoGitInfo :: Maybe GitInfo
userWebPort :: Maybe Port
colorMode :: Maybe ColorMode
cheatMode :: Bool
autoPlay :: Bool
scriptToRun :: Maybe String
userScenario :: Maybe String
userSeed :: Maybe Port
..} = do
  let isRunningInitialProgram :: Bool
isRunningInitialProgram = forall a. Maybe a -> Bool
isJust Maybe String
scriptToRun Bool -> Bool -> Bool
|| Bool
autoPlay
      skipMenu :: Bool
skipMenu = forall a. Maybe a -> Bool
isJust Maybe String
userScenario Bool -> Bool -> Bool
|| Bool
isRunningInitialProgram Bool -> Bool -> Bool
|| forall a. Maybe a -> Bool
isJust Maybe Port
userSeed
  GameState
gs <- ExceptT Text IO GameState
initGameState
  ([SystemFailure]
warnings, UIState
ui) <- Bool -> Bool -> ExceptT Text IO ([SystemFailure], UIState)
initUIState (Bool -> Bool
not Bool
skipMenu) Bool
cheatMode
  let logWarning :: RuntimeState -> SystemFailure -> RuntimeState
logWarning RuntimeState
rs SystemFailure
w = RuntimeState
rs forall a b. a -> (a -> b) -> b
& Lens' RuntimeState (Notifications LogEntry)
eventLog forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ LogSource
-> (Text, Port)
-> Text
-> Notifications LogEntry
-> Notifications LogEntry
logEvent (ErrorLevel -> LogSource
ErrorTrace ErrorLevel
Error) (Text
"UI Loading", -Port
8) (SystemFailure -> Text
prettyFailure SystemFailure
w)
  let rs :: RuntimeState
rs = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' RuntimeState -> SystemFailure -> RuntimeState
logWarning RuntimeState
initRuntimeState [SystemFailure]
warnings
  case Bool
skipMenu of
    Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ GameState -> UIState -> RuntimeState -> AppState
AppState GameState
gs UIState
ui RuntimeState
rs
    Bool
True -> do
      (Scenario
scenario, String
path) <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Lift IO) sig m, Has (Throw Text) sig m) =>
String -> EntityMap -> m (Scenario, String)
loadScenario (forall a. a -> Maybe a -> a
fromMaybe String
"classic" Maybe String
userScenario) (GameState
gs forall s a. s -> Getting a s a -> a
^. Lens' GameState EntityMap
entityMap)

      let maybeAutoplay :: Maybe CodeToRun
maybeAutoplay = do
            forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
autoPlay
            ProcessedTerm
soln <- Scenario
scenario forall s a. s -> Getting a s a -> a
^. Lens' Scenario (Maybe ProcessedTerm)
scenarioSolution
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ProcessedTerm -> CodeToRun
SuggestedSolution ProcessedTerm
soln
      let realToRun :: Maybe CodeToRun
realToRun = Maybe CodeToRun
maybeAutoplay forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (String -> CodeToRun
ScriptPath forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
scriptToRun)

      forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT
        (forall (m :: * -> *).
(MonadIO m, MonadState AppState m) =>
Maybe Port -> ScenarioInfoPair -> Maybe CodeToRun -> m ()
startGameWithSeed Maybe Port
userSeed (Scenario
scenario, String
-> ScenarioStatus
-> ScenarioStatus
-> ScenarioStatus
-> ScenarioInfo
ScenarioInfo String
path ScenarioStatus
NotStarted ScenarioStatus
NotStarted ScenarioStatus
NotStarted) Maybe CodeToRun
realToRun)
        (GameState -> UIState -> RuntimeState -> AppState
AppState GameState
gs UIState
ui RuntimeState
rs)

-- | Load a 'Scenario' and start playing the game.
startGame :: (MonadIO m, MonadState AppState m) => ScenarioInfoPair -> Maybe CodeToRun -> m ()
startGame :: forall (m :: * -> *).
(MonadIO m, MonadState AppState m) =>
ScenarioInfoPair -> Maybe CodeToRun -> m ()
startGame = forall (m :: * -> *).
(MonadIO m, MonadState AppState m) =>
Maybe Port -> ScenarioInfoPair -> Maybe CodeToRun -> m ()
startGameWithSeed forall a. Maybe a
Nothing

-- | Re-initialize the game from the stored reference to the current scenario.
--
-- Note that "restarting" is intended only for "scenarios";
-- with some scenarios, it may be possible to get stuck so that it is
-- either impossible or very annoying to win, so being offered an
-- option to restart is more user-friendly.
--
-- Since scenarios are stored as a Maybe in the UI state, we handle the Nothing
-- case upstream so that the Scenario passed to this function definitely exists.
restartGame :: (MonadIO m, MonadState AppState m) => Seed -> ScenarioInfoPair -> m ()
restartGame :: forall (m :: * -> *).
(MonadIO m, MonadState AppState m) =>
Port -> ScenarioInfoPair -> m ()
restartGame Port
currentSeed ScenarioInfoPair
siPair = forall (m :: * -> *).
(MonadIO m, MonadState AppState m) =>
Maybe Port -> ScenarioInfoPair -> Maybe CodeToRun -> m ()
startGameWithSeed (forall a. a -> Maybe a
Just Port
currentSeed) ScenarioInfoPair
siPair forall a. Maybe a
Nothing

-- | Load a 'Scenario' and start playing the game, with the
--   possibility for the user to override the seed.
startGameWithSeed :: (MonadIO m, MonadState AppState m) => Maybe Seed -> ScenarioInfoPair -> Maybe CodeToRun -> m ()
startGameWithSeed :: forall (m :: * -> *).
(MonadIO m, MonadState AppState m) =>
Maybe Port -> ScenarioInfoPair -> Maybe CodeToRun -> m ()
startGameWithSeed Maybe Port
userSeed siPair :: ScenarioInfoPair
siPair@(Scenario
_scene, ScenarioInfo
si) Maybe CodeToRun
toRun = do
  ZonedTime
t <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ZonedTime
getZonedTime
  ScenarioCollection
ss <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use forall a b. (a -> b) -> a -> b
$ Lens' AppState GameState
gameState forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' GameState ScenarioCollection
scenarios
  String
p <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ScenarioCollection -> String -> IO String
normalizeScenarioPath ScenarioCollection
ss (ScenarioInfo
si forall s a. s -> Getting a s a -> a
^. Lens' ScenarioInfo String
scenarioPath)
  Lens' AppState GameState
gameState forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' GameState (Maybe String)
currentScenarioPath forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= forall a. a -> Maybe a
Just String
p
  Lens' AppState GameState
gameState forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' GameState ScenarioCollection
scenarios forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Traversal' ScenarioCollection ScenarioItem
scenarioItemByPath String
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prism' ScenarioItem ScenarioInfoPair
_SISingle forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field2 s t a b => Lens s t a b
_2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' ScenarioInfo ScenarioStatus
scenarioStatus forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= ZonedTime -> NominalDiffTime -> Integer -> ScenarioStatus
InProgress ZonedTime
t NominalDiffTime
0 Integer
0
  forall (m :: * -> *).
(MonadIO m, MonadState AppState m) =>
ScenarioInfoPair -> Maybe Port -> Maybe CodeToRun -> m ()
scenarioToAppState ScenarioInfoPair
siPair Maybe Port
userSeed Maybe CodeToRun
toRun

-- TODO: #516 do we need to keep an old entity map around???

-- | Modify the 'AppState' appropriately when starting a new scenario.
scenarioToAppState ::
  (MonadIO m, MonadState AppState m) =>
  ScenarioInfoPair ->
  Maybe Seed ->
  Maybe CodeToRun ->
  m ()
scenarioToAppState :: forall (m :: * -> *).
(MonadIO m, MonadState AppState m) =>
ScenarioInfoPair -> Maybe Port -> Maybe CodeToRun -> m ()
scenarioToAppState siPair :: ScenarioInfoPair
siPair@(Scenario
scene, ScenarioInfo
_) Maybe Port
userSeed Maybe CodeToRun
toRun = do
  forall (m :: * -> *) x.
(MonadIO m, MonadState AppState m) =>
Lens' AppState x -> (x -> IO x) -> m ()
withLensIO Lens' AppState GameState
gameState forall a b. (a -> b) -> a -> b
$ Scenario
-> Maybe Port -> Maybe CodeToRun -> GameState -> IO GameState
scenarioToGameState Scenario
scene Maybe Port
userSeed Maybe CodeToRun
toRun
  forall (m :: * -> *) x.
(MonadIO m, MonadState AppState m) =>
Lens' AppState x -> (x -> IO x) -> m ()
withLensIO Lens' AppState UIState
uiState forall a b. (a -> b) -> a -> b
$ ScenarioInfoPair -> UIState -> IO UIState
scenarioToUIState ScenarioInfoPair
siPair
 where
  withLensIO :: (MonadIO m, MonadState AppState m) => Lens' AppState x -> (x -> IO x) -> m ()
  withLensIO :: forall (m :: * -> *) x.
(MonadIO m, MonadState AppState m) =>
Lens' AppState x -> (x -> IO x) -> m ()
withLensIO Lens' AppState x
l x -> IO x
a = do
    x
x <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' AppState x
l
    x
x' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ x -> IO x
a x
x
    Lens' AppState x
l forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= x
x'

attainAchievement :: (MonadIO m, MonadState AppState m) => CategorizedAchievement -> m ()
attainAchievement :: forall (m :: * -> *).
(MonadIO m, MonadState AppState m) =>
CategorizedAchievement -> m ()
attainAchievement CategorizedAchievement
a = do
  ZonedTime
currentTime <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ZonedTime
getZonedTime
  forall (m :: * -> *).
(MonadIO m, MonadState AppState m) =>
ZonedTime -> Maybe String -> CategorizedAchievement -> m ()
attainAchievement' ZonedTime
currentTime forall a. Maybe a
Nothing CategorizedAchievement
a

attainAchievement' ::
  (MonadIO m, MonadState AppState m) =>
  ZonedTime ->
  Maybe FilePath ->
  CategorizedAchievement ->
  m ()
attainAchievement' :: forall (m :: * -> *).
(MonadIO m, MonadState AppState m) =>
ZonedTime -> Maybe String -> CategorizedAchievement -> m ()
attainAchievement' ZonedTime
t Maybe String
p CategorizedAchievement
a = do
  (Lens' AppState UIState
uiState forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' UIState (Map CategorizedAchievement Attainment)
uiAchievements)
    forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith
      forall a. Semigroup a => a -> a -> a
(<>)
      CategorizedAchievement
a
      (CategorizedAchievement -> Maybe String -> ZonedTime -> Attainment
Attainment CategorizedAchievement
a Maybe String
p ZonedTime
t)
  Map CategorizedAchievement Attainment
newAchievements <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use forall a b. (a -> b) -> a -> b
$ Lens' AppState UIState
uiState forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' UIState (Map CategorizedAchievement Attainment)
uiAchievements
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Attainment] -> IO ()
saveAchievementsInfo forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
M.elems Map CategorizedAchievement Attainment
newAchievements

-- | Modify the UI state appropriately when starting a new scenario.
scenarioToUIState :: ScenarioInfoPair -> UIState -> IO UIState
scenarioToUIState :: ScenarioInfoPair -> UIState -> IO UIState
scenarioToUIState ScenarioInfoPair
siPair UIState
u = do
  TimeSpec
curTime <- Clock -> IO TimeSpec
getTime Clock
Monotonic
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
    UIState
u
      forall a b. a -> (a -> b) -> b
& Lens' UIState Bool
uiPlaying forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
True
      forall a b. a -> (a -> b) -> b
& Lens' UIState GoalDisplay
uiGoal forall s t a b. ASetter s t a b -> b -> s -> t
.~ GoalDisplay
emptyGoalDisplay
      forall a b. a -> (a -> b) -> b
& Lens' UIState (FocusRing Name)
uiFocusRing forall s t a b. ASetter s t a b -> b -> s -> t
.~ FocusRing Name
initFocusRing
      forall a b. a -> (a -> b) -> b
& Lens' UIState (Maybe (Port, List Name InventoryListEntry))
uiInventory forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. Maybe a
Nothing
      forall a b. a -> (a -> b) -> b
& Lens' UIState InventorySortOptions
uiInventorySort forall s t a b. ASetter s t a b -> b -> s -> t
.~ InventorySortOptions
defaultSortOptions
      forall a b. a -> (a -> b) -> b
& Lens' UIState Bool
uiShowFPS forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
False
      forall a b. a -> (a -> b) -> b
& Lens' UIState Bool
uiShowZero forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
True
      forall a b. a -> (a -> b) -> b
& Lens' UIState Port
lgTicksPerSecond forall s t a b. ASetter s t a b -> b -> s -> t
.~ Port
initLgTicksPerSecond
      forall a b. a -> (a -> b) -> b
& Lens' UIState REPLState
uiREPL forall s t a b. ASetter s t a b -> b -> s -> t
.~ REPLHistory -> REPLState
initREPLState (UIState
u forall s a. s -> Getting a s a -> a
^. Lens' UIState REPLState
uiREPL forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' REPLState REPLHistory
replHistory)
      forall a b. a -> (a -> b) -> b
& Lens' UIState REPLState
uiREPL forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' REPLState REPLHistory
replHistory forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ REPLHistory -> REPLHistory
restartREPLHistory
      forall a b. a -> (a -> b) -> b
& Lens' UIState AttrMap
uiAttrMap forall s t a b. ASetter s t a b -> b -> s -> t
.~ [(AttrName, Attr)] -> AttrMap -> AttrMap
applyAttrMappings (forall a b. (a -> b) -> [a] -> [b]
map CustomAttr -> (AttrName, Attr)
toAttrPair forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst ScenarioInfoPair
siPair forall s a. s -> Getting a s a -> a
^. Lens' Scenario [CustomAttr]
scenarioAttrs) AttrMap
swarmAttrMap
      forall a b. a -> (a -> b) -> b
& Lens' UIState (Maybe ScenarioInfoPair)
scenarioRef forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ ScenarioInfoPair
siPair
      forall a b. a -> (a -> b) -> b
& Lens' UIState TimeSpec
lastFrameTime forall s t a b. ASetter s t a b -> b -> s -> t
.~ TimeSpec
curTime