{-# 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
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)
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
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
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
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
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