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

-- |
-- SPDX-License-Identifier: BSD-3-Clause
module Swarm.TUI.Model.StateUpdate (
  initAppState,
  initPersistentState,
  constructAppState,
  initAppStateForScenario,
  classicGame0,
  startGame,
  startGameWithSeed,
  restartGame,
  attainAchievement,
  attainAchievement',
  scenarioToAppState,
) where

import Brick.AttrMap (applyAttrMappings)
import Brick.Widgets.List qualified as BL
import Control.Applicative ((<|>))
import Control.Carrier.Accum.FixedStrict (runAccum)
import Control.Carrier.Lift (runM)
import Control.Carrier.Throw.Either (runThrow)
import Control.Effect.Accum
import Control.Effect.Lift
import Control.Effect.Throw
import Control.Lens hiding (from, (<.>))
import Control.Monad (guard, void)
import Control.Monad.Except (ExceptT (..))
import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.State (MonadState, execStateT)
import Data.Foldable qualified as F
import Data.List qualified as List
import Data.List.NonEmpty qualified as NE
import Data.Map qualified as M
import Data.Maybe (fromMaybe, isJust)
import Data.Sequence (Seq)
import Data.Text (Text)
import Data.Time (ZonedTime, getZonedTime)
import Swarm.Game.Achievement.Attainment
import Swarm.Game.Achievement.Definitions
import Swarm.Game.Achievement.Persistence
import Swarm.Game.Failure (SystemFailure)
import Swarm.Game.Scenario (loadScenario, scenarioAttrs, scenarioWorlds)
import Swarm.Game.Scenario.Scoring.Best
import Swarm.Game.Scenario.Scoring.ConcreteMetrics
import Swarm.Game.Scenario.Scoring.GenericMetrics
import Swarm.Game.Scenario.Status
import Swarm.Game.ScenarioInfo (
  loadScenarioInfo,
  normalizeScenarioPath,
  scenarioItemByPath,
  scenarioSolution,
  _SISingle,
 )
import Swarm.Game.State
import Swarm.Language.Pretty (prettyText)
import Swarm.Log (LogSource (SystemLog), Severity (..))
import Swarm.TUI.Editor.Model qualified as EM
import Swarm.TUI.Editor.Util qualified as EU
import Swarm.TUI.Inventory.Sorting
import Swarm.TUI.Launch.Model (toSerializableParams)
import Swarm.TUI.Model
import Swarm.TUI.Model.Goal (emptyGoalDisplay)
import Swarm.TUI.Model.Repl
import Swarm.TUI.Model.UI
import Swarm.TUI.View.Attribute.Attr (swarmAttrMap)
import Swarm.TUI.View.Attribute.CustomStyling (toAttrPair)
import Swarm.Util.Effect (asExceptT, withThrow)
import System.Clock

-- | Initialize the 'AppState' from scratch.
initAppState ::
  (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
  AppOpts ->
  m AppState
initAppState :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
AppOpts -> m AppState
initAppState AppOpts
opts = do
  (RuntimeState
rs, UIState
ui) <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
AppOpts -> m (RuntimeState, UIState)
initPersistentState AppOpts
opts
  forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
RuntimeState -> UIState -> AppOpts -> m AppState
constructAppState RuntimeState
rs UIState
ui AppOpts
opts

-- | Add some system failures to the list of messages in the
--   'RuntimeState'.
addWarnings :: RuntimeState -> [SystemFailure] -> RuntimeState
addWarnings :: RuntimeState -> [SystemFailure] -> RuntimeState
addWarnings = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' forall {a}. PrettyPrec a => RuntimeState -> a -> RuntimeState
logWarning
 where
  logWarning :: RuntimeState -> a -> RuntimeState
logWarning RuntimeState
rs' a
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
-> Severity
-> Text
-> Text
-> Notifications LogEntry
-> Notifications LogEntry
logEvent LogSource
SystemLog Severity
Error Text
"UI Loading" (forall a. PrettyPrec a => a -> Text
prettyText a
w)

-- | Based on the command line options, should we skip displaying the
--   menu?
skipMenu :: AppOpts -> Bool
skipMenu :: AppOpts -> Bool
skipMenu AppOpts {Bool
Seed
Maybe Seed
Maybe FilePath
Maybe GitInfo
Maybe ColorMode
repoGitInfo :: AppOpts -> Maybe GitInfo
userWebPort :: AppOpts -> Maybe Seed
colorMode :: AppOpts -> Maybe ColorMode
cheatMode :: AppOpts -> Bool
speed :: AppOpts -> Seed
autoPlay :: AppOpts -> Bool
scriptToRun :: AppOpts -> Maybe FilePath
userScenario :: AppOpts -> Maybe FilePath
userSeed :: AppOpts -> Maybe Seed
repoGitInfo :: Maybe GitInfo
userWebPort :: Maybe Seed
colorMode :: Maybe ColorMode
cheatMode :: Bool
speed :: Seed
autoPlay :: Bool
scriptToRun :: Maybe FilePath
userScenario :: Maybe FilePath
userSeed :: Maybe Seed
..} = forall a. Maybe a -> Bool
isJust Maybe FilePath
userScenario Bool -> Bool -> Bool
|| Bool
isRunningInitialProgram Bool -> Bool -> Bool
|| forall a. Maybe a -> Bool
isJust Maybe Seed
userSeed
 where
  isRunningInitialProgram :: Bool
isRunningInitialProgram = forall a. Maybe a -> Bool
isJust Maybe FilePath
scriptToRun Bool -> Bool -> Bool
|| Bool
autoPlay

-- | Initialize the more persistent parts of the app state, /i.e./ the
--   'RuntimeState' and 'UIState'.  This is split out into a separate
--   function so that in the integration test suite we can call this
--   once and reuse the resulting states for all tests.
initPersistentState ::
  (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
  AppOpts ->
  m (RuntimeState, UIState)
initPersistentState :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
AppOpts -> m (RuntimeState, UIState)
initPersistentState opts :: AppOpts
opts@(AppOpts {Bool
Seed
Maybe Seed
Maybe FilePath
Maybe GitInfo
Maybe ColorMode
repoGitInfo :: Maybe GitInfo
userWebPort :: Maybe Seed
colorMode :: Maybe ColorMode
cheatMode :: Bool
speed :: Seed
autoPlay :: Bool
scriptToRun :: Maybe FilePath
userScenario :: Maybe FilePath
userSeed :: Maybe Seed
repoGitInfo :: AppOpts -> Maybe GitInfo
userWebPort :: AppOpts -> Maybe Seed
colorMode :: AppOpts -> Maybe ColorMode
cheatMode :: AppOpts -> Bool
speed :: AppOpts -> Seed
autoPlay :: AppOpts -> Bool
scriptToRun :: AppOpts -> Maybe FilePath
userScenario :: AppOpts -> Maybe FilePath
userSeed :: AppOpts -> Maybe Seed
..}) = do
  (Seq SystemFailure
warnings :: Seq SystemFailure, (RuntimeState
initRS, UIState
initUI)) <- forall w (m :: * -> *) a. w -> AccumC w m a -> m (w, a)
runAccum forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$ do
    RuntimeState
rs <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Throw SystemFailure) sig m,
 Has (Accum (Seq SystemFailure)) sig m, Has (Lift IO) sig m) =>
m RuntimeState
initRuntimeState
    UIState
ui <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Accum (Seq SystemFailure)) sig m, Has (Lift IO) sig m) =>
Seed -> Bool -> Bool -> m UIState
initUIState Seed
speed (Bool -> Bool
not (AppOpts -> Bool
skipMenu AppOpts
opts)) Bool
cheatMode
    forall (m :: * -> *) a. Monad m => a -> m a
return (RuntimeState
rs, UIState
ui)
  let initRS' :: RuntimeState
initRS' = RuntimeState -> [SystemFailure] -> RuntimeState
addWarnings RuntimeState
initRS (forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList Seq SystemFailure
warnings)
  forall (m :: * -> *) a. Monad m => a -> m a
return (RuntimeState
initRS', UIState
initUI)

-- | Construct an 'AppState' from an already-loaded 'RuntimeState' and
--   'UIState', given the 'AppOpts' the app was started with.
constructAppState ::
  (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
  RuntimeState ->
  UIState ->
  AppOpts ->
  m AppState
constructAppState :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
RuntimeState -> UIState -> AppOpts -> m AppState
constructAppState RuntimeState
rs UIState
ui opts :: AppOpts
opts@(AppOpts {Bool
Seed
Maybe Seed
Maybe FilePath
Maybe GitInfo
Maybe ColorMode
repoGitInfo :: Maybe GitInfo
userWebPort :: Maybe Seed
colorMode :: Maybe ColorMode
cheatMode :: Bool
speed :: Seed
autoPlay :: Bool
scriptToRun :: Maybe FilePath
userScenario :: Maybe FilePath
userSeed :: Maybe Seed
repoGitInfo :: AppOpts -> Maybe GitInfo
userWebPort :: AppOpts -> Maybe Seed
colorMode :: AppOpts -> Maybe ColorMode
cheatMode :: AppOpts -> Bool
speed :: AppOpts -> Seed
autoPlay :: AppOpts -> Bool
scriptToRun :: AppOpts -> Maybe FilePath
userScenario :: AppOpts -> Maybe FilePath
userSeed :: AppOpts -> Maybe Seed
..}) = do
  let gs :: GameState
gs = GameStateConfig -> GameState
initGameState (RuntimeState -> GameStateConfig
mkGameStateConfig RuntimeState
rs)
  case AppOpts -> Bool
skipMenu AppOpts
opts 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 forall a b. a -> (a -> b) -> b
& Lens' UIState Seed
lgTicksPerSecond forall s t a b. ASetter s t a b -> b -> s -> t
.~ Seed
defaultInitLgTicksPerSecond) RuntimeState
rs
    Bool
True -> do
      (Scenario
scenario, FilePath
path) <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
FilePath -> EntityMap -> WorldMap -> m (Scenario, FilePath)
loadScenario (forall a. a -> Maybe a -> a
fromMaybe FilePath
"classic" Maybe FilePath
userScenario) (GameState
gs forall s a. s -> Getting a s a -> a
^. Lens' GameState Landscape
landscape forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Landscape EntityMap
entityMap) (RuntimeState
rs forall s a. s -> Getting a s a -> a
^. Lens' RuntimeState WorldMap
worlds)
      Maybe CodeToRun
maybeRunScript <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
FilePath -> m CodeToRun
parseCodeFile Maybe FilePath
scriptToRun

      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
$ SolutionSource -> ProcessedTerm -> CodeToRun
CodeToRun SolutionSource
ScenarioSuggested ProcessedTerm
soln
          codeToRun :: Maybe CodeToRun
codeToRun = Maybe CodeToRun
maybeAutoplay forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe CodeToRun
maybeRunScript

      Either SystemFailure ScenarioInfo
eitherSi <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Lift IO) sig m =>
IO a -> m a
sendIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. LiftC m a -> m a
runM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. ThrowC e m a -> m (Either e a)
runThrow forall a b. (a -> b) -> a -> b
$ forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
FilePath -> m ScenarioInfo
loadScenarioInfo FilePath
path
      let (ScenarioInfo
si, RuntimeState
newRs) = case Either SystemFailure ScenarioInfo
eitherSi of
            Right ScenarioInfo
x -> (ScenarioInfo
x, RuntimeState
rs)
            Left SystemFailure
e -> (FilePath -> ScenarioStatus -> ScenarioInfo
ScenarioInfo FilePath
path ScenarioStatus
NotStarted, RuntimeState -> [SystemFailure] -> RuntimeState
addWarnings RuntimeState
rs [SystemFailure
e])
      forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Lift IO) sig m =>
IO a -> m a
sendIO forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT
          (forall (m :: * -> *).
(MonadIO m, MonadState AppState m) =>
ScenarioInfoPair -> ValidatedLaunchParams -> m ()
startGameWithSeed (Scenario
scenario, ScenarioInfo
si) forall a b. (a -> b) -> a -> b
$ forall code (f :: * -> *).
f (Maybe Seed)
-> f (Maybe code) -> ParameterizableLaunchParams code f
LaunchParams (forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Seed
userSeed) (forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe CodeToRun
codeToRun))
          (GameState -> UIState -> RuntimeState -> AppState
AppState GameState
gs UIState
ui RuntimeState
newRs)

-- | 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 ScenarioInfoPair
siPair = forall (m :: * -> *).
(MonadIO m, MonadState AppState m) =>
ScenarioInfoPair -> ValidatedLaunchParams -> m ()
startGameWithSeed ScenarioInfoPair
siPair forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall code (f :: * -> *).
f (Maybe Seed)
-> f (Maybe code) -> ParameterizableLaunchParams code f
LaunchParams (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | 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) =>
Seed -> ScenarioInfoPair -> m ()
restartGame Seed
currentSeed ScenarioInfoPair
siPair = forall (m :: * -> *).
(MonadIO m, MonadState AppState m) =>
ScenarioInfoPair -> ValidatedLaunchParams -> m ()
startGameWithSeed ScenarioInfoPair
siPair forall a b. (a -> b) -> a -> b
$ forall code (f :: * -> *).
f (Maybe Seed)
-> f (Maybe code) -> ParameterizableLaunchParams code f
LaunchParams (forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just Seed
currentSeed)) (forall (f :: * -> *) a. Applicative f => a -> f a
pure 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) =>
  ScenarioInfoPair ->
  ValidatedLaunchParams ->
  m ()
startGameWithSeed :: forall (m :: * -> *).
(MonadIO m, MonadState AppState m) =>
ScenarioInfoPair -> ValidatedLaunchParams -> m ()
startGameWithSeed siPair :: ScenarioInfoPair
siPair@(Scenario
_scene, ScenarioInfo
si) ValidatedLaunchParams
lp = 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 RuntimeState
runtimeState forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' RuntimeState ScenarioCollection
scenarios
  FilePath
p <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
ScenarioCollection -> FilePath -> m FilePath
normalizeScenarioPath ScenarioCollection
ss (ScenarioInfo
si forall s a. s -> Getting a s a -> a
^. Lens' ScenarioInfo FilePath
scenarioPath)
  Lens' AppState RuntimeState
runtimeState
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' RuntimeState ScenarioCollection
scenarios
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Traversal' ScenarioCollection ScenarioItem
scenarioItemByPath FilePath
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 ()
.= SerializableLaunchParams
-> ProgressMetric -> BestRecords -> ScenarioStatus
Played
      (ValidatedLaunchParams -> SerializableLaunchParams
toSerializableParams ValidatedLaunchParams
lp)
      (forall a. Progress -> a -> Metric a
Metric Progress
Attempted forall a b. (a -> b) -> a -> b
$ ZonedTime -> AttemptMetrics -> ProgressStats
ProgressStats ZonedTime
t AttemptMetrics
emptyAttemptMetric)
      (ZonedTime -> BestRecords
prevBest ZonedTime
t)
  forall (m :: * -> *).
(MonadIO m, MonadState AppState m) =>
ScenarioInfoPair -> ValidatedLaunchParams -> m ()
scenarioToAppState ScenarioInfoPair
siPair ValidatedLaunchParams
lp
  -- Beware: currentScenarioPath must be set so that progress/achievements can be saved.
  -- It has just been cleared in scenarioToAppState.
  Lens' AppState GameState
gameState forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' GameState (Maybe FilePath)
currentScenarioPath forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= forall a. a -> Maybe a
Just FilePath
p
 where
  prevBest :: ZonedTime -> BestRecords
prevBest ZonedTime
t = case ScenarioInfo
si forall s a. s -> Getting a s a -> a
^. Lens' ScenarioInfo ScenarioStatus
scenarioStatus of
    ScenarioStatus
NotStarted -> ZonedTime -> BestRecords
emptyBest ZonedTime
t
    Played SerializableLaunchParams
_ ProgressMetric
_ BestRecords
b -> BestRecords
b

-- | Modify the 'AppState' appropriately when starting a new scenario.
scenarioToAppState ::
  (MonadIO m, MonadState AppState m) =>
  ScenarioInfoPair ->
  ValidatedLaunchParams ->
  m ()
scenarioToAppState :: forall (m :: * -> *).
(MonadIO m, MonadState AppState m) =>
ScenarioInfoPair -> ValidatedLaunchParams -> m ()
scenarioToAppState siPair :: ScenarioInfoPair
siPair@(Scenario
scene, ScenarioInfo
_) ValidatedLaunchParams
lp = do
  RuntimeState
rs <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' AppState RuntimeState
runtimeState
  GameState
gs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Scenario
-> ValidatedLaunchParams -> GameStateConfig -> IO GameState
scenarioToGameState Scenario
scene ValidatedLaunchParams
lp forall a b. (a -> b) -> a -> b
$ RuntimeState -> GameStateConfig
mkGameStateConfig RuntimeState
rs
  Lens' AppState GameState
gameState forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= GameState
gs
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) x.
(MonadIO m, MonadState AppState m) =>
Lens' AppState x -> (x -> IO x) -> m x
withLensIO Lens' AppState UIState
uiState forall a b. (a -> b) -> a -> b
$ Bool -> ScenarioInfoPair -> GameState -> UIState -> IO UIState
scenarioToUIState Bool
isAutoplaying ScenarioInfoPair
siPair GameState
gs
 where
  isAutoplaying :: Bool
isAutoplaying = case forall a. Identity a -> a
runIdentity (forall code (f :: * -> *).
ParameterizableLaunchParams code f -> f (Maybe code)
initialCode ValidatedLaunchParams
lp) of
    Just (CodeToRun SolutionSource
ScenarioSuggested ProcessedTerm
_) -> Bool
True
    Maybe CodeToRun
_ -> Bool
False

  withLensIO :: (MonadIO m, MonadState AppState m) => Lens' AppState x -> (x -> IO x) -> m x
  withLensIO :: forall (m :: * -> *) x.
(MonadIO m, MonadState AppState m) =>
Lens' AppState x -> (x -> IO x) -> m x
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'
    forall (m :: * -> *) a. Monad m => a -> m a
return 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 FilePath -> 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 FilePath -> CategorizedAchievement -> m ()
attainAchievement' ZonedTime
t Maybe FilePath
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 FilePath -> ZonedTime -> Attainment
Attainment CategorizedAchievement
a Maybe FilePath
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 ::
  Bool ->
  ScenarioInfoPair ->
  GameState ->
  UIState ->
  IO UIState
scenarioToUIState :: Bool -> ScenarioInfoPair -> GameState -> UIState -> IO UIState
scenarioToUIState Bool
isAutoplaying siPair :: ScenarioInfoPair
siPair@(Scenario
scenario, ScenarioInfo
_) GameState
gs 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 Bool
uiCheatMode forall s t. ASetter s t Bool Bool -> Bool -> s -> t
||~ Bool
isAutoplaying
      forall a b. a -> (a -> b) -> b
& Lens' UIState Bool
uiHideGoals forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Bool
isAutoplaying Bool -> Bool -> Bool
&& Bool -> Bool
not (UIState
u forall s a. s -> Getting a s a -> a
^. Lens' UIState Bool
uiCheatMode))
      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 (Seed, 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 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
      forall a b. a -> (a -> b) -> b
& Lens' UIState (WorldEditor Name)
uiWorldEditor forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Lens' (WorldEditor n) (List n EntityFacade)
EM.entityPaintList forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall (t :: * -> *) e n.
(Foldable t, Splittable t) =>
t e -> Maybe Seed -> GenericList n t e -> GenericList n t e
BL.listReplace Vector EntityFacade
entityList forall a. Maybe a
Nothing
      forall a b. a -> (a -> b) -> b
& Lens' UIState (WorldEditor Name)
uiWorldEditor forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Lens' (WorldEditor n) MapEditingBounds
EM.editingBounds forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' MapEditingBounds (Maybe (Cosmic BoundsRectangle))
EM.boundsRect forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Maybe (Cosmic BoundsRectangle) -> Maybe (Cosmic BoundsRectangle)
setNewBounds
 where
  entityList :: Vector EntityFacade
entityList = EntityMap -> Vector EntityFacade
EU.getEntitiesForList forall a b. (a -> b) -> a -> b
$ GameState
gs forall s a. s -> Getting a s a -> a
^. Lens' GameState Landscape
landscape forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Landscape EntityMap
entityMap

  (Bool
isEmptyArea, Cosmic BoundsRectangle
newBounds) = WorldDescription -> (Bool, Cosmic BoundsRectangle)
EU.getEditingBounds forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> a
NE.head forall a b. (a -> b) -> a -> b
$ Scenario
scenario forall s a. s -> Getting a s a -> a
^. Lens' Scenario (NonEmpty WorldDescription)
scenarioWorlds
  setNewBounds :: Maybe (Cosmic BoundsRectangle) -> Maybe (Cosmic BoundsRectangle)
setNewBounds Maybe (Cosmic BoundsRectangle)
maybeOldBounds =
    if Bool
isEmptyArea
      then Maybe (Cosmic BoundsRectangle)
maybeOldBounds
      else forall a. a -> Maybe a
Just Cosmic BoundsRectangle
newBounds

-- | Create an initial app state for a specific scenario.  Note that
--   this function is used only for unit tests, integration tests, and
--   benchmarks.
--
--   In normal play, an 'AppState' already exists and we simply need
--   to update it using 'scenarioToAppState'.
initAppStateForScenario :: String -> Maybe Seed -> Maybe FilePath -> ExceptT Text IO AppState
initAppStateForScenario :: FilePath
-> Maybe Seed -> Maybe FilePath -> ExceptT Text IO AppState
initAppStateForScenario FilePath
sceneName Maybe Seed
userSeed Maybe FilePath
toRun =
  forall e (m :: * -> *) a. ThrowC e m a -> ExceptT e m a
asExceptT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e2 (sig :: (* -> *) -> * -> *) (m :: * -> *) e1 a.
Has (Throw e2) sig m =>
(e1 -> e2) -> ThrowC e1 m a -> m a
withThrow (forall a. PrettyPrec a => a -> Text
prettyText @SystemFailure) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
AppOpts -> m AppState
initAppState forall a b. (a -> b) -> a -> b
$
    AppOpts
defaultAppOpts
      { userScenario :: Maybe FilePath
userScenario = forall a. a -> Maybe a
Just FilePath
sceneName
      , userSeed :: Maybe Seed
userSeed = Maybe Seed
userSeed
      , scriptToRun :: Maybe FilePath
scriptToRun = Maybe FilePath
toRun
      }

-- | For convenience, the 'AppState' corresponding to the classic game
--   with seed 0.  This is used only for benchmarks and unit tests.
classicGame0 :: ExceptT Text IO AppState
classicGame0 :: ExceptT Text IO AppState
classicGame0 = FilePath
-> Maybe Seed -> Maybe FilePath -> ExceptT Text IO AppState
initAppStateForScenario FilePath
"classic" (forall a. a -> Maybe a
Just Seed
0) forall a. Maybe a
Nothing