{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
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
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
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)
skipMenu :: AppOpts -> Bool
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
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)
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)
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
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)
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
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
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
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
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
}
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