{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies #-}

-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- A /world/ refers to the grid on which the game takes place, and the
-- things in it (besides robots). A world has a base, immutable
-- /terrain/ layer, where each cell contains a terrain type, and a
-- mutable /entity/ layer, with at most one entity per cell.
--
-- A world is technically finite but practically infinite (worlds are
-- indexed by 32-bit signed integers, so they correspond to a
-- \( 2^{32} \times 2^{32} \) torus).
module Swarm.Game.World (
  -- * World coordinates
  Coords (..),
  locToCoords,
  coordsToLoc,
  BoundsRectangle,

  -- * Worlds
  WorldFun (..),
  runWF,
  worldFunFromArray,
  World,
  MultiWorld,

  -- ** Tile management
  loadCell,
  loadRegion,

  -- ** World functions
  newWorld,
  lookupCosmicTerrain,
  lookupTerrain,
  lookupCosmicEntity,
  lookupEntity,
  update,

  -- ** Monadic variants
  lookupTerrainM,
  lookupEntityM,
  updateM,

  -- ** Runtime updates
  WorldUpdate (..),
) where

import Control.Algebra (Has)
import Control.Arrow ((&&&))
import Control.Effect.State (State, get, modify, state)
import Control.Lens
import Data.Array qualified as A
import Data.Array.IArray
import Data.Array.Unboxed qualified as U
import Data.Bifunctor (second)
import Data.Bits
import Data.Foldable (foldl')
import Data.Int (Int32)
import Data.Map (Map)
import Data.Map.Strict qualified as M
import Data.Semigroup (Last (..))
import Data.Yaml (FromJSON, ToJSON)
import GHC.Generics (Generic)
import Swarm.Game.Entity (Entity)
import Swarm.Game.Location
import Swarm.Game.Terrain (TerrainType (BlankT))
import Swarm.Game.Universe
import Swarm.Game.World.Coords
import Swarm.Game.World.Modify
import Swarm.Util ((?))
import Swarm.Util.Erasable
import Prelude hiding (lookup)

------------------------------------------------------------
-- World function
------------------------------------------------------------

-- | A @WorldFun t e@ represents a 2D world with terrain of type @t@
-- (exactly one per cell) and entities of type @e@ (at most one per
-- cell).
newtype WorldFun t e = WF {forall t e. WorldFun t e -> Coords -> (t, Erasable (Last e))
getWF :: Coords -> (t, Erasable (Last e))}
  deriving stock (forall a b. a -> WorldFun t b -> WorldFun t a
forall a b. (a -> b) -> WorldFun t a -> WorldFun t b
forall t a b. a -> WorldFun t b -> WorldFun t a
forall t a b. (a -> b) -> WorldFun t a -> WorldFun t b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> WorldFun t b -> WorldFun t a
$c<$ :: forall t a b. a -> WorldFun t b -> WorldFun t a
fmap :: forall a b. (a -> b) -> WorldFun t a -> WorldFun t b
$cfmap :: forall t a b. (a -> b) -> WorldFun t a -> WorldFun t b
Functor)
  deriving newtype (NonEmpty (WorldFun t e) -> WorldFun t e
WorldFun t e -> WorldFun t e -> WorldFun t e
forall b. Integral b => b -> WorldFun t e -> WorldFun t e
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall t e. Semigroup t => NonEmpty (WorldFun t e) -> WorldFun t e
forall t e.
Semigroup t =>
WorldFun t e -> WorldFun t e -> WorldFun t e
forall t e b.
(Semigroup t, Integral b) =>
b -> WorldFun t e -> WorldFun t e
stimes :: forall b. Integral b => b -> WorldFun t e -> WorldFun t e
$cstimes :: forall t e b.
(Semigroup t, Integral b) =>
b -> WorldFun t e -> WorldFun t e
sconcat :: NonEmpty (WorldFun t e) -> WorldFun t e
$csconcat :: forall t e. Semigroup t => NonEmpty (WorldFun t e) -> WorldFun t e
<> :: WorldFun t e -> WorldFun t e -> WorldFun t e
$c<> :: forall t e.
Semigroup t =>
WorldFun t e -> WorldFun t e -> WorldFun t e
Semigroup, WorldFun t e
[WorldFun t e] -> WorldFun t e
WorldFun t e -> WorldFun t e -> WorldFun t e
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall {t} {e}. Monoid t => Semigroup (WorldFun t e)
forall t e. Monoid t => WorldFun t e
forall t e. Monoid t => [WorldFun t e] -> WorldFun t e
forall t e.
Monoid t =>
WorldFun t e -> WorldFun t e -> WorldFun t e
mconcat :: [WorldFun t e] -> WorldFun t e
$cmconcat :: forall t e. Monoid t => [WorldFun t e] -> WorldFun t e
mappend :: WorldFun t e -> WorldFun t e -> WorldFun t e
$cmappend :: forall t e.
Monoid t =>
WorldFun t e -> WorldFun t e -> WorldFun t e
mempty :: WorldFun t e
$cmempty :: forall t e. Monoid t => WorldFun t e
Monoid)

runWF :: WorldFun t e -> Coords -> (t, Maybe e)
runWF :: forall t e. WorldFun t e -> Coords -> (t, Maybe e)
runWF WorldFun t e
wf = forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall e. Erasable e -> Maybe e
erasableToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Last a -> a
getLast) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t e. WorldFun t e -> Coords -> (t, Erasable (Last e))
getWF WorldFun t e
wf

instance Bifunctor WorldFun where
  bimap :: forall a b c d.
(a -> b) -> (c -> d) -> WorldFun a c -> WorldFun b d
bimap a -> b
g c -> d
h (WF Coords -> (a, Erasable (Last c))
z) = forall t e. (Coords -> (t, Erasable (Last e))) -> WorldFun t e
WF (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap a -> b
g (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c -> d
h)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coords -> (a, Erasable (Last c))
z)

-- | Create a world function from a finite array of specified cells.
worldFunFromArray :: Monoid t => Array (Int32, Int32) (t, Erasable e) -> WorldFun t e
worldFunFromArray :: forall t e.
Monoid t =>
Array (Int32, Int32) (t, Erasable e) -> WorldFun t e
worldFunFromArray Array (Int32, Int32) (t, Erasable e)
arr = forall t e. (Coords -> (t, Erasable (Last e))) -> WorldFun t e
WF forall a b. (a -> b) -> a -> b
$ \(Coords (Int32
r, Int32
c)) ->
  if forall a. Ix a => (a, a) -> a -> Bool
inRange ((Int32, Int32), (Int32, Int32))
bnds (Int32
r, Int32
c)
    then forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Last a
Last) (Array (Int32, Int32) (t, Erasable e)
arr forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! (Int32
r, Int32
c))
    else forall a. Monoid a => a
mempty
 where
  bnds :: ((Int32, Int32), (Int32, Int32))
bnds = forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
bounds Array (Int32, Int32) (t, Erasable e)
arr

------------------------------------------------------------
-- Tiles and coordinates
------------------------------------------------------------

-- | The number of bits we need in each coordinate to represent all
--   the locations in a tile.  In other words, each tile has a size of
--   @2^tileBits x 2^tileBits@.
--
--   Currently, 'tileBits' is set to 6, giving us 64x64 tiles, with
--   4096 cells in each tile. That seems intuitively like a good size,
--   but I don't have a good sense for the tradeoffs here, and I don't
--   know how much the choice of tile size matters.
tileBits :: Int
tileBits :: Int
tileBits = Int
6

-- | The number consisting of 'tileBits' many 1 bits.  We can use this
--   to mask out the tile offset of a coordinate.
tileMask :: Int32
tileMask :: Int32
tileMask = (Int32
1 forall a. Bits a => a -> Int -> a
`shiftL` Int
tileBits) forall a. Num a => a -> a -> a
- Int32
1

-- | If we think of the world as a grid of /tiles/, we can assign each
--   tile some coordinates in the same way we would if each tile was a
--   single cell.  These are the tile coordinates.
newtype TileCoords = TileCoords {TileCoords -> Coords
unTileCoords :: Coords}
  deriving (TileCoords -> TileCoords -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TileCoords -> TileCoords -> Bool
$c/= :: TileCoords -> TileCoords -> Bool
== :: TileCoords -> TileCoords -> Bool
$c== :: TileCoords -> TileCoords -> Bool
Eq, Eq TileCoords
TileCoords -> TileCoords -> Bool
TileCoords -> TileCoords -> Ordering
TileCoords -> TileCoords -> TileCoords
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TileCoords -> TileCoords -> TileCoords
$cmin :: TileCoords -> TileCoords -> TileCoords
max :: TileCoords -> TileCoords -> TileCoords
$cmax :: TileCoords -> TileCoords -> TileCoords
>= :: TileCoords -> TileCoords -> Bool
$c>= :: TileCoords -> TileCoords -> Bool
> :: TileCoords -> TileCoords -> Bool
$c> :: TileCoords -> TileCoords -> Bool
<= :: TileCoords -> TileCoords -> Bool
$c<= :: TileCoords -> TileCoords -> Bool
< :: TileCoords -> TileCoords -> Bool
$c< :: TileCoords -> TileCoords -> Bool
compare :: TileCoords -> TileCoords -> Ordering
$ccompare :: TileCoords -> TileCoords -> Ordering
Ord, Int -> TileCoords -> ShowS
[TileCoords] -> ShowS
TileCoords -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TileCoords] -> ShowS
$cshowList :: [TileCoords] -> ShowS
show :: TileCoords -> String
$cshow :: TileCoords -> String
showsPrec :: Int -> TileCoords -> ShowS
$cshowsPrec :: Int -> TileCoords -> ShowS
Show, Ord TileCoords
(TileCoords, TileCoords) -> Int
(TileCoords, TileCoords) -> [TileCoords]
(TileCoords, TileCoords) -> TileCoords -> Bool
(TileCoords, TileCoords) -> TileCoords -> Int
forall a.
Ord a
-> ((a, a) -> [a])
-> ((a, a) -> a -> Int)
-> ((a, a) -> a -> Int)
-> ((a, a) -> a -> Bool)
-> ((a, a) -> Int)
-> ((a, a) -> Int)
-> Ix a
unsafeRangeSize :: (TileCoords, TileCoords) -> Int
$cunsafeRangeSize :: (TileCoords, TileCoords) -> Int
rangeSize :: (TileCoords, TileCoords) -> Int
$crangeSize :: (TileCoords, TileCoords) -> Int
inRange :: (TileCoords, TileCoords) -> TileCoords -> Bool
$cinRange :: (TileCoords, TileCoords) -> TileCoords -> Bool
unsafeIndex :: (TileCoords, TileCoords) -> TileCoords -> Int
$cunsafeIndex :: (TileCoords, TileCoords) -> TileCoords -> Int
index :: (TileCoords, TileCoords) -> TileCoords -> Int
$cindex :: (TileCoords, TileCoords) -> TileCoords -> Int
range :: (TileCoords, TileCoords) -> [TileCoords]
$crange :: (TileCoords, TileCoords) -> [TileCoords]
Ix, forall x. Rep TileCoords x -> TileCoords
forall x. TileCoords -> Rep TileCoords x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TileCoords x -> TileCoords
$cfrom :: forall x. TileCoords -> Rep TileCoords x
Generic)

instance Rewrapped TileCoords t
instance Wrapped TileCoords

-- | Convert from a cell's coordinates to the coordinates of its tile,
--   simply by shifting out 'tileBits' many bits.
tileCoords :: Coords -> TileCoords
tileCoords :: Coords -> TileCoords
tileCoords = Coords -> TileCoords
TileCoords forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (forall s t. Rewrapping s t => Iso s t (Unwrapped s) (Unwrapped t)
_Wrapped forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (r :: * -> * -> *) a b.
Bitraversable r =>
Traversal (r a a) (r b b) a b
both) (forall a. Bits a => a -> Int -> a
`shiftR` Int
tileBits)

-- | Find the coordinates of the upper-left corner of a tile.
tileOrigin :: TileCoords -> Coords
tileOrigin :: TileCoords -> Coords
tileOrigin = forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (forall s t. Rewrapping s t => Iso s t (Unwrapped s) (Unwrapped t)
_Wrapped forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (r :: * -> * -> *) a b.
Bitraversable r =>
Traversal (r a a) (r b b) a b
both) (forall a. Bits a => a -> Int -> a
`shiftL` Int
tileBits) forall b c a. (b -> c) -> (a -> b) -> a -> c
. TileCoords -> Coords
unTileCoords

-- | A 'TileOffset' represents an offset from the upper-left corner of
--   some tile to a cell in its interior.
newtype TileOffset = TileOffset Coords
  deriving (TileOffset -> TileOffset -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TileOffset -> TileOffset -> Bool
$c/= :: TileOffset -> TileOffset -> Bool
== :: TileOffset -> TileOffset -> Bool
$c== :: TileOffset -> TileOffset -> Bool
Eq, Eq TileOffset
TileOffset -> TileOffset -> Bool
TileOffset -> TileOffset -> Ordering
TileOffset -> TileOffset -> TileOffset
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TileOffset -> TileOffset -> TileOffset
$cmin :: TileOffset -> TileOffset -> TileOffset
max :: TileOffset -> TileOffset -> TileOffset
$cmax :: TileOffset -> TileOffset -> TileOffset
>= :: TileOffset -> TileOffset -> Bool
$c>= :: TileOffset -> TileOffset -> Bool
> :: TileOffset -> TileOffset -> Bool
$c> :: TileOffset -> TileOffset -> Bool
<= :: TileOffset -> TileOffset -> Bool
$c<= :: TileOffset -> TileOffset -> Bool
< :: TileOffset -> TileOffset -> Bool
$c< :: TileOffset -> TileOffset -> Bool
compare :: TileOffset -> TileOffset -> Ordering
$ccompare :: TileOffset -> TileOffset -> Ordering
Ord, Int -> TileOffset -> ShowS
[TileOffset] -> ShowS
TileOffset -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TileOffset] -> ShowS
$cshowList :: [TileOffset] -> ShowS
show :: TileOffset -> String
$cshow :: TileOffset -> String
showsPrec :: Int -> TileOffset -> ShowS
$cshowsPrec :: Int -> TileOffset -> ShowS
Show, Ord TileOffset
(TileOffset, TileOffset) -> Int
(TileOffset, TileOffset) -> [TileOffset]
(TileOffset, TileOffset) -> TileOffset -> Bool
(TileOffset, TileOffset) -> TileOffset -> Int
forall a.
Ord a
-> ((a, a) -> [a])
-> ((a, a) -> a -> Int)
-> ((a, a) -> a -> Int)
-> ((a, a) -> a -> Bool)
-> ((a, a) -> Int)
-> ((a, a) -> Int)
-> Ix a
unsafeRangeSize :: (TileOffset, TileOffset) -> Int
$cunsafeRangeSize :: (TileOffset, TileOffset) -> Int
rangeSize :: (TileOffset, TileOffset) -> Int
$crangeSize :: (TileOffset, TileOffset) -> Int
inRange :: (TileOffset, TileOffset) -> TileOffset -> Bool
$cinRange :: (TileOffset, TileOffset) -> TileOffset -> Bool
unsafeIndex :: (TileOffset, TileOffset) -> TileOffset -> Int
$cunsafeIndex :: (TileOffset, TileOffset) -> TileOffset -> Int
index :: (TileOffset, TileOffset) -> TileOffset -> Int
$cindex :: (TileOffset, TileOffset) -> TileOffset -> Int
range :: (TileOffset, TileOffset) -> [TileOffset]
$crange :: (TileOffset, TileOffset) -> [TileOffset]
Ix, forall x. Rep TileOffset x -> TileOffset
forall x. TileOffset -> Rep TileOffset x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TileOffset x -> TileOffset
$cfrom :: forall x. TileOffset -> Rep TileOffset x
Generic)

-- | The offsets of the upper-left and lower-right corners of a tile:
--   (0,0) to ('tileMask', 'tileMask').
tileBounds :: (TileOffset, TileOffset)
tileBounds :: (TileOffset, TileOffset)
tileBounds = (Coords -> TileOffset
TileOffset ((Int32, Int32) -> Coords
Coords (Int32
0, Int32
0)), Coords -> TileOffset
TileOffset ((Int32, Int32) -> Coords
Coords (Int32
tileMask, Int32
tileMask)))

-- | Compute the offset of a given coordinate within its tile.
tileOffset :: Coords -> TileOffset
tileOffset :: Coords -> TileOffset
tileOffset = Coords -> TileOffset
TileOffset forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (forall s t. Rewrapping s t => Iso s t (Unwrapped s) (Unwrapped t)
_Wrapped forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (r :: * -> * -> *) a b.
Bitraversable r =>
Traversal (r a a) (r b b) a b
both) (forall a. Bits a => a -> a -> a
.&. Int32
tileMask)

-- | Add a tile offset to the coordinates of the tile's upper left
--   corner.  NOTE that for efficiency, this function only works when
--   the first argument is in fact the coordinates of a tile's
--   upper-left corner (/i.e./ it is an output of 'tileOrigin').  In
--   that case the coordinates will end with all 0 bits, and we can
--   add the tile offset just by doing a coordinatewise 'xor'.
plusOffset :: Coords -> TileOffset -> Coords
plusOffset :: Coords -> TileOffset -> Coords
plusOffset (Coords (Int32
x1, Int32
y1)) (TileOffset (Coords (Int32
x2, Int32
y2))) = (Int32, Int32) -> Coords
Coords (Int32
x1 forall a. Bits a => a -> a -> a
`xor` Int32
x2, Int32
y1 forall a. Bits a => a -> a -> a
`xor` Int32
y2)

instance Rewrapped TileOffset t
instance Wrapped TileOffset

-- | A terrain tile is an unboxed array of terrain values.
type TerrainTile t = U.UArray TileOffset t

-- | An entity tile is an array of possible entity values.  Note it
--   cannot be an unboxed array since entities are complex records
--   which have to be boxed.
type EntityTile e = A.Array TileOffset (Maybe e)

type MultiWorld t e = Map SubworldName (World t e)

-- | A 'World' consists of a 'WorldFun' that specifies the initial
--   world, a cache of loaded square tiles to make lookups faster, and
--   a map storing locations whose entities have changed from their
--   initial values.
--
--   Right now the 'World' simply holds on to all the tiles it has
--   ever loaded.  Ideally it would use some kind of LRU caching
--   scheme to keep memory usage bounded, but it would be a bit
--   tricky, and in any case it's probably not going to matter much
--   for a while.  Once tile loads can trigger robots to spawn, it
--   would also make for some difficult decisions in terms of how to
--   handle respawning.
data World t e = World
  { forall t e. World t e -> WorldFun t e
_worldFun :: WorldFun t e
  , forall t e.
World t e -> Map TileCoords (TerrainTile t, EntityTile e)
_tileCache :: M.Map TileCoords (TerrainTile t, EntityTile e)
  , forall t e. World t e -> Map Coords (Maybe e)
_changed :: M.Map Coords (Maybe e)
  }

-- | Create a new 'World' from a 'WorldFun'.
newWorld :: WorldFun t e -> World t e
newWorld :: forall t e. WorldFun t e -> World t e
newWorld WorldFun t e
f = forall t e.
WorldFun t e
-> Map TileCoords (TerrainTile t, EntityTile e)
-> Map Coords (Maybe e)
-> World t e
World WorldFun t e
f forall k a. Map k a
M.empty forall k a. Map k a
M.empty

lookupCosmicTerrain ::
  IArray U.UArray Int =>
  Cosmic Coords ->
  MultiWorld Int e ->
  TerrainType
lookupCosmicTerrain :: forall e.
IArray UArray Int =>
Cosmic Coords -> MultiWorld Int e -> TerrainType
lookupCosmicTerrain (Cosmic SubworldName
subworldName Coords
i) MultiWorld Int e
multiWorld =
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe TerrainType
BlankT (forall a. Enum a => Int -> a
toEnum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t e. IArray UArray t => Coords -> World t e -> t
lookupTerrain Coords
i) forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup SubworldName
subworldName MultiWorld Int e
multiWorld

-- | Look up the terrain value at certain coordinates: try looking it
--   up in the tile cache first, and fall back to running the 'WorldFun'
--   otherwise.
--
--   This function does /not/ ensure that the tile containing the
--   given coordinates is loaded.  For that, see 'lookupTerrainM'.
lookupTerrain :: (IArray U.UArray t) => Coords -> World t e -> t
lookupTerrain :: forall t e. IArray UArray t => Coords -> World t e -> t
lookupTerrain Coords
i (World WorldFun t e
f Map TileCoords (TerrainTile t, EntityTile e)
t Map Coords (Maybe e)
_) =
  ((forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
U.! Coords -> TileOffset
tileOffset Coords
i) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Coords -> TileCoords
tileCoords Coords
i) Map TileCoords (TerrainTile t, EntityTile e)
t)
    forall a. Maybe a -> a -> a
? forall a b. (a, b) -> a
fst (forall t e. WorldFun t e -> Coords -> (t, Maybe e)
runWF WorldFun t e
f Coords
i)

-- | A stateful variant of 'lookupTerrain', which first loads the tile
--   containing the given coordinates if it is not already loaded,
--   then looks up the terrain value.
lookupTerrainM ::
  forall t e sig m.
  (Has (State (World t e)) sig m, IArray U.UArray t) =>
  Coords ->
  m t
lookupTerrainM :: forall t e (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State (World t e)) sig m, IArray UArray t) =>
Coords -> m t
lookupTerrainM Coords
c = do
  forall s (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
(s -> s) -> m ()
modify @(World t e) forall a b. (a -> b) -> a -> b
$ forall t e. IArray UArray t => Coords -> World t e -> World t e
loadCell Coords
c
  forall t e. IArray UArray t => Coords -> World t e -> t
lookupTerrain Coords
c forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
m s
get @(World t e)

lookupCosmicEntity :: Cosmic Coords -> MultiWorld t e -> Maybe e
lookupCosmicEntity :: forall t e. Cosmic Coords -> MultiWorld t e -> Maybe e
lookupCosmicEntity (Cosmic SubworldName
subworldName Coords
i) MultiWorld t e
multiWorld =
  forall t e. Coords -> World t e -> Maybe e
lookupEntity Coords
i forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup SubworldName
subworldName MultiWorld t e
multiWorld

-- | Look up the entity at certain coordinates: first, see if it is in
--   the map of locations with changed entities; then try looking it
--   up in the tile cache first; and finally fall back to running the
--   'WorldFun'.
--
--   This function does /not/ ensure that the tile containing the
--   given coordinates is loaded.  For that, see 'lookupEntityM'.
lookupEntity :: Coords -> World t e -> Maybe e
lookupEntity :: forall t e. Coords -> World t e -> Maybe e
lookupEntity Coords
i (World WorldFun t e
f Map TileCoords (TerrainTile t, EntityTile e)
t Map Coords (Maybe e)
m) =
  forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Coords
i Map Coords (Maybe e)
m
    forall a. Maybe a -> a -> a
? ((forall i e. Ix i => Array i e -> i -> e
A.! Coords -> TileOffset
tileOffset Coords
i) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Coords -> TileCoords
tileCoords Coords
i) Map TileCoords (TerrainTile t, EntityTile e)
t)
    forall a. Maybe a -> a -> a
? forall a b. (a, b) -> b
snd (forall t e. WorldFun t e -> Coords -> (t, Maybe e)
runWF WorldFun t e
f Coords
i)

-- | A stateful variant of 'lookupEntity', which first loads the tile
--   containing the given coordinates if it is not already loaded,
--   then looks up the terrain value.
lookupEntityM ::
  forall t e sig m.
  (Has (State (World t e)) sig m, IArray U.UArray t) =>
  Coords ->
  m (Maybe e)
lookupEntityM :: forall t e (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State (World t e)) sig m, IArray UArray t) =>
Coords -> m (Maybe e)
lookupEntityM Coords
c = do
  forall s (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
(s -> s) -> m ()
modify @(World t e) forall a b. (a -> b) -> a -> b
$ forall t e. IArray UArray t => Coords -> World t e -> World t e
loadCell Coords
c
  forall t e. Coords -> World t e -> Maybe e
lookupEntity Coords
c forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
m s
get @(World t e)

-- | Update the entity (or absence thereof) at a certain location,
--   returning an updated 'World' and a Boolean indicating whether
--   the update changed the entity here.
--   See also 'updateM'.
update ::
  Coords ->
  (Maybe Entity -> Maybe Entity) ->
  World t Entity ->
  (World t Entity, CellUpdate Entity)
update :: forall t.
Coords
-> (Maybe Entity -> Maybe Entity)
-> World t Entity
-> (World t Entity, CellUpdate Entity)
update Coords
i Maybe Entity -> Maybe Entity
g w :: World t Entity
w@(World WorldFun t Entity
f Map TileCoords (TerrainTile t, EntityTile Entity)
t Map Coords (Maybe Entity)
m) =
  (World t Entity
wNew, Maybe Entity -> Maybe Entity -> CellUpdate Entity
classifyModification Maybe Entity
entityBefore Maybe Entity
entityAfter)
 where
  wNew :: World t Entity
wNew = forall t e.
WorldFun t e
-> Map TileCoords (TerrainTile t, EntityTile e)
-> Map Coords (Maybe e)
-> World t e
World WorldFun t Entity
f Map TileCoords (TerrainTile t, EntityTile Entity)
t forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Coords
i Maybe Entity
entityAfter Map Coords (Maybe Entity)
m
  entityBefore :: Maybe Entity
entityBefore = forall t e. Coords -> World t e -> Maybe e
lookupEntity Coords
i World t Entity
w
  entityAfter :: Maybe Entity
entityAfter = Maybe Entity -> Maybe Entity
g Maybe Entity
entityBefore

-- | A stateful variant of 'update', which also ensures the tile
--   containing the given coordinates is loaded.
updateM ::
  forall t sig m.
  (Has (State (World t Entity)) sig m, IArray U.UArray t) =>
  Coords ->
  (Maybe Entity -> Maybe Entity) ->
  m (CellUpdate Entity)
updateM :: forall t (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State (World t Entity)) sig m, IArray UArray t) =>
Coords -> (Maybe Entity -> Maybe Entity) -> m (CellUpdate Entity)
updateM Coords
c Maybe Entity -> Maybe Entity
g = do
  forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (State s) sig m =>
(s -> (s, a)) -> m a
state @(World t Entity) forall a b. (a -> b) -> a -> b
$ forall t.
Coords
-> (Maybe Entity -> Maybe Entity)
-> World t Entity
-> (World t Entity, CellUpdate Entity)
update Coords
c Maybe Entity -> Maybe Entity
g forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t e. IArray UArray t => Coords -> World t e -> World t e
loadCell Coords
c

-- | Load the tile containing a specific cell.
loadCell :: (IArray U.UArray t) => Coords -> World t e -> World t e
loadCell :: forall t e. IArray UArray t => Coords -> World t e -> World t e
loadCell Coords
c = forall t e.
IArray UArray t =>
(Coords, Coords) -> World t e -> World t e
loadRegion (Coords
c, Coords
c)

-- | Load all the tiles which overlap the given rectangular region
--   (specified as an upper-left and lower-right corner, inclusive).
loadRegion ::
  forall t e.
  (IArray U.UArray t) =>
  (Coords, Coords) ->
  World t e ->
  World t e
loadRegion :: forall t e.
IArray UArray t =>
(Coords, Coords) -> World t e -> World t e
loadRegion (Coords, Coords)
reg (World WorldFun t e
f Map TileCoords (TerrainTile t, EntityTile e)
t Map Coords (Maybe e)
m) = forall t e.
WorldFun t e
-> Map TileCoords (TerrainTile t, EntityTile e)
-> Map Coords (Maybe e)
-> World t e
World WorldFun t e
f Map TileCoords (TerrainTile t, EntityTile e)
t' Map Coords (Maybe e)
m
 where
  tiles :: [TileCoords]
tiles = forall a. Ix a => (a, a) -> [a]
range (forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall (r :: * -> * -> *) a b.
Bitraversable r =>
Traversal (r a a) (r b b) a b
both Coords -> TileCoords
tileCoords (Coords, Coords)
reg)
  t' :: Map TileCoords (TerrainTile t, EntityTile e)
t' = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Map TileCoords (TerrainTile t, EntityTile e)
hm (TileCoords
i, (TerrainTile t, EntityTile e)
tile) -> forall k a. Ord k => k -> a -> Map k a -> Map k a
maybeInsert TileCoords
i (TerrainTile t, EntityTile e)
tile Map TileCoords (TerrainTile t, EntityTile e)
hm) Map TileCoords (TerrainTile t, EntityTile e)
t (forall a b. (a -> b) -> [a] -> [b]
map (forall a. a -> a
id forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& TileCoords -> (TerrainTile t, EntityTile e)
loadTile) [TileCoords]
tiles)

  maybeInsert :: k -> a -> Map k a -> Map k a
maybeInsert k
k a
v Map k a
tm
    | k
k forall k a. Ord k => k -> Map k a -> Bool
`M.member` Map k a
tm = Map k a
tm
    | Bool
otherwise = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert k
k a
v Map k a
tm

  loadTile :: TileCoords -> (TerrainTile t, EntityTile e)
  loadTile :: TileCoords -> (TerrainTile t, EntityTile e)
loadTile TileCoords
tc = (forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
listArray (TileOffset, TileOffset)
tileBounds [t]
terrain, forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
listArray (TileOffset, TileOffset)
tileBounds [Maybe e]
entities)
   where
    tileCorner :: Coords
tileCorner = TileCoords -> Coords
tileOrigin TileCoords
tc
    ([t]
terrain, [Maybe e]
entities) = forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall t e. WorldFun t e -> Coords -> (t, Maybe e)
runWF WorldFun t e
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coords -> TileOffset -> Coords
plusOffset Coords
tileCorner) (forall a. Ix a => (a, a) -> [a]
range (TileOffset, TileOffset)
tileBounds)

---------------------------------------------------------------------
-- Runtime world update
---------------------------------------------------------------------

-- | Enumeration of world updates.  This type is used for changes by
--   /e.g./ the @drill@ command which must be carried out at a later
--   tick. Using a first-order representation (as opposed to /e.g./
--   just a @World -> World@ function) allows us to serialize and
--   inspect the updates.
data WorldUpdate e = ReplaceEntity
  { forall e. WorldUpdate e -> Cosmic Location
updatedLoc :: Cosmic Location
  , forall e. WorldUpdate e -> e
originalEntity :: e
  , forall e. WorldUpdate e -> Maybe e
newEntity :: Maybe e
  }
  deriving (WorldUpdate e -> WorldUpdate e -> Bool
forall e. Eq e => WorldUpdate e -> WorldUpdate e -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WorldUpdate e -> WorldUpdate e -> Bool
$c/= :: forall e. Eq e => WorldUpdate e -> WorldUpdate e -> Bool
== :: WorldUpdate e -> WorldUpdate e -> Bool
$c== :: forall e. Eq e => WorldUpdate e -> WorldUpdate e -> Bool
Eq, WorldUpdate e -> WorldUpdate e -> Bool
WorldUpdate e -> WorldUpdate e -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {e}. Ord e => Eq (WorldUpdate e)
forall e. Ord e => WorldUpdate e -> WorldUpdate e -> Bool
forall e. Ord e => WorldUpdate e -> WorldUpdate e -> Ordering
forall e. Ord e => WorldUpdate e -> WorldUpdate e -> WorldUpdate e
min :: WorldUpdate e -> WorldUpdate e -> WorldUpdate e
$cmin :: forall e. Ord e => WorldUpdate e -> WorldUpdate e -> WorldUpdate e
max :: WorldUpdate e -> WorldUpdate e -> WorldUpdate e
$cmax :: forall e. Ord e => WorldUpdate e -> WorldUpdate e -> WorldUpdate e
>= :: WorldUpdate e -> WorldUpdate e -> Bool
$c>= :: forall e. Ord e => WorldUpdate e -> WorldUpdate e -> Bool
> :: WorldUpdate e -> WorldUpdate e -> Bool
$c> :: forall e. Ord e => WorldUpdate e -> WorldUpdate e -> Bool
<= :: WorldUpdate e -> WorldUpdate e -> Bool
$c<= :: forall e. Ord e => WorldUpdate e -> WorldUpdate e -> Bool
< :: WorldUpdate e -> WorldUpdate e -> Bool
$c< :: forall e. Ord e => WorldUpdate e -> WorldUpdate e -> Bool
compare :: WorldUpdate e -> WorldUpdate e -> Ordering
$ccompare :: forall e. Ord e => WorldUpdate e -> WorldUpdate e -> Ordering
Ord, Int -> WorldUpdate e -> ShowS
forall e. Show e => Int -> WorldUpdate e -> ShowS
forall e. Show e => [WorldUpdate e] -> ShowS
forall e. Show e => WorldUpdate e -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WorldUpdate e] -> ShowS
$cshowList :: forall e. Show e => [WorldUpdate e] -> ShowS
show :: WorldUpdate e -> String
$cshow :: forall e. Show e => WorldUpdate e -> String
showsPrec :: Int -> WorldUpdate e -> ShowS
$cshowsPrec :: forall e. Show e => Int -> WorldUpdate e -> ShowS
Show, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall e x. Rep (WorldUpdate e) x -> WorldUpdate e
forall e x. WorldUpdate e -> Rep (WorldUpdate e) x
$cto :: forall e x. Rep (WorldUpdate e) x -> WorldUpdate e
$cfrom :: forall e x. WorldUpdate e -> Rep (WorldUpdate e) x
Generic, forall e. FromJSON e => Value -> Parser [WorldUpdate e]
forall e. FromJSON e => Value -> Parser (WorldUpdate e)
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [WorldUpdate e]
$cparseJSONList :: forall e. FromJSON e => Value -> Parser [WorldUpdate e]
parseJSON :: Value -> Parser (WorldUpdate e)
$cparseJSON :: forall e. FromJSON e => Value -> Parser (WorldUpdate e)
FromJSON, forall e. ToJSON e => [WorldUpdate e] -> Encoding
forall e. ToJSON e => [WorldUpdate e] -> Value
forall e. ToJSON e => WorldUpdate e -> Encoding
forall e. ToJSON e => WorldUpdate e -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [WorldUpdate e] -> Encoding
$ctoEncodingList :: forall e. ToJSON e => [WorldUpdate e] -> Encoding
toJSONList :: [WorldUpdate e] -> Value
$ctoJSONList :: forall e. ToJSON e => [WorldUpdate e] -> Value
toEncoding :: WorldUpdate e -> Encoding
$ctoEncoding :: forall e. ToJSON e => WorldUpdate e -> Encoding
toJSON :: WorldUpdate e -> Value
$ctoJSON :: forall e. ToJSON e => WorldUpdate e -> Value
ToJSON)