diff --git a/src/swarm-engine/Swarm/Game/State.hs b/src/swarm-engine/Swarm/Game/State.hs index 620cfcb54..b6ef376b8 100644 --- a/src/swarm-engine/Swarm/Game/State.hs +++ b/src/swarm-engine/Swarm/Game/State.hs @@ -34,8 +34,6 @@ module Swarm.Game.State ( -- ** GameState initialization initGameState, - scenarioToGameState, - pureScenarioToGameState, CodeToRun (..), Sha1 (..), SolutionSource (..), @@ -71,7 +69,6 @@ module Swarm.Game.State ( zoomRobots, ) where -import Control.Arrow (Arrow ((&&&))) import Control.Carrier.State.Lazy qualified as Fused import Control.Effect.Lens import Control.Effect.Lift @@ -82,48 +79,28 @@ import Control.Monad (forM, join) import Data.Aeson (ToJSON) import Data.Digest.Pure.SHA (sha1, showDigest) import Data.Foldable (toList) -import Data.Foldable.Extra (allM) import Data.Function (on) import Data.Int (Int32) import Data.IntMap qualified as IM import Data.IntSet qualified as IS -import Data.List (partition) -import Data.List.NonEmpty (NonEmpty) -import Data.List.NonEmpty qualified as NE -import Data.Map (Map) import Data.Map qualified as M -import Data.Maybe (fromMaybe, isNothing, mapMaybe) +import Data.Maybe (fromMaybe, mapMaybe) import Data.Sequence (Seq ((:<|))) import Data.Sequence qualified as Seq -import Data.Set qualified as S import Data.Text (Text) import Data.Text qualified as T (drop, take) import Data.Text.IO qualified as TIO import Data.Text.Lazy qualified as TL import Data.Text.Lazy.Encoding qualified as TL import GHC.Generics (Generic) -import Linear (V2 (..)) -import Swarm.Game.CESK (Store, emptyStore, finalValue, initMachine, store, suspendedEnv) -import Swarm.Game.Device (getCapabilitySet, getMap) +import Swarm.Game.CESK (Store, emptyStore, store, suspendedEnv) import Swarm.Game.Entity import Swarm.Game.Failure (SystemFailure (..)) import Swarm.Game.Land import Swarm.Game.Location -import Swarm.Game.Recipe ( - catRecipeMap, - inRecipeMap, - outRecipeMap, - ) import Swarm.Game.Robot import Swarm.Game.Robot.Concrete -import Swarm.Game.Scenario -import Swarm.Game.Scenario.Objective import Swarm.Game.Scenario.Status -import Swarm.Game.Scenario.Topography.Structure qualified as Structure -import Swarm.Game.Scenario.Topography.Structure.Recognition -import Swarm.Game.Scenario.Topography.Structure.Recognition.Log -import Swarm.Game.Scenario.Topography.Structure.Recognition.Precompute -import Swarm.Game.Scenario.Topography.Structure.Recognition.Type import Swarm.Game.State.Landscape import Swarm.Game.State.Robot import Swarm.Game.State.Substate @@ -133,17 +110,12 @@ import Swarm.Game.Tick (addTicks) import Swarm.Game.Universe as U import Swarm.Game.World qualified as W import Swarm.Game.World.Coords -import Swarm.Game.World.Gen (Seed) -import Swarm.Language.Capability (constCaps) import Swarm.Language.Pipeline (processTermEither) -import Swarm.Language.Syntax (SrcLoc (..), TSyntax, allConst, sLoc) -import Swarm.Language.Types +import Swarm.Language.Syntax (SrcLoc (..), TSyntax, sLoc) import Swarm.Language.Value (Env) import Swarm.Log -import Swarm.Util (binTuples, uniq, (?)) +import Swarm.Util (uniq) import Swarm.Util.Lens (makeLensesNoSigs) -import System.Clock qualified as Clock -import System.Random (mkStdGen) newtype Sha1 = Sha1 String deriving (Show, Eq, Ord, Generic, ToJSON) @@ -531,169 +503,3 @@ zoomWorld swName n = do let (w', a) = run (Fused.runState w n) landscape . multiWorld %= M.insert swName w' return a - --- | Matches definitions against the placements. --- Fails fast (short-circuits) if a non-matching --- cell is encountered. -ensureStructureIntact :: - (Has (State GameState) sig m) => - FoundStructure Cell Entity -> - m Bool -ensureStructureIntact (FoundStructure (StructureWithGrid _ _ grid) upperLeft) = - allM outer $ zip [0 ..] grid - where - outer (y, row) = allM (inner y) $ zip [0 ..] row - inner y (x, maybeTemplateEntity) = case maybeTemplateEntity of - Nothing -> return True - Just _ -> - fmap (== maybeTemplateEntity) $ - entityAt $ - upperLeft `offsetBy` V2 x (negate y) - -mkRecognizer :: - (Has (State GameState) sig m) => - StaticStructureInfo -> - m (StructureRecognizer Cell EntityName Entity) -mkRecognizer structInfo@(StaticStructureInfo structDefs _) = do - foundIntact <- mapM (sequenceA . (id &&& ensureStructureIntact)) allPlaced - let fs = populateStaticFoundStructures . map fst . filter snd $ foundIntact - return $ - StructureRecognizer - (mkAutomatons structDefs) - fs - [IntactStaticPlacement $ map mkLogEntry foundIntact] - where - allPlaced = lookupStaticPlacements structInfo - mkLogEntry (x, isIntact) = - IntactPlacementLog - isIntact - ((Structure.name . originalDefinition . structureWithGrid) x) - (upperLeftCorner x) - -buildTagMap :: EntityMap -> Map Text (NonEmpty EntityName) -buildTagMap em = - binTuples expanded - where - expanded = concatMap (\(k, vs) -> [(v, k) | v <- S.toList vs]) tagsByEntity - tagsByEntity = map (view entityName &&& view entityTags) $ entityDefinitionOrder em - -pureScenarioToGameState :: - Scenario -> - Seed -> - Clock.TimeSpec -> - Maybe CodeToRun -> - GameStateConfig -> - GameState -pureScenarioToGameState scenario theSeed now toRun gsc = - preliminaryGameState - & discovery . structureRecognition .~ recognizer - where - sLandscape = scenario ^. scenarioLandscape - - recognizer = - runIdentity $ - Fused.evalState preliminaryGameState $ - mkRecognizer (sLandscape ^. scenarioStructures) - - gs = initGameState gsc - preliminaryGameState = - gs - & robotInfo %~ setRobotInfo baseID robotList' - & creativeMode .~ scenario ^. scenarioOperation . scenarioCreative - & winCondition .~ theWinCondition - & winSolution .~ scenario ^. scenarioOperation . scenarioSolution - & discovery . availableCommands .~ Notifications 0 initialCommands - & discovery . knownEntities .~ sLandscape ^. scenarioKnown - & discovery . tagMembers .~ buildTagMap em - & randomness . seed .~ theSeed - & randomness . randGen .~ mkStdGen theSeed - & recipesInfo %~ modifyRecipesInfo - & landscape .~ mkLandscape sLandscape worldTuples theSeed - & gameControls . initiallyRunCode .~ initialCodeToRun - & gameControls . replStatus .~ case running of -- When the base starts out running a program, the REPL status must be set to working, - -- otherwise the store of definition cells is not saved (see #333, #838) - False -> REPLDone Nothing - True -> REPLWorking PolyUnit Nothing - & temporal . robotStepsPerTick .~ ((scenario ^. scenarioOperation . scenarioStepsPerTick) ? defaultRobotStepsPerTick) - - robotList' = (robotCreatedAt .~ now) <$> robotList - - modifyRecipesInfo oldRecipesInfo = - oldRecipesInfo - & recipesOut %~ addRecipesWith outRecipeMap - & recipesIn %~ addRecipesWith inRecipeMap - & recipesCat %~ addRecipesWith catRecipeMap - - TerrainEntityMaps _ em = sLandscape ^. scenarioTerrainAndEntities - baseID = 0 - (things, devices) = partition (M.null . getMap . view entityCapabilities) (M.elems (entitiesByName em)) - - getCodeToRun (CodeToRun _ s) = s - - robotsByBasePrecedence = genRobotTemplates sLandscape worldTuples - - initialCodeToRun = getCodeToRun <$> toRun - - robotListRaw = - zipWith (instantiateRobot Nothing) [baseID ..] robotsByBasePrecedence - - robotList = - robotListRaw - -- If the --run flag was used, use it to replace the CESK machine of the - -- robot whose id is 0, i.e. the first robot listed in the scenario. - -- Note that this *replaces* any program the base robot otherwise - -- would have run (i.e. any program specified in the program: field - -- of the scenario description). - & ix baseID - . machine - %~ case initialCodeToRun of - Nothing -> id - Just t -> const $ initMachine t - -- If we are in creative mode, give base all the things - & ix baseID - . robotInventory - %~ case scenario ^. scenarioOperation . scenarioCreative of - False -> id - True -> union (fromElems (map (0,) things)) - & ix baseID - . equippedDevices - %~ case scenario ^. scenarioOperation . scenarioCreative of - False -> id - True -> const (fromList devices) - - running = case robotList of - [] -> False - (base : _) -> isNothing (finalValue (base ^. machine)) - - -- Initial list of available commands = all commands enabled by - -- devices in inventory or equipped; and commands that require no - -- capability. - allCapabilities r = - inventoryCapabilities (r ^. equippedDevices) - <> inventoryCapabilities (r ^. robotInventory) - initialCaps = getCapabilitySet $ mconcat $ map allCapabilities robotList - initialCommands = - filter - (maybe True (`S.member` initialCaps) . constCaps) - allConst - - worldTuples = buildWorldTuples sLandscape - - theWinCondition = - maybe - NoWinCondition - (WinConditions Ongoing . initCompletion . NE.toList) - (NE.nonEmpty (scenario ^. scenarioOperation . scenarioObjectives)) - - addRecipesWith f = IM.unionWith (<>) (f $ scenario ^. scenarioOperation . scenarioRecipes) - --- | Create an initial game state corresponding to the given scenario. -scenarioToGameState :: - Scenario -> - ValidatedLaunchParams -> - GameStateConfig -> - IO GameState -scenarioToGameState scenario (LaunchParams (Identity userSeed) (Identity toRun)) gsc = do - theSeed <- arbitrateSeed userSeed $ scenario ^. scenarioLandscape - now <- Clock.getTime Clock.Monotonic - return $ pureScenarioToGameState scenario theSeed now toRun gsc diff --git a/src/swarm-engine/Swarm/Game/State/Initialize.hs b/src/swarm-engine/Swarm/Game/State/Initialize.hs new file mode 100644 index 000000000..a5593fbb9 --- /dev/null +++ b/src/swarm-engine/Swarm/Game/State/Initialize.hs @@ -0,0 +1,224 @@ +-- SPDX-License-Identifier: BSD-3-Clause +-- Description: Game-related state and utilities +-- +-- Definition of the record holding all the game-related state, and various related +-- utility functions. +module Swarm.Game.State.Initialize ( + scenarioToGameState, + pureScenarioToGameState, +) where + +import Control.Arrow (Arrow ((&&&))) +import Control.Carrier.State.Lazy qualified as Fused +import Control.Effect.Lens (view) +import Control.Effect.Lift (Has) +import Control.Effect.State (State) +import Control.Lens hiding (Const, use, uses, view, (%=), (+=), (.=), (<+=), (<<.=)) +import Data.Foldable.Extra (allM) +import Data.IntMap qualified as IM +import Data.List (partition) +import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty qualified as NE +import Data.Map (Map) +import Data.Map qualified as M +import Data.Maybe (isNothing) +import Data.Set qualified as S +import Data.Text (Text) +import Linear (V2 (..)) +import Swarm.Game.CESK (finalValue, initMachine) +import Swarm.Game.Device (getCapabilitySet, getMap) +import Swarm.Game.Entity +import Swarm.Game.Land +import Swarm.Game.Recipe ( + catRecipeMap, + inRecipeMap, + outRecipeMap, + ) +import Swarm.Game.Robot +import Swarm.Game.Robot.Concrete +import Swarm.Game.Scenario +import Swarm.Game.Scenario.Objective +import Swarm.Game.Scenario.Status +import Swarm.Game.Scenario.Topography.Structure qualified as Structure +import Swarm.Game.Scenario.Topography.Structure.Recognition +import Swarm.Game.Scenario.Topography.Structure.Recognition.Log +import Swarm.Game.Scenario.Topography.Structure.Recognition.Precompute +import Swarm.Game.Scenario.Topography.Structure.Recognition.Type +import Swarm.Game.State +import Swarm.Game.State.Landscape +import Swarm.Game.State.Robot +import Swarm.Game.State.Substate +import Swarm.Game.Universe as U +import Swarm.Game.World.Gen (Seed) +import Swarm.Language.Capability (constCaps) +import Swarm.Language.Syntax (allConst) +import Swarm.Language.Types +import Swarm.Util (binTuples, (?)) +import System.Clock qualified as Clock +import System.Random (mkStdGen) + +-- | Create an initial game state corresponding to the given scenario. +scenarioToGameState :: + Scenario -> + ValidatedLaunchParams -> + GameStateConfig -> + IO GameState +scenarioToGameState scenario (LaunchParams (Identity userSeed) (Identity toRun)) gsc = do + theSeed <- arbitrateSeed userSeed $ scenario ^. scenarioLandscape + now <- Clock.getTime Clock.Monotonic + return $ pureScenarioToGameState scenario theSeed now toRun gsc + +pureScenarioToGameState :: + Scenario -> + Seed -> + Clock.TimeSpec -> + Maybe CodeToRun -> + GameStateConfig -> + GameState +pureScenarioToGameState scenario theSeed now toRun gsc = + preliminaryGameState + & discovery . structureRecognition .~ recognizer + where + sLandscape = scenario ^. scenarioLandscape + + recognizer = + runIdentity $ + Fused.evalState preliminaryGameState $ + mkRecognizer (sLandscape ^. scenarioStructures) + + gs = initGameState gsc + preliminaryGameState = + gs + & robotInfo %~ setRobotInfo baseID robotList' + & creativeMode .~ scenario ^. scenarioOperation . scenarioCreative + & winCondition .~ theWinCondition + & winSolution .~ scenario ^. scenarioOperation . scenarioSolution + & discovery . availableCommands .~ Notifications 0 initialCommands + & discovery . knownEntities .~ sLandscape ^. scenarioKnown + & discovery . tagMembers .~ buildTagMap em + & randomness . seed .~ theSeed + & randomness . randGen .~ mkStdGen theSeed + & recipesInfo %~ modifyRecipesInfo + & landscape .~ mkLandscape sLandscape worldTuples theSeed + & gameControls . initiallyRunCode .~ initialCodeToRun + & gameControls . replStatus .~ case running of -- When the base starts out running a program, the REPL status must be set to working, + -- otherwise the store of definition cells is not saved (see #333, #838) + False -> REPLDone Nothing + True -> REPLWorking PolyUnit Nothing + & temporal . robotStepsPerTick .~ ((scenario ^. scenarioOperation . scenarioStepsPerTick) ? defaultRobotStepsPerTick) + + robotList' = (robotCreatedAt .~ now) <$> robotList + + modifyRecipesInfo oldRecipesInfo = + oldRecipesInfo + & recipesOut %~ addRecipesWith outRecipeMap + & recipesIn %~ addRecipesWith inRecipeMap + & recipesCat %~ addRecipesWith catRecipeMap + + TerrainEntityMaps _ em = sLandscape ^. scenarioTerrainAndEntities + baseID = 0 + (things, devices) = partition (M.null . getMap . view entityCapabilities) (M.elems (entitiesByName em)) + + getCodeToRun (CodeToRun _ s) = s + + robotsByBasePrecedence = genRobotTemplates sLandscape worldTuples + + initialCodeToRun = getCodeToRun <$> toRun + + robotListRaw = + zipWith (instantiateRobot Nothing) [baseID ..] robotsByBasePrecedence + + robotList = + robotListRaw + -- If the --run flag was used, use it to replace the CESK machine of the + -- robot whose id is 0, i.e. the first robot listed in the scenario. + -- Note that this *replaces* any program the base robot otherwise + -- would have run (i.e. any program specified in the program: field + -- of the scenario description). + & ix baseID + . machine + %~ case initialCodeToRun of + Nothing -> id + Just t -> const $ initMachine t + -- If we are in creative mode, give base all the things + & ix baseID + . robotInventory + %~ case scenario ^. scenarioOperation . scenarioCreative of + False -> id + True -> union (fromElems (map (0,) things)) + & ix baseID + . equippedDevices + %~ case scenario ^. scenarioOperation . scenarioCreative of + False -> id + True -> const (fromList devices) + + running = case robotList of + [] -> False + (base : _) -> isNothing (finalValue (base ^. machine)) + + -- Initial list of available commands = all commands enabled by + -- devices in inventory or equipped; and commands that require no + -- capability. + allCapabilities r = + inventoryCapabilities (r ^. equippedDevices) + <> inventoryCapabilities (r ^. robotInventory) + initialCaps = getCapabilitySet $ mconcat $ map allCapabilities robotList + initialCommands = + filter + (maybe True (`S.member` initialCaps) . constCaps) + allConst + + worldTuples = buildWorldTuples sLandscape + + theWinCondition = + maybe + NoWinCondition + (WinConditions Ongoing . initCompletion . NE.toList) + (NE.nonEmpty (scenario ^. scenarioOperation . scenarioObjectives)) + + addRecipesWith f = IM.unionWith (<>) (f $ scenario ^. scenarioOperation . scenarioRecipes) + +mkRecognizer :: + (Has (State GameState) sig m) => + StaticStructureInfo -> + m (StructureRecognizer Cell EntityName Entity) +mkRecognizer structInfo@(StaticStructureInfo structDefs _) = do + foundIntact <- mapM (sequenceA . (id &&& ensureStructureIntact)) allPlaced + let fs = populateStaticFoundStructures . map fst . filter snd $ foundIntact + return $ + StructureRecognizer + (mkAutomatons structDefs) + fs + [IntactStaticPlacement $ map mkLogEntry foundIntact] + where + allPlaced = lookupStaticPlacements structInfo + mkLogEntry (x, intact) = + IntactPlacementLog + intact + ((Structure.name . originalDefinition . structureWithGrid) x) + (upperLeftCorner x) + +-- | Matches definitions against the placements. +-- Fails fast (short-circuits) if a non-matching +-- cell is encountered. +ensureStructureIntact :: + (Has (State GameState) sig m) => + FoundStructure Cell Entity -> + m Bool +ensureStructureIntact (FoundStructure (StructureWithGrid _ _ grid) upperLeft) = + allM outer $ zip [0 ..] grid + where + outer (y, row) = allM (inner y) $ zip [0 ..] row + inner y (x, maybeTemplateEntity) = case maybeTemplateEntity of + Nothing -> return True + Just _ -> + fmap (== maybeTemplateEntity) $ + entityAt $ + upperLeft `offsetBy` V2 x (negate y) + +buildTagMap :: EntityMap -> Map Text (NonEmpty EntityName) +buildTagMap em = + binTuples expanded + where + expanded = concatMap (\(k, vs) -> [(v, k) | v <- S.toList vs]) tagsByEntity + tagsByEntity = map (view entityName &&& view entityTags) $ entityDefinitionOrder em diff --git a/src/swarm-tournament/Swarm/Web/Tournament/Validate.hs b/src/swarm-tournament/Swarm/Web/Tournament/Validate.hs index d0480d2b2..997a56df2 100644 --- a/src/swarm-tournament/Swarm/Web/Tournament/Validate.hs +++ b/src/swarm-tournament/Swarm/Web/Tournament/Validate.hs @@ -29,6 +29,7 @@ import Swarm.Game.Scenario import Swarm.Game.Scenario.Scoring.CodeSize (codeMetricsFromSyntax) import Swarm.Game.Scenario.Status (emptyLaunchParams) import Swarm.Game.State +import Swarm.Game.State.Initialize (scenarioToGameState) import Swarm.Game.State.Runtime (initGameStateConfig, initScenarioInputs) import Swarm.Game.State.Substate (initState, seed) import Swarm.Game.Step.Validate (playUntilWin) diff --git a/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs b/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs index f76b9a965..024c6e955 100644 --- a/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs +++ b/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs @@ -67,6 +67,7 @@ import Swarm.Game.ScenarioInfo ( _SISingle, ) import Swarm.Game.State +import Swarm.Game.State.Initialize import Swarm.Game.State.Landscape import Swarm.Game.State.Runtime import Swarm.Game.State.Substate diff --git a/swarm.cabal b/swarm.cabal index af20cb3c6..fce5aed55 100644 --- a/swarm.cabal +++ b/swarm.cabal @@ -378,6 +378,7 @@ library swarm-engine Swarm.Game.Scenario.Topography.Structure.Recognition.Tracking Swarm.Game.ScenarioInfo Swarm.Game.State + Swarm.Game.State.Initialize Swarm.Game.State.Robot Swarm.Game.State.Runtime Swarm.Game.State.Substate diff --git a/test/bench/Benchmark.hs b/test/bench/Benchmark.hs index 7e704be3b..71b42fdfd 100644 --- a/test/bench/Benchmark.hs +++ b/test/bench/Benchmark.hs @@ -21,7 +21,8 @@ import Swarm.Game.Location import Swarm.Game.Robot (TRobot, mkRobot) import Swarm.Game.Robot.Walk (emptyExceptions) import Swarm.Game.Scenario (loadStandaloneScenario) -import Swarm.Game.State (GameState, creativeMode, landscape, pureScenarioToGameState, zoomRobots) +import Swarm.Game.State (GameState, creativeMode, landscape, zoomRobots) +import Swarm.Game.State.Initialize (pureScenarioToGameState) import Swarm.Game.State.Landscape (multiWorld) import Swarm.Game.State.Robot (addTRobot) import Swarm.Game.State.Runtime (initRuntimeState, stdGameConfigInputs)