{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}

-- |
-- SPDX-License-Identifier: BSD-3-Clause
module Swarm.Game.State.Landscape (
  Landscape,
  SubworldDescription,

  -- ** Lenses
  worldNavigation,
  multiWorld,
  worldScrollable,
  terrainAndEntities,
  recognizerAutomatons,

  -- ** Utilities
  initLandscape,
  mkLandscape,
  buildWorldTuples,
  genMultiWorld,
  buildWorld,
  genRobotTemplates,
) where

import Control.Arrow (Arrow ((&&&)))
import Control.Lens hiding (Const, both, use, uses, (%=), (+=), (.=), (<+=), (<<.=))
import Data.Array (Array, listArray)
import Data.Bifunctor (first)
import Data.Int (Int32)
import Data.List (sortOn)
import Data.List.NonEmpty (NonEmpty)
import Data.List.NonEmpty qualified as NE
import Data.Map qualified as M
import Data.Maybe (isJust)
import Data.Tuple.Extra (both, swap)
import Swarm.Game.Entity
import Swarm.Game.Land
import Swarm.Game.Location
import Swarm.Game.Robot (TRobot, trobotLocation)
import Swarm.Game.Scenario
import Swarm.Game.Scenario.RobotLookup (IndexedTRobot)
import Swarm.Game.Scenario.Topography.Area
import Swarm.Game.Scenario.Topography.Cell
import Swarm.Game.Scenario.Topography.Grid
import Swarm.Game.Scenario.Topography.Navigation.Portal (Navigation (..))
import Swarm.Game.Scenario.Topography.Structure.Overlay
import Swarm.Game.Scenario.Topography.Structure.Recognition.Type
import Swarm.Game.Scenario.Topography.WorldDescription
import Swarm.Game.State.Config
import Swarm.Game.Terrain (TerrainType (..), terrainIndexByName)
import Swarm.Game.Universe as U
import Swarm.Game.World
import Swarm.Game.World.Coords
import Swarm.Game.World.Eval (runWorld)
import Swarm.Game.World.Gen (Seed)
import Swarm.Util.Erasable
import Swarm.Util.Lens (makeLensesNoSigs)

type SubworldDescription = (SubworldName, ([IndexedTRobot], Seed -> WorldFun Int Entity))

data Landscape = Landscape
  { Landscape -> Navigation (Map SubworldName) Location
_worldNavigation :: Navigation (M.Map SubworldName) Location
  , Landscape -> MultiWorld Seed Entity
_multiWorld :: MultiWorld Int Entity
  , Landscape -> TerrainEntityMaps
_terrainAndEntities :: TerrainEntityMaps
  , Landscape
-> RecognizerAutomatons RecognizableStructureContent Entity
_recognizerAutomatons :: RecognizerAutomatons RecognizableStructureContent Entity
  , Landscape -> Bool
_worldScrollable :: Bool
  }

makeLensesNoSigs ''Landscape

-- | Includes a 'Map' of named locations and an
-- "edge list" (graph) that maps portal entrances to exits
worldNavigation :: Lens' Landscape (Navigation (M.Map SubworldName) Location)

-- | The current state of the world (terrain and entities only; robots
--   are stored in the 'robotMap').  'Int' is used instead of
--   'TerrainType' because we need to be able to store terrain values in
--   unboxed tile arrays.
multiWorld :: Lens' Landscape (MultiWorld Int Entity)

-- | The catalogs of all terrain and entities that the game knows about.
terrainAndEntities :: Lens' Landscape TerrainEntityMaps

-- | Recognition engine for predefined structures
recognizerAutomatons :: Lens' Landscape (RecognizerAutomatons RecognizableStructureContent Entity)

-- | Whether the world map is supposed to be scrollable or not.
worldScrollable :: Lens' Landscape Bool

-- | Create an record that is empty except for
-- system-provided entities.
initLandscape :: GameStateConfig -> Landscape
initLandscape :: GameStateConfig -> Landscape
initLandscape GameStateConfig
gsc =
  Landscape
    { _worldNavigation :: Navigation (Map SubworldName) Location
_worldNavigation = Map SubworldName WaypointMap
-> Map (Cosmic Location) (AnnotatedDestination Location)
-> Navigation (Map SubworldName) Location
forall (additionalDimension :: * -> *) portalExitLoc.
additionalDimension WaypointMap
-> Map (Cosmic Location) (AnnotatedDestination portalExitLoc)
-> Navigation additionalDimension portalExitLoc
Navigation Map SubworldName WaypointMap
forall a. Monoid a => a
mempty Map (Cosmic Location) (AnnotatedDestination Location)
forall a. Monoid a => a
mempty
    , _multiWorld :: MultiWorld Seed Entity
_multiWorld = MultiWorld Seed Entity
forall a. Monoid a => a
mempty
    , _terrainAndEntities :: TerrainEntityMaps
_terrainAndEntities = ScenarioInputs -> TerrainEntityMaps
initEntityTerrain (ScenarioInputs -> TerrainEntityMaps)
-> ScenarioInputs -> TerrainEntityMaps
forall a b. (a -> b) -> a -> b
$ GameStateInputs -> ScenarioInputs
gsiScenarioInputs (GameStateInputs -> ScenarioInputs)
-> GameStateInputs -> ScenarioInputs
forall a b. (a -> b) -> a -> b
$ GameStateConfig -> GameStateInputs
initState GameStateConfig
gsc
    , _recognizerAutomatons :: RecognizerAutomatons RecognizableStructureContent Entity
_recognizerAutomatons = Map
  StructureName (StructureInfo RecognizableStructureContent Entity)
-> HashMap
     Entity (AutomatonInfo RecognizableStructureContent Entity)
-> RecognizerAutomatons RecognizableStructureContent Entity
forall b a.
Map StructureName (StructureInfo b a)
-> HashMap a (AutomatonInfo b a) -> RecognizerAutomatons b a
RecognizerAutomatons Map
  StructureName (StructureInfo RecognizableStructureContent Entity)
forall a. Monoid a => a
mempty HashMap Entity (AutomatonInfo RecognizableStructureContent Entity)
forall a. Monoid a => a
mempty
    , _worldScrollable :: Bool
_worldScrollable = Bool
True
    }

mkLandscape :: ScenarioLandscape -> NonEmpty SubworldDescription -> Seed -> Landscape
mkLandscape :: ScenarioLandscape
-> NonEmpty SubworldDescription -> Seed -> Landscape
mkLandscape ScenarioLandscape
sLandscape NonEmpty SubworldDescription
worldTuples Seed
theSeed =
  Landscape
    { _worldNavigation :: Navigation (Map SubworldName) Location
_worldNavigation = ScenarioLandscape
sLandscape ScenarioLandscape
-> Getting
     (Navigation (Map SubworldName) Location)
     ScenarioLandscape
     (Navigation (Map SubworldName) Location)
-> Navigation (Map SubworldName) Location
forall s a. s -> Getting a s a -> a
^. Getting
  (Navigation (Map SubworldName) Location)
  ScenarioLandscape
  (Navigation (Map SubworldName) Location)
Lens' ScenarioLandscape (Navigation (Map SubworldName) Location)
scenarioNavigation
    , _multiWorld :: MultiWorld Seed Entity
_multiWorld = NonEmpty SubworldDescription -> Seed -> MultiWorld Seed Entity
genMultiWorld NonEmpty SubworldDescription
worldTuples Seed
theSeed
    , _terrainAndEntities :: TerrainEntityMaps
_terrainAndEntities = ScenarioLandscape
sLandscape ScenarioLandscape
-> Getting TerrainEntityMaps ScenarioLandscape TerrainEntityMaps
-> TerrainEntityMaps
forall s a. s -> Getting a s a -> a
^. Getting TerrainEntityMaps ScenarioLandscape TerrainEntityMaps
Lens' ScenarioLandscape TerrainEntityMaps
scenarioTerrainAndEntities
    , _recognizerAutomatons :: RecognizerAutomatons RecognizableStructureContent Entity
_recognizerAutomatons = ScenarioLandscape
sLandscape ScenarioLandscape
-> Getting
     (RecognizerAutomatons RecognizableStructureContent Entity)
     ScenarioLandscape
     (RecognizerAutomatons RecognizableStructureContent Entity)
-> RecognizerAutomatons RecognizableStructureContent Entity
forall s a. s -> Getting a s a -> a
^. (StaticStructureInfo RecognizableStructureContent Entity
 -> Const
      (RecognizerAutomatons RecognizableStructureContent Entity)
      (StaticStructureInfo RecognizableStructureContent Entity))
-> ScenarioLandscape
-> Const
     (RecognizerAutomatons RecognizableStructureContent Entity)
     ScenarioLandscape
Lens'
  ScenarioLandscape
  (StaticStructureInfo RecognizableStructureContent Entity)
scenarioStructures ((StaticStructureInfo RecognizableStructureContent Entity
  -> Const
       (RecognizerAutomatons RecognizableStructureContent Entity)
       (StaticStructureInfo RecognizableStructureContent Entity))
 -> ScenarioLandscape
 -> Const
      (RecognizerAutomatons RecognizableStructureContent Entity)
      ScenarioLandscape)
-> ((RecognizerAutomatons RecognizableStructureContent Entity
     -> Const
          (RecognizerAutomatons RecognizableStructureContent Entity)
          (RecognizerAutomatons RecognizableStructureContent Entity))
    -> StaticStructureInfo RecognizableStructureContent Entity
    -> Const
         (RecognizerAutomatons RecognizableStructureContent Entity)
         (StaticStructureInfo RecognizableStructureContent Entity))
-> Getting
     (RecognizerAutomatons RecognizableStructureContent Entity)
     ScenarioLandscape
     (RecognizerAutomatons RecognizableStructureContent Entity)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RecognizerAutomatons RecognizableStructureContent Entity
 -> Const
      (RecognizerAutomatons RecognizableStructureContent Entity)
      (RecognizerAutomatons RecognizableStructureContent Entity))
-> StaticStructureInfo RecognizableStructureContent Entity
-> Const
     (RecognizerAutomatons RecognizableStructureContent Entity)
     (StaticStructureInfo RecognizableStructureContent Entity)
forall b a (f :: * -> *).
Functor f =>
(RecognizerAutomatons b a -> f (RecognizerAutomatons b a))
-> StaticStructureInfo b a -> f (StaticStructureInfo b a)
staticAutomatons
    , -- TODO (#1370): Should we allow subworlds to have their own scrollability?
      -- Leaning toward no, but for now just adopt the root world scrollability
      -- as being universal.
      _worldScrollable :: Bool
_worldScrollable = NonEmpty WorldDescription -> WorldDescription
forall a. NonEmpty a -> a
NE.head (ScenarioLandscape
sLandscape ScenarioLandscape
-> Getting
     (NonEmpty WorldDescription)
     ScenarioLandscape
     (NonEmpty WorldDescription)
-> NonEmpty WorldDescription
forall s a. s -> Getting a s a -> a
^. Getting
  (NonEmpty WorldDescription)
  ScenarioLandscape
  (NonEmpty WorldDescription)
Lens' ScenarioLandscape (NonEmpty WorldDescription)
scenarioWorlds) WorldDescription -> Getting Bool WorldDescription Bool -> Bool
forall s a. s -> Getting a s a -> a
^. (WorldDescription -> Bool) -> Getting Bool WorldDescription Bool
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to WorldDescription -> Bool
forall e. PWorldDescription e -> Bool
scrollable
    }

buildWorldTuples :: ScenarioLandscape -> NonEmpty SubworldDescription
buildWorldTuples :: ScenarioLandscape -> NonEmpty SubworldDescription
buildWorldTuples ScenarioLandscape
sLandscape =
  (WorldDescription -> SubworldDescription)
-> NonEmpty WorldDescription -> NonEmpty SubworldDescription
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map (WorldDescription -> SubworldName
forall e. PWorldDescription e -> SubworldName
worldName (WorldDescription -> SubworldName)
-> (WorldDescription
    -> ([IndexedTRobot], Seed -> WorldFun Seed Entity))
-> WorldDescription
-> SubworldDescription
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& TerrainEntityMaps
-> WorldDescription
-> ([IndexedTRobot], Seed -> WorldFun Seed Entity)
buildWorld (ScenarioLandscape
sLandscape ScenarioLandscape
-> Getting TerrainEntityMaps ScenarioLandscape TerrainEntityMaps
-> TerrainEntityMaps
forall s a. s -> Getting a s a -> a
^. Getting TerrainEntityMaps ScenarioLandscape TerrainEntityMaps
Lens' ScenarioLandscape TerrainEntityMaps
scenarioTerrainAndEntities)) (NonEmpty WorldDescription -> NonEmpty SubworldDescription)
-> NonEmpty WorldDescription -> NonEmpty SubworldDescription
forall a b. (a -> b) -> a -> b
$
    ScenarioLandscape
sLandscape ScenarioLandscape
-> Getting
     (NonEmpty WorldDescription)
     ScenarioLandscape
     (NonEmpty WorldDescription)
-> NonEmpty WorldDescription
forall s a. s -> Getting a s a -> a
^. Getting
  (NonEmpty WorldDescription)
  ScenarioLandscape
  (NonEmpty WorldDescription)
Lens' ScenarioLandscape (NonEmpty WorldDescription)
scenarioWorlds

genMultiWorld :: NonEmpty SubworldDescription -> Seed -> MultiWorld Int Entity
genMultiWorld :: NonEmpty SubworldDescription -> Seed -> MultiWorld Seed Entity
genMultiWorld NonEmpty SubworldDescription
worldTuples Seed
s =
  (([IndexedTRobot], Seed -> WorldFun Seed Entity)
 -> World Seed Entity)
-> Map SubworldName ([IndexedTRobot], Seed -> WorldFun Seed Entity)
-> MultiWorld Seed Entity
forall a b k. (a -> b) -> Map k a -> Map k b
M.map ([IndexedTRobot], Seed -> WorldFun Seed Entity)
-> World Seed Entity
forall {a} {t} {e}. (a, Seed -> WorldFun t e) -> World t e
genWorld
    (Map SubworldName ([IndexedTRobot], Seed -> WorldFun Seed Entity)
 -> MultiWorld Seed Entity)
-> (NonEmpty SubworldDescription
    -> Map
         SubworldName ([IndexedTRobot], Seed -> WorldFun Seed Entity))
-> NonEmpty SubworldDescription
-> MultiWorld Seed Entity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SubworldDescription]
-> Map SubworldName ([IndexedTRobot], Seed -> WorldFun Seed Entity)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
    ([SubworldDescription]
 -> Map
      SubworldName ([IndexedTRobot], Seed -> WorldFun Seed Entity))
-> (NonEmpty SubworldDescription -> [SubworldDescription])
-> NonEmpty SubworldDescription
-> Map SubworldName ([IndexedTRobot], Seed -> WorldFun Seed Entity)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty SubworldDescription -> [SubworldDescription]
forall a. NonEmpty a -> [a]
NE.toList
    (NonEmpty SubworldDescription -> MultiWorld Seed Entity)
-> NonEmpty SubworldDescription -> MultiWorld Seed Entity
forall a b. (a -> b) -> a -> b
$ NonEmpty SubworldDescription
worldTuples
 where
  genWorld :: (a, Seed -> WorldFun t e) -> World t e
genWorld (a, Seed -> WorldFun t e)
x = WorldFun t e -> World t e
forall t e. WorldFun t e -> World t e
newWorld (WorldFun t e -> World t e) -> WorldFun t e -> World t e
forall a b. (a -> b) -> a -> b
$ (a, Seed -> WorldFun t e) -> Seed -> WorldFun t e
forall a b. (a, b) -> b
snd (a, Seed -> WorldFun t e)
x Seed
s

-- | Take a world description, parsed from a scenario file, and turn
--   it into a list of located robots and a world function.
buildWorld ::
  TerrainEntityMaps ->
  WorldDescription ->
  ([IndexedTRobot], Seed -> WorldFun Int Entity)
buildWorld :: TerrainEntityMaps
-> WorldDescription
-> ([IndexedTRobot], Seed -> WorldFun Seed Entity)
buildWorld TerrainEntityMaps
tem WorldDescription {Bool
[LocatedStructure]
Maybe (TTerm '[] (World CellVal))
SubworldName
Navigation Identity WaypointName
WorldPalette Entity
PositionedGrid (Maybe (PCell Entity))
scrollable :: forall e. PWorldDescription e -> Bool
worldName :: forall e. PWorldDescription e -> SubworldName
scrollable :: Bool
palette :: WorldPalette Entity
area :: PositionedGrid (Maybe (PCell Entity))
navigation :: Navigation Identity WaypointName
placedStructures :: [LocatedStructure]
worldName :: SubworldName
worldProg :: Maybe (TTerm '[] (World CellVal))
worldProg :: forall e. PWorldDescription e -> Maybe (TTerm '[] (World CellVal))
placedStructures :: forall e. PWorldDescription e -> [LocatedStructure]
navigation :: forall e. PWorldDescription e -> Navigation Identity WaypointName
area :: forall e. PWorldDescription e -> PositionedGrid (Maybe (PCell e))
palette :: forall e. PWorldDescription e -> WorldPalette e
..} =
  (SubworldName -> [IndexedTRobot]
robots SubworldName
worldName, (TerrainType -> Seed)
-> WorldFun TerrainType Entity -> WorldFun Seed Entity
forall a b c. (a -> b) -> WorldFun a c -> WorldFun b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first TerrainType -> Seed
getTerrainIndex (WorldFun TerrainType Entity -> WorldFun Seed Entity)
-> (Seed -> WorldFun TerrainType Entity)
-> Seed
-> WorldFun Seed Entity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seed -> WorldFun TerrainType Entity
wf)
 where
  getTerrainIndex :: TerrainType -> Seed
getTerrainIndex TerrainType
t =
    Seed -> TerrainType -> Map TerrainType Seed -> Seed
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault Seed
0 TerrainType
t (Map TerrainType Seed -> Seed) -> Map TerrainType Seed -> Seed
forall a b. (a -> b) -> a -> b
$
      TerrainMap -> Map TerrainType Seed
terrainIndexByName (TerrainMap -> Map TerrainType Seed)
-> TerrainMap -> Map TerrainType Seed
forall a b. (a -> b) -> a -> b
$
        TerrainEntityMaps
tem TerrainEntityMaps
-> Getting TerrainMap TerrainEntityMaps TerrainMap -> TerrainMap
forall s a. s -> Getting a s a -> a
^. Getting TerrainMap TerrainEntityMaps TerrainMap
Lens' TerrainEntityMaps TerrainMap
terrainMap

  g :: Grid (Maybe (PCell Entity))
g = PositionedGrid (Maybe (PCell Entity))
-> Grid (Maybe (PCell Entity))
forall a. PositionedGrid a -> Grid a
gridContent PositionedGrid (Maybe (PCell Entity))
area

  worldGrid :: Grid (TerrainType, Erasable Entity)
  worldGrid :: Grid (TerrainType, Erasable Entity)
worldGrid = (TerrainType, Erasable Entity)
-> (PCell Entity -> (TerrainType, Erasable Entity))
-> Maybe (PCell Entity)
-> (TerrainType, Erasable Entity)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (TerrainType
BlankT, Erasable Entity
forall e. Erasable e
ENothing) (PCell Entity -> TerrainType
forall e. PCell e -> TerrainType
cellTerrain (PCell Entity -> TerrainType)
-> (PCell Entity -> Erasable Entity)
-> PCell Entity
-> (TerrainType, Erasable Entity)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& PCell Entity -> Erasable Entity
forall e. PCell e -> Erasable e
cellEntity) (Maybe (PCell Entity) -> (TerrainType, Erasable Entity))
-> Grid (Maybe (PCell Entity))
-> Grid (TerrainType, Erasable Entity)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Grid (Maybe (PCell Entity))
g

  offsetCoordsByArea :: Coords -> AreaDimensions -> Coords
  offsetCoordsByArea :: Coords -> AreaDimensions -> Coords
offsetCoordsByArea Coords
x AreaDimensions
a =
    Coords
x Coords -> (Int32, Int32) -> Coords
`addTuple` (Int32, Int32) -> (Int32, Int32)
forall a b. (a, b) -> (b, a)
swap (AreaDimensions -> (Int32, Int32)
asTuple AreaDimensions
a)

  coords :: Coords
coords = Location -> Coords
locToCoords (Location -> Coords) -> Location -> Coords
forall a b. (a -> b) -> a -> b
$ PositionedGrid (Maybe (PCell Entity)) -> Location
forall a. PositionedGrid a -> Location
gridPosition PositionedGrid (Maybe (PCell Entity))
area

  arrayMaxBound :: (Int32, Int32)
arrayMaxBound =
    (Int32 -> Int32) -> (Int32, Int32) -> (Int32, Int32)
forall a b. (a -> b) -> (a, a) -> (b, b)
both (Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
subtract Int32
1)
      ((Int32, Int32) -> (Int32, Int32))
-> (AreaDimensions -> (Int32, Int32))
-> AreaDimensions
-> (Int32, Int32)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coords -> (Int32, Int32)
unCoords
      (Coords -> (Int32, Int32))
-> (AreaDimensions -> Coords) -> AreaDimensions -> (Int32, Int32)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coords -> AreaDimensions -> Coords
offsetCoordsByArea Coords
coords
      (AreaDimensions -> (Int32, Int32))
-> AreaDimensions -> (Int32, Int32)
forall a b. (a -> b) -> a -> b
$ Grid (Maybe (PCell Entity)) -> AreaDimensions
forall a. Grid a -> AreaDimensions
getGridDimensions Grid (Maybe (PCell Entity))
g

  arrayBoundsTuple :: ((Int32, Int32), (Int32, Int32))
arrayBoundsTuple = (Coords -> (Int32, Int32)
unCoords Coords
coords, (Int32, Int32)
arrayMaxBound)

  worldArray :: Array (Int32, Int32) (TerrainType, Erasable Entity)
  worldArray :: Array (Int32, Int32) (TerrainType, Erasable Entity)
worldArray = ((Int32, Int32), (Int32, Int32))
-> [(TerrainType, Erasable Entity)]
-> Array (Int32, Int32) (TerrainType, Erasable Entity)
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray ((Int32, Int32), (Int32, Int32))
arrayBoundsTuple ([(TerrainType, Erasable Entity)]
 -> Array (Int32, Int32) (TerrainType, Erasable Entity))
-> [(TerrainType, Erasable Entity)]
-> Array (Int32, Int32) (TerrainType, Erasable Entity)
forall a b. (a -> b) -> a -> b
$ Grid (TerrainType, Erasable Entity)
-> [(TerrainType, Erasable Entity)]
forall a. Grid a -> [a]
allMembers Grid (TerrainType, Erasable Entity)
worldGrid

  dslWF, arrayWF :: Seed -> WorldFun TerrainType Entity
  dslWF :: Seed -> WorldFun TerrainType Entity
dslWF = (Seed -> WorldFun TerrainType Entity)
-> (TTerm '[] (World CellVal)
    -> Seed -> WorldFun TerrainType Entity)
-> Maybe (TTerm '[] (World CellVal))
-> Seed
-> WorldFun TerrainType Entity
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Seed -> WorldFun TerrainType Entity
forall a. Monoid a => a
mempty TTerm '[] (World CellVal) -> Seed -> WorldFun TerrainType Entity
runWorld Maybe (TTerm '[] (World CellVal))
worldProg
  arrayWF :: Seed -> WorldFun TerrainType Entity
arrayWF = WorldFun TerrainType Entity -> Seed -> WorldFun TerrainType Entity
forall a b. a -> b -> a
const (WorldFun TerrainType Entity
 -> Seed -> WorldFun TerrainType Entity)
-> WorldFun TerrainType Entity
-> Seed
-> WorldFun TerrainType Entity
forall a b. (a -> b) -> a -> b
$ Array (Int32, Int32) (TerrainType, Erasable Entity)
-> WorldFun TerrainType Entity
forall t e.
Monoid t =>
Array (Int32, Int32) (t, Erasable e) -> WorldFun t e
worldFunFromArray Array (Int32, Int32) (TerrainType, Erasable Entity)
worldArray

  wf :: Seed -> WorldFun TerrainType Entity
wf = Seed -> WorldFun TerrainType Entity
dslWF (Seed -> WorldFun TerrainType Entity)
-> (Seed -> WorldFun TerrainType Entity)
-> Seed
-> WorldFun TerrainType Entity
forall a. Semigroup a => a -> a -> a
<> Seed -> WorldFun TerrainType Entity
arrayWF

  -- Get all the robots described in cells and set their locations appropriately
  robots :: SubworldName -> [IndexedTRobot]
  robots :: SubworldName -> [IndexedTRobot]
robots SubworldName
swName =
    [[IndexedTRobot]] -> [IndexedTRobot]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[IndexedTRobot]] -> [IndexedTRobot])
-> [[IndexedTRobot]] -> [IndexedTRobot]
forall a b. (a -> b) -> a -> b
$ (Coords -> Maybe (PCell Entity) -> [IndexedTRobot])
-> Grid (Maybe (PCell Entity)) -> [[IndexedTRobot]]
forall a b. (Coords -> a -> b) -> Grid a -> [b]
mapWithCoords Coords -> Maybe (PCell Entity) -> [IndexedTRobot]
forall {e}. Coords -> Maybe (PCell e) -> [IndexedTRobot]
extractRobots Grid (Maybe (PCell Entity))
g
   where
    extractRobots :: Coords -> Maybe (PCell e) -> [IndexedTRobot]
extractRobots (Coords (Int32, Int32)
coordsTuple) Maybe (PCell e)
maybeCell =
      let robotWithLoc :: TRobot -> TRobot
robotWithLoc = (Maybe (Cosmic Location) -> Identity (Maybe (Cosmic Location)))
-> TRobot -> Identity TRobot
Lens' TRobot (Maybe (Cosmic Location))
trobotLocation ((Maybe (Cosmic Location) -> Identity (Maybe (Cosmic Location)))
 -> TRobot -> Identity TRobot)
-> Cosmic Location -> TRobot -> TRobot
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ SubworldName -> Location -> Cosmic Location
forall a. SubworldName -> a -> Cosmic a
Cosmic SubworldName
swName (Coords -> Location
coordsToLoc (Coords
coords Coords -> (Int32, Int32) -> Coords
`addTuple` (Int32, Int32)
coordsTuple))
       in (IndexedTRobot -> IndexedTRobot)
-> [IndexedTRobot] -> [IndexedTRobot]
forall a b. (a -> b) -> [a] -> [b]
map ((TRobot -> TRobot) -> IndexedTRobot -> IndexedTRobot
forall a b. (a -> b) -> (Seed, a) -> (Seed, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TRobot -> TRobot
robotWithLoc) ([IndexedTRobot]
-> (PCell e -> [IndexedTRobot])
-> Maybe (PCell e)
-> [IndexedTRobot]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] PCell e -> [IndexedTRobot]
forall e. PCell e -> [IndexedTRobot]
cellRobots Maybe (PCell e)
maybeCell)

-- |
-- Returns a list of robots, ordered by decreasing preference
-- to serve as the "base".
--
-- = Rules for selecting the "base" robot:
--
-- What follows is a thorough description of how the base
-- choice is made as of the most recent study of the code.
-- This level of detail is not meant to be public-facing.
--
-- For an abbreviated explanation, see the "Base robot" section of the
-- <https://github.com/swarm-game/swarm/tree/main/data/scenarios#base-robot Scenario Authoring Guide>.
--
-- == Precedence rules
--
-- 1. Prefer those robots defined with a @loc@ ('robotLocation') in the scenario file
--
--     1. If multiple robots define a @loc@, use the robot that is defined
--        first within the scenario file.
--     2. Note that if a robot is both given a @loc@ AND is specified in the
--        world map, then two instances of the robot shall be created. The
--        instance with the @loc@ shall be preferred as the base.
--
-- 2. Fall back to robots generated from templates via the map and palette.
--
--     1. If multiple robots are specified in the map, prefer the one that
--        is defined first within the scenario file.
--     2. If multiple robots are instantiated from the same template, then
--        prefer the one with a lower-indexed subworld. Note that the root
--        subworld is always first.
--     3. If multiple robots instantiated from the same template are in the
--        same subworld, then
--        prefer the one closest to the upper-left of the screen, with higher
--        rows given precedence over columns (i.e. first in row-major order).
genRobotTemplates :: ScenarioLandscape -> NonEmpty (a, ([(Int, TRobot)], b)) -> [TRobot]
genRobotTemplates :: forall a b.
ScenarioLandscape -> NonEmpty (a, ([IndexedTRobot], b)) -> [TRobot]
genRobotTemplates ScenarioLandscape
sLandscape NonEmpty (a, ([IndexedTRobot], b))
worldTuples =
  [TRobot]
locatedRobots [TRobot] -> [TRobot] -> [TRobot]
forall a. [a] -> [a] -> [a]
++ (IndexedTRobot -> TRobot) -> [IndexedTRobot] -> [TRobot]
forall a b. (a -> b) -> [a] -> [b]
map IndexedTRobot -> TRobot
forall a b. (a, b) -> b
snd ((IndexedTRobot -> Seed) -> [IndexedTRobot] -> [IndexedTRobot]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn IndexedTRobot -> Seed
forall a b. (a, b) -> a
fst [IndexedTRobot]
genRobots)
 where
  -- Keep only robots from the robot list with a concrete location;
  -- the others existed only to serve as a template for robots drawn
  -- in the world map
  locatedRobots :: [TRobot]
locatedRobots = (TRobot -> Bool) -> [TRobot] -> [TRobot]
forall a. (a -> Bool) -> [a] -> [a]
filter (Maybe (Cosmic Location) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Cosmic Location) -> Bool)
-> (TRobot -> Maybe (Cosmic Location)) -> TRobot -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (Maybe (Cosmic Location)) TRobot (Maybe (Cosmic Location))
-> TRobot -> Maybe (Cosmic Location)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Maybe (Cosmic Location)) TRobot (Maybe (Cosmic Location))
Lens' TRobot (Maybe (Cosmic Location))
trobotLocation) ([TRobot] -> [TRobot]) -> [TRobot] -> [TRobot]
forall a b. (a -> b) -> a -> b
$ ScenarioLandscape
sLandscape ScenarioLandscape
-> Getting [TRobot] ScenarioLandscape [TRobot] -> [TRobot]
forall s a. s -> Getting a s a -> a
^. Getting [TRobot] ScenarioLandscape [TRobot]
Lens' ScenarioLandscape [TRobot]
scenarioRobots

  -- Subworld order as encountered in the scenario YAML file is preserved for
  -- the purpose of numbering robots, other than the "root" subworld
  -- guaranteed to be first.
  genRobots :: [(Int, TRobot)]
  genRobots :: [IndexedTRobot]
genRobots = [[IndexedTRobot]] -> [IndexedTRobot]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[IndexedTRobot]] -> [IndexedTRobot])
-> [[IndexedTRobot]] -> [IndexedTRobot]
forall a b. (a -> b) -> a -> b
$ NonEmpty [IndexedTRobot] -> [[IndexedTRobot]]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty [IndexedTRobot] -> [[IndexedTRobot]])
-> NonEmpty [IndexedTRobot] -> [[IndexedTRobot]]
forall a b. (a -> b) -> a -> b
$ ((a, ([IndexedTRobot], b)) -> [IndexedTRobot])
-> NonEmpty (a, ([IndexedTRobot], b)) -> NonEmpty [IndexedTRobot]
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map (([IndexedTRobot], b) -> [IndexedTRobot]
forall a b. (a, b) -> a
fst (([IndexedTRobot], b) -> [IndexedTRobot])
-> ((a, ([IndexedTRobot], b)) -> ([IndexedTRobot], b))
-> (a, ([IndexedTRobot], b))
-> [IndexedTRobot]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, ([IndexedTRobot], b)) -> ([IndexedTRobot], b)
forall a b. (a, b) -> b
snd) NonEmpty (a, ([IndexedTRobot], b))
worldTuples