{-# LANGUAGE TemplateHaskell #-}

-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Robot-specific subrecords and utilities used by 'Swarm.Game.State.GameState'
module Swarm.Game.State.Robot (
  -- * Types
  ViewCenterRule (..),
  Robots,

  -- * Robot naming
  RobotNaming,
  nameGenerator,
  gensym,
  robotNaming,

  -- * Initialization
  initRobots,
  setRobotInfo,

  -- * Accessors
  robotMap,
  robotsByLocation,
  robotsWatching,
  activeRobots,
  waitingRobots,
  currentTickWakeableBots,
  viewCenterRule,
  viewCenter,
  focusedRobotID,

  -- * Utilities
  wakeWatchingRobots,
  sleepUntil,
  sleepForever,
  wakeUpRobotsDoneSleeping,
  deleteRobot,
  removeRobotFromLocationMap,
  activateRobot,
  addRobot,
  addRobotToLocation,
  addTRobot,
  addTRobot',

  -- ** View
  modifyViewCenter,
  unfocus,
  recalcViewCenter,
) where

import Control.Arrow (Arrow ((&&&)))
import Control.Effect.Lens
import Control.Effect.State (State)
import Control.Effect.Throw (Has)
import Control.Lens hiding (Const, use, uses, view, (%=), (+=), (.=), (<+=), (<<.=))
import Control.Monad (forM_, void)
import Data.Aeson (FromJSON, ToJSON)
import Data.IntMap (IntMap)
import Data.IntMap qualified as IM
import Data.IntSet (IntSet)
import Data.IntSet qualified as IS
import Data.IntSet.Lens (setOf)
import Data.List (partition)
import Data.Maybe (fromMaybe, mapMaybe)
import Data.MonoidMap (MonoidMap)
import Data.MonoidMap qualified as MM
import Data.Set qualified as S
import GHC.Generics (Generic)
import Swarm.Game.CESK (CESK (Waiting))
import Swarm.Game.Location
import Swarm.Game.Robot
import Swarm.Game.Robot.Concrete
import Swarm.Game.State.Config
import Swarm.Game.Tick
import Swarm.Game.Universe as U
import Swarm.ResourceLoading (NameGenerator)
import Swarm.Util ((<+=), (<<.=))
import Swarm.Util.Lens (makeLensesExcluding)

-- | The 'ViewCenterRule' specifies how to determine the center of the
--   world viewport.
data ViewCenterRule
  = -- | The view should be centered on an absolute position.
    VCLocation (Cosmic Location)
  | -- | The view should be centered on a certain robot.
    VCRobot RID
  deriving (ViewCenterRule -> ViewCenterRule -> Bool
(ViewCenterRule -> ViewCenterRule -> Bool)
-> (ViewCenterRule -> ViewCenterRule -> Bool) -> Eq ViewCenterRule
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ViewCenterRule -> ViewCenterRule -> Bool
== :: ViewCenterRule -> ViewCenterRule -> Bool
$c/= :: ViewCenterRule -> ViewCenterRule -> Bool
/= :: ViewCenterRule -> ViewCenterRule -> Bool
Eq, Eq ViewCenterRule
Eq ViewCenterRule =>
(ViewCenterRule -> ViewCenterRule -> Ordering)
-> (ViewCenterRule -> ViewCenterRule -> Bool)
-> (ViewCenterRule -> ViewCenterRule -> Bool)
-> (ViewCenterRule -> ViewCenterRule -> Bool)
-> (ViewCenterRule -> ViewCenterRule -> Bool)
-> (ViewCenterRule -> ViewCenterRule -> ViewCenterRule)
-> (ViewCenterRule -> ViewCenterRule -> ViewCenterRule)
-> Ord ViewCenterRule
ViewCenterRule -> ViewCenterRule -> Bool
ViewCenterRule -> ViewCenterRule -> Ordering
ViewCenterRule -> ViewCenterRule -> ViewCenterRule
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
$ccompare :: ViewCenterRule -> ViewCenterRule -> Ordering
compare :: ViewCenterRule -> ViewCenterRule -> Ordering
$c< :: ViewCenterRule -> ViewCenterRule -> Bool
< :: ViewCenterRule -> ViewCenterRule -> Bool
$c<= :: ViewCenterRule -> ViewCenterRule -> Bool
<= :: ViewCenterRule -> ViewCenterRule -> Bool
$c> :: ViewCenterRule -> ViewCenterRule -> Bool
> :: ViewCenterRule -> ViewCenterRule -> Bool
$c>= :: ViewCenterRule -> ViewCenterRule -> Bool
>= :: ViewCenterRule -> ViewCenterRule -> Bool
$cmax :: ViewCenterRule -> ViewCenterRule -> ViewCenterRule
max :: ViewCenterRule -> ViewCenterRule -> ViewCenterRule
$cmin :: ViewCenterRule -> ViewCenterRule -> ViewCenterRule
min :: ViewCenterRule -> ViewCenterRule -> ViewCenterRule
Ord, RID -> ViewCenterRule -> ShowS
[ViewCenterRule] -> ShowS
ViewCenterRule -> String
(RID -> ViewCenterRule -> ShowS)
-> (ViewCenterRule -> String)
-> ([ViewCenterRule] -> ShowS)
-> Show ViewCenterRule
forall a.
(RID -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: RID -> ViewCenterRule -> ShowS
showsPrec :: RID -> ViewCenterRule -> ShowS
$cshow :: ViewCenterRule -> String
show :: ViewCenterRule -> String
$cshowList :: [ViewCenterRule] -> ShowS
showList :: [ViewCenterRule] -> ShowS
Show, (forall x. ViewCenterRule -> Rep ViewCenterRule x)
-> (forall x. Rep ViewCenterRule x -> ViewCenterRule)
-> Generic ViewCenterRule
forall x. Rep ViewCenterRule x -> ViewCenterRule
forall x. ViewCenterRule -> Rep ViewCenterRule x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ViewCenterRule -> Rep ViewCenterRule x
from :: forall x. ViewCenterRule -> Rep ViewCenterRule x
$cto :: forall x. Rep ViewCenterRule x -> ViewCenterRule
to :: forall x. Rep ViewCenterRule x -> ViewCenterRule
Generic, Maybe ViewCenterRule
Value -> Parser [ViewCenterRule]
Value -> Parser ViewCenterRule
(Value -> Parser ViewCenterRule)
-> (Value -> Parser [ViewCenterRule])
-> Maybe ViewCenterRule
-> FromJSON ViewCenterRule
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser ViewCenterRule
parseJSON :: Value -> Parser ViewCenterRule
$cparseJSONList :: Value -> Parser [ViewCenterRule]
parseJSONList :: Value -> Parser [ViewCenterRule]
$comittedField :: Maybe ViewCenterRule
omittedField :: Maybe ViewCenterRule
FromJSON, [ViewCenterRule] -> Value
[ViewCenterRule] -> Encoding
ViewCenterRule -> Bool
ViewCenterRule -> Value
ViewCenterRule -> Encoding
(ViewCenterRule -> Value)
-> (ViewCenterRule -> Encoding)
-> ([ViewCenterRule] -> Value)
-> ([ViewCenterRule] -> Encoding)
-> (ViewCenterRule -> Bool)
-> ToJSON ViewCenterRule
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: ViewCenterRule -> Value
toJSON :: ViewCenterRule -> Value
$ctoEncoding :: ViewCenterRule -> Encoding
toEncoding :: ViewCenterRule -> Encoding
$ctoJSONList :: [ViewCenterRule] -> Value
toJSONList :: [ViewCenterRule] -> Value
$ctoEncodingList :: [ViewCenterRule] -> Encoding
toEncodingList :: [ViewCenterRule] -> Encoding
$comitField :: ViewCenterRule -> Bool
omitField :: ViewCenterRule -> Bool
ToJSON)

makePrisms ''ViewCenterRule

data RobotNaming = RobotNaming
  { RobotNaming -> NameGenerator
_nameGenerator :: NameGenerator
  , RobotNaming -> RID
_gensym :: Int
  }

makeLensesExcluding ['_nameGenerator] ''RobotNaming

--- | Read-only list of words, for use in building random robot names.
nameGenerator :: Getter RobotNaming NameGenerator
nameGenerator :: Getter RobotNaming NameGenerator
nameGenerator = (RobotNaming -> NameGenerator)
-> (NameGenerator -> f NameGenerator)
-> RobotNaming
-> f RobotNaming
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to RobotNaming -> NameGenerator
_nameGenerator

-- | A counter used to generate globally unique IDs.
gensym :: Lens' RobotNaming Int

data Robots = Robots
  { Robots -> IntMap Robot
_robotMap :: IntMap Robot
  , -- A set of robots to consider for the next game tick. It is guaranteed to
    -- be a subset of the keys of 'robotMap'. It may contain waiting or idle
    -- robots. But robots that are present in 'robotMap' and not in 'activeRobots'
    -- are guaranteed to be either waiting or idle.
    Robots -> IntSet
_activeRobots :: IntSet
  , -- A set of probably waiting robots, indexed by probable wake-up time. It
    -- may contain robots that are in fact active or idle, as well as robots
    -- that do not exist anymore. Its only guarantee is that once a robot name
    -- with its wake up time is inserted in it, it will remain there until the
    -- wake-up time is reached, at which point it is removed via
    -- 'wakeUpRobotsDoneSleeping'.
    -- Waiting robots for a given time are a list because it is cheaper to
    -- prepend to a list than insert into a 'Set'.
    Robots -> MonoidMap TickNumber [RID]
_waitingRobots :: MonoidMap TickNumber [RID]
  , Robots -> [RID]
_currentTickWakeableBots :: [RID]
  , Robots -> MonoidMap SubworldName (MonoidMap Location IntSet)
_robotsByLocation :: MonoidMap SubworldName (MonoidMap Location IntSet)
  , -- This member exists as an optimization so
    -- that we do not have to iterate over all "waiting" robots,
    -- since there may be many.
    Robots -> MonoidMap (Cosmic Location) IntSet
_robotsWatching :: MonoidMap (Cosmic Location) IntSet
  , Robots -> RobotNaming
_robotNaming :: RobotNaming
  , Robots -> ViewCenterRule
_viewCenterRule :: ViewCenterRule
  , Robots -> Cosmic Location
_viewCenter :: Cosmic Location
  , Robots -> RID
_focusedRobotID :: RID
  }

-- We want to access active and waiting robots via lenses inside
-- this module but to expose it as a Getter to protect invariants.
makeLensesFor
  [ ("_activeRobots", "internalActiveRobots")
  , ("_waitingRobots", "internalWaitingRobots")
  ]
  ''Robots

makeLensesExcluding ['_viewCenter, '_viewCenterRule, '_focusedRobotID, '_activeRobots, '_waitingRobots] ''Robots

-- | All the robots that currently exist in the game, indexed by ID.
robotMap :: Lens' Robots (IntMap Robot)

-- | The names of the robots that are currently not sleeping.
activeRobots :: Getter Robots IntSet
activeRobots :: Getter Robots IntSet
activeRobots = (IntSet -> f IntSet) -> Robots -> f Robots
Lens' Robots IntSet
internalActiveRobots

-- | The names of the robots that are currently sleeping, indexed by wake up
--   time. Note that this may not include all sleeping robots, particularly
--   those that are only taking a short nap (e.g. @wait 1@).
waitingRobots :: Getter Robots (MonoidMap TickNumber [RID])
waitingRobots :: Getter Robots (MonoidMap TickNumber [RID])
waitingRobots = (MonoidMap TickNumber [RID] -> f (MonoidMap TickNumber [RID]))
-> Robots -> f Robots
Lens' Robots (MonoidMap TickNumber [RID])
internalWaitingRobots

-- | Get a list of all the robots that are \"watching\" by location.
currentTickWakeableBots :: Lens' Robots [RID]

-- | The names of all robots that currently exist in the game, indexed by
--   location (which we need both for /e.g./ the @salvage@ command as
--   well as for actually drawing the world).  Unfortunately there is
--   no good way to automatically keep this up to date, since we don't
--   just want to completely rebuild it every time the 'robotMap'
--   changes.  Instead, we just make sure to update it every time the
--   location of a robot changes, or a robot is created or destroyed.
--   Fortunately, there are relatively few ways for these things to
--   happen.
robotsByLocation :: Lens' Robots (MonoidMap SubworldName (MonoidMap Location IntSet))

-- | Get a list of all the robots that are \"watching\" by location.
robotsWatching :: Lens' Robots (MonoidMap (Cosmic Location) IntSet)

-- | State and data for assigning identifiers to robots
robotNaming :: Lens' Robots RobotNaming

-- | The current center of the world view. Note that this cannot be
--   modified directly, since it is calculated automatically from the
--   'viewCenterRule'.  To modify the view center, either set the
--   'viewCenterRule', or use 'modifyViewCenter'.
viewCenter :: Getter Robots (Cosmic Location)
viewCenter :: Getter Robots (Cosmic Location)
viewCenter = (Robots -> Cosmic Location)
-> (Cosmic Location -> f (Cosmic Location)) -> Robots -> f Robots
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Robots -> Cosmic Location
_viewCenter

-- | The current robot in focus.
--
-- It is only a 'Getter' because this value should be updated only when
-- the 'viewCenterRule' is specified to be a robot.
--
-- Technically it's the last robot ID specified by 'viewCenterRule',
-- but that robot may not be alive anymore - to be safe use 'focusedRobot'.
focusedRobotID :: Getter Robots RID
focusedRobotID :: Getter Robots RID
focusedRobotID = (Robots -> RID) -> (RID -> f RID) -> Robots -> f Robots
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Robots -> RID
_focusedRobotID

-- * Utilities

initRobots :: GameStateConfig -> Robots
initRobots :: GameStateConfig -> Robots
initRobots GameStateConfig
gsc =
  Robots
    { _robotMap :: IntMap Robot
_robotMap = IntMap Robot
forall a. IntMap a
IM.empty
    , _activeRobots :: IntSet
_activeRobots = IntSet
IS.empty
    , _waitingRobots :: MonoidMap TickNumber [RID]
_waitingRobots = MonoidMap TickNumber [RID]
forall a. Monoid a => a
mempty
    , _currentTickWakeableBots :: [RID]
_currentTickWakeableBots = [RID]
forall a. Monoid a => a
mempty
    , _robotsByLocation :: MonoidMap SubworldName (MonoidMap Location IntSet)
_robotsByLocation = MonoidMap SubworldName (MonoidMap Location IntSet)
forall a. Monoid a => a
mempty
    , _robotsWatching :: MonoidMap (Cosmic Location) IntSet
_robotsWatching = MonoidMap (Cosmic Location) IntSet
forall a. Monoid a => a
mempty
    , _robotNaming :: RobotNaming
_robotNaming =
        RobotNaming
          { _nameGenerator :: NameGenerator
_nameGenerator = GameStateConfig -> NameGenerator
nameParts GameStateConfig
gsc
          , _gensym :: RID
_gensym = RID
0
          }
    , _viewCenterRule :: ViewCenterRule
_viewCenterRule = RID -> ViewCenterRule
VCRobot RID
0
    , _viewCenter :: Cosmic Location
_viewCenter = Cosmic Location
defaultCosmicLocation
    , _focusedRobotID :: RID
_focusedRobotID = RID
0
    }

-- | The current rule for determining the center of the world view.
--   It updates also, 'viewCenter' and 'focusedRobot' to keep
--   everything synchronized.
viewCenterRule :: Lens' Robots ViewCenterRule
viewCenterRule :: Lens' Robots ViewCenterRule
viewCenterRule = (Robots -> ViewCenterRule)
-> (Robots -> ViewCenterRule -> Robots)
-> Lens' Robots ViewCenterRule
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Robots -> ViewCenterRule
getter Robots -> ViewCenterRule -> Robots
setter
 where
  getter :: Robots -> ViewCenterRule
  getter :: Robots -> ViewCenterRule
getter = Robots -> ViewCenterRule
_viewCenterRule

  -- The setter takes care of updating 'viewCenter' and 'focusedRobot'
  -- So none of these fields get out of sync.
  setter :: Robots -> ViewCenterRule -> Robots
  setter :: Robots -> ViewCenterRule -> Robots
setter Robots
g ViewCenterRule
rule =
    case ViewCenterRule
rule of
      VCLocation Cosmic Location
loc -> Robots
g {_viewCenterRule = rule, _viewCenter = loc}
      VCRobot RID
rid ->
        let robotcenter :: Maybe (Cosmic Location)
robotcenter = Robots
g Robots
-> Getting (First (Cosmic Location)) Robots (Cosmic Location)
-> Maybe (Cosmic Location)
forall s a. s -> Getting (First a) s a -> Maybe a
^? (IntMap Robot -> Const (First (Cosmic Location)) (IntMap Robot))
-> Robots -> Const (First (Cosmic Location)) Robots
Lens' Robots (IntMap Robot)
robotMap ((IntMap Robot -> Const (First (Cosmic Location)) (IntMap Robot))
 -> Robots -> Const (First (Cosmic Location)) Robots)
-> ((Cosmic Location
     -> Const (First (Cosmic Location)) (Cosmic Location))
    -> IntMap Robot -> Const (First (Cosmic Location)) (IntMap Robot))
-> Getting (First (Cosmic Location)) Robots (Cosmic Location)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (IntMap Robot)
-> Traversal' (IntMap Robot) (IxValue (IntMap Robot))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix RID
Index (IntMap Robot)
rid ((Robot -> Const (First (Cosmic Location)) Robot)
 -> IntMap Robot -> Const (First (Cosmic Location)) (IntMap Robot))
-> ((Cosmic Location
     -> Const (First (Cosmic Location)) (Cosmic Location))
    -> Robot -> Const (First (Cosmic Location)) Robot)
-> (Cosmic Location
    -> Const (First (Cosmic Location)) (Cosmic Location))
-> IntMap Robot
-> Const (First (Cosmic Location)) (IntMap Robot)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Cosmic Location
 -> Const (First (Cosmic Location)) (Cosmic Location))
-> Robot -> Const (First (Cosmic Location)) Robot
Getter Robot (Cosmic Location)
robotLocation
         in -- retrieve the loc of the robot if it exists, Nothing otherwise.
            -- sometimes, lenses are amazing...
            case Maybe (Cosmic Location)
robotcenter of
              Maybe (Cosmic Location)
Nothing -> Robots
g
              Just Cosmic Location
loc -> Robots
g {_viewCenterRule = rule, _viewCenter = loc, _focusedRobotID = rid}

-- | Add a concrete instance of a robot template to the game state:
--   First, generate a unique ID number for it.  Then, add it to the
--   main robot map, the active robot set, and to to the index of
--   robots by location.
addTRobot :: (Has (State Robots) sig m) => CESK -> TRobot -> m ()
addTRobot :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State Robots) sig m =>
CESK -> TRobot -> m ()
addTRobot CESK
m TRobot
r = m Robot -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Robot -> m ()) -> m Robot -> m ()
forall a b. (a -> b) -> a -> b
$ CESK -> TRobot -> m Robot
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State Robots) sig m =>
CESK -> TRobot -> m Robot
addTRobot' CESK
m TRobot
r

-- | Like addTRobot, but return the newly instantiated robot.
addTRobot' :: (Has (State Robots) sig m) => CESK -> TRobot -> m Robot
addTRobot' :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State Robots) sig m =>
CESK -> TRobot -> m Robot
addTRobot' CESK
initialMachine TRobot
r = do
  RID
rid <- (RobotNaming -> (RID, RobotNaming)) -> Robots -> (RID, Robots)
Lens' Robots RobotNaming
robotNaming ((RobotNaming -> (RID, RobotNaming)) -> Robots -> (RID, Robots))
-> ((RID -> (RID, RID)) -> RobotNaming -> (RID, RobotNaming))
-> (RID -> (RID, RID))
-> Robots
-> (RID, Robots)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RID -> (RID, RID)) -> RobotNaming -> (RID, RobotNaming)
Lens' RobotNaming RID
gensym ((RID -> (RID, RID)) -> Robots -> (RID, Robots)) -> RID -> m RID
forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(Has (State s) sig m, Num a) =>
LensLike' ((,) a) s a -> a -> m a
<+= RID
1
  let newRobot :: Robot
newRobot = Maybe CESK -> RID -> TRobot -> Robot
instantiateRobot (CESK -> Maybe CESK
forall a. a -> Maybe a
Just CESK
initialMachine) RID
rid TRobot
r
  Robot -> m ()
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State Robots) sig m =>
Robot -> m ()
addRobot Robot
newRobot
  Robot -> m Robot
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Robot
newRobot

-- | Add a robot to the game state, adding it to the main robot map,
--   the active robot set, and to to the index of robots by
--   location.
addRobot :: (Has (State Robots) sig m) => Robot -> m ()
addRobot :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State Robots) sig m =>
Robot -> m ()
addRobot Robot
r = do
  (IntMap Robot -> Identity (IntMap Robot))
-> Robots -> Identity Robots
Lens' Robots (IntMap Robot)
robotMap ((IntMap Robot -> Identity (IntMap Robot))
 -> Robots -> Identity Robots)
-> (IntMap Robot -> IntMap Robot) -> m ()
forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= RID -> Robot -> IntMap Robot -> IntMap Robot
forall a. RID -> a -> IntMap a -> IntMap a
IM.insert RID
rid Robot
r
  RID -> Cosmic Location -> m ()
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State Robots) sig m =>
RID -> Cosmic Location -> m ()
addRobotToLocation RID
rid (Cosmic Location -> m ()) -> Cosmic Location -> m ()
forall a b. (a -> b) -> a -> b
$ Robot
r Robot
-> Getting (Cosmic Location) Robot (Cosmic Location)
-> Cosmic Location
forall s a. s -> Getting a s a -> a
^. Getting (Cosmic Location) Robot (Cosmic Location)
Getter Robot (Cosmic Location)
robotLocation
  (IntSet -> Identity IntSet) -> Robots -> Identity Robots
Lens' Robots IntSet
internalActiveRobots ((IntSet -> Identity IntSet) -> Robots -> Identity Robots)
-> (IntSet -> IntSet) -> m ()
forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= RID -> IntSet -> IntSet
IS.insert RID
rid
 where
  rid :: RID
rid = Robot
r Robot -> Getting RID Robot RID -> RID
forall s a. s -> Getting a s a -> a
^. Getting RID Robot RID
Getter Robot RID
robotID

-- | Helper function for updating the "robotsByLocation" bookkeeping
addRobotToLocation :: (Has (State Robots) sig m) => RID -> Cosmic Location -> m ()
addRobotToLocation :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State Robots) sig m =>
RID -> Cosmic Location -> m ()
addRobotToLocation RID
rid Cosmic Location
rLoc =
  (MonoidMap SubworldName (MonoidMap Location IntSet)
 -> Identity (MonoidMap SubworldName (MonoidMap Location IntSet)))
-> Robots -> Identity Robots
Lens' Robots (MonoidMap SubworldName (MonoidMap Location IntSet))
robotsByLocation
    ((MonoidMap SubworldName (MonoidMap Location IntSet)
  -> Identity (MonoidMap SubworldName (MonoidMap Location IntSet)))
 -> Robots -> Identity Robots)
-> (MonoidMap SubworldName (MonoidMap Location IntSet)
    -> MonoidMap SubworldName (MonoidMap Location IntSet))
-> m ()
forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= (MonoidMap Location IntSet -> MonoidMap Location IntSet)
-> SubworldName
-> MonoidMap SubworldName (MonoidMap Location IntSet)
-> MonoidMap SubworldName (MonoidMap Location IntSet)
forall k v.
(Ord k, MonoidNull v) =>
(v -> v) -> k -> MonoidMap k v -> MonoidMap k v
MM.adjust ((IntSet -> IntSet)
-> Location
-> MonoidMap Location IntSet
-> MonoidMap Location IntSet
forall k v.
(Ord k, MonoidNull v) =>
(v -> v) -> k -> MonoidMap k v -> MonoidMap k v
MM.adjust (RID -> IntSet -> IntSet
IS.insert RID
rid) (Cosmic Location
rLoc Cosmic Location
-> Getting Location (Cosmic Location) Location -> Location
forall s a. s -> Getting a s a -> a
^. Getting Location (Cosmic Location) Location
forall a1 a2 (f :: * -> *).
Functor f =>
(a1 -> f a2) -> Cosmic a1 -> f (Cosmic a2)
planar)) (Cosmic Location
rLoc Cosmic Location
-> Getting SubworldName (Cosmic Location) SubworldName
-> SubworldName
forall s a. s -> Getting a s a -> a
^. Getting SubworldName (Cosmic Location) SubworldName
forall a (f :: * -> *).
Functor f =>
(SubworldName -> f SubworldName) -> Cosmic a -> f (Cosmic a)
subworld)

-- | Takes a robot out of the 'activeRobots' set and puts it in the 'waitingRobots'
--   queue.
sleepUntil :: (Has (State Robots) sig m) => RID -> TickNumber -> m ()
sleepUntil :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State Robots) sig m =>
RID -> TickNumber -> m ()
sleepUntil RID
rid TickNumber
time = do
  (IntSet -> Identity IntSet) -> Robots -> Identity Robots
Lens' Robots IntSet
internalActiveRobots ((IntSet -> Identity IntSet) -> Robots -> Identity Robots)
-> (IntSet -> IntSet) -> m ()
forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= RID -> IntSet -> IntSet
IS.delete RID
rid
  (MonoidMap TickNumber [RID]
 -> Identity (MonoidMap TickNumber [RID]))
-> Robots -> Identity Robots
Lens' Robots (MonoidMap TickNumber [RID])
internalWaitingRobots ((MonoidMap TickNumber [RID]
  -> Identity (MonoidMap TickNumber [RID]))
 -> Robots -> Identity Robots)
-> (MonoidMap TickNumber [RID] -> MonoidMap TickNumber [RID])
-> m ()
forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= ([RID] -> [RID])
-> TickNumber
-> MonoidMap TickNumber [RID]
-> MonoidMap TickNumber [RID]
forall k v.
(Ord k, MonoidNull v) =>
(v -> v) -> k -> MonoidMap k v -> MonoidMap k v
MM.adjust (RID
rid RID -> [RID] -> [RID]
forall a. a -> [a] -> [a]
:) TickNumber
time

-- | Takes a robot out of the 'activeRobots' set.
sleepForever :: (Has (State Robots) sig m) => RID -> m ()
sleepForever :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State Robots) sig m =>
RID -> m ()
sleepForever RID
rid = (IntSet -> Identity IntSet) -> Robots -> Identity Robots
Lens' Robots IntSet
internalActiveRobots ((IntSet -> Identity IntSet) -> Robots -> Identity Robots)
-> (IntSet -> IntSet) -> m ()
forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= RID -> IntSet -> IntSet
IS.delete RID
rid

-- | Adds a robot to the 'activeRobots' set.
activateRobot :: (Has (State Robots) sig m) => RID -> m ()
activateRobot :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State Robots) sig m =>
RID -> m ()
activateRobot RID
rid = (IntSet -> Identity IntSet) -> Robots -> Identity Robots
Lens' Robots IntSet
internalActiveRobots ((IntSet -> Identity IntSet) -> Robots -> Identity Robots)
-> (IntSet -> IntSet) -> m ()
forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= RID -> IntSet -> IntSet
IS.insert RID
rid

-- | Removes robots whose wake up time matches the current game ticks count
--   from the 'waitingRobots' queue and put them back in the 'activeRobots' set
--   if they still exist in the keys of 'robotMap'.
--
-- = Mutations
--
-- This function modifies:
--
-- * 'wakeLog'
-- * 'robotsWatching'
-- * 'internalWaitingRobots'
-- * 'internalActiveRobots' (aka 'activeRobots')
wakeUpRobotsDoneSleeping :: (Has (State Robots) sig m) => TickNumber -> m ()
wakeUpRobotsDoneSleeping :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State Robots) sig m =>
TickNumber -> m ()
wakeUpRobotsDoneSleeping TickNumber
time = do
  IntSet
robotIdSet <- IntMap Robot -> IntSet
forall a. IntMap a -> IntSet
IM.keysSet (IntMap Robot -> IntSet) -> m (IntMap Robot) -> m IntSet
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting (IntMap Robot) Robots (IntMap Robot) -> m (IntMap Robot)
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getting (IntMap Robot) Robots (IntMap Robot)
Lens' Robots (IntMap Robot)
robotMap
  IntSet
wakeableRIDsSet <- [RID] -> IntSet
IS.fromList ([RID] -> IntSet)
-> (MonoidMap TickNumber [RID] -> [RID])
-> MonoidMap TickNumber [RID]
-> IntSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TickNumber -> MonoidMap TickNumber [RID] -> [RID]
forall k v. (Ord k, Monoid v) => k -> MonoidMap k v -> v
MM.get TickNumber
time (MonoidMap TickNumber [RID] -> IntSet)
-> m (MonoidMap TickNumber [RID]) -> m IntSet
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting
  (MonoidMap TickNumber [RID]) Robots (MonoidMap TickNumber [RID])
-> m (MonoidMap TickNumber [RID])
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getting
  (MonoidMap TickNumber [RID]) Robots (MonoidMap TickNumber [RID])
Lens' Robots (MonoidMap TickNumber [RID])
internalWaitingRobots
  (MonoidMap TickNumber [RID]
 -> Identity (MonoidMap TickNumber [RID]))
-> Robots -> Identity Robots
Lens' Robots (MonoidMap TickNumber [RID])
internalWaitingRobots ((MonoidMap TickNumber [RID]
  -> Identity (MonoidMap TickNumber [RID]))
 -> Robots -> Identity Robots)
-> (MonoidMap TickNumber [RID] -> MonoidMap TickNumber [RID])
-> m ()
forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= TickNumber
-> MonoidMap TickNumber [RID] -> MonoidMap TickNumber [RID]
forall k v. Ord k => k -> MonoidMap k v -> MonoidMap k v
MM.nullify TickNumber
time

  -- Limit ourselves to the robots that have not expired in their sleep
  let newlyAlive :: IntSet
newlyAlive = IntSet -> IntSet -> IntSet
IS.intersection IntSet
robotIdSet IntSet
wakeableRIDsSet

  (IntSet -> Identity IntSet) -> Robots -> Identity Robots
Lens' Robots IntSet
internalActiveRobots ((IntSet -> Identity IntSet) -> Robots -> Identity Robots)
-> (IntSet -> IntSet) -> m ()
forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= IntSet -> IntSet -> IntSet
IS.union IntSet
newlyAlive

  -- These robots' wake times may have been moved "forward"
  -- by 'wakeWatchingRobots'.
  IntSet -> m ()
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State Robots) sig m =>
IntSet -> m ()
clearWatchingRobots IntSet
wakeableRIDsSet

-- | Clear the "watch" state of all of the
-- awakened robots
clearWatchingRobots ::
  (Has (State Robots) sig m) =>
  IntSet ->
  m ()
clearWatchingRobots :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State Robots) sig m =>
IntSet -> m ()
clearWatchingRobots IntSet
rids = do
  (MonoidMap (Cosmic Location) IntSet
 -> Identity (MonoidMap (Cosmic Location) IntSet))
-> Robots -> Identity Robots
Lens' Robots (MonoidMap (Cosmic Location) IntSet)
robotsWatching ((MonoidMap (Cosmic Location) IntSet
  -> Identity (MonoidMap (Cosmic Location) IntSet))
 -> Robots -> Identity Robots)
-> (MonoidMap (Cosmic Location) IntSet
    -> MonoidMap (Cosmic Location) IntSet)
-> m ()
forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= (IntSet -> IntSet)
-> MonoidMap (Cosmic Location) IntSet
-> MonoidMap (Cosmic Location) IntSet
forall v2 v1 k.
MonoidNull v2 =>
(v1 -> v2) -> MonoidMap k v1 -> MonoidMap k v2
MM.map (IntSet -> IntSet -> IntSet
`IS.difference` IntSet
rids)

-- | Iterates through all of the currently @wait@-ing robots,
-- and moves forward the wake time of the ones that are @watch@-ing this location.
--
-- NOTE: Clearing 'TickNumber' map entries from 'internalWaitingRobots'
-- upon wakeup is handled by 'wakeUpRobotsDoneSleeping'
wakeWatchingRobots :: (Has (State Robots) sig m) => RID -> TickNumber -> Cosmic Location -> m ()
wakeWatchingRobots :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State Robots) sig m =>
RID -> TickNumber -> Cosmic Location -> m ()
wakeWatchingRobots RID
myID TickNumber
currentTick Cosmic Location
loc = do
  MonoidMap TickNumber [RID]
waitingMap <- Getting
  (MonoidMap TickNumber [RID]) Robots (MonoidMap TickNumber [RID])
-> m (MonoidMap TickNumber [RID])
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getting
  (MonoidMap TickNumber [RID]) Robots (MonoidMap TickNumber [RID])
Getter Robots (MonoidMap TickNumber [RID])
waitingRobots
  IntMap Robot
rMap <- Getting (IntMap Robot) Robots (IntMap Robot) -> m (IntMap Robot)
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getting (IntMap Robot) Robots (IntMap Robot)
Lens' Robots (IntMap Robot)
robotMap
  MonoidMap (Cosmic Location) IntSet
watchingMap <- Getting
  (MonoidMap (Cosmic Location) IntSet)
  Robots
  (MonoidMap (Cosmic Location) IntSet)
-> m (MonoidMap (Cosmic Location) IntSet)
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getting
  (MonoidMap (Cosmic Location) IntSet)
  Robots
  (MonoidMap (Cosmic Location) IntSet)
Lens' Robots (MonoidMap (Cosmic Location) IntSet)
robotsWatching

  -- The bookkeeping updates to robot waiting
  -- states are prepared in 4 steps...

  let -- Step 1: Identify the robots that are watching this location.
      botsWatchingThisLoc :: [Robot]
      botsWatchingThisLoc :: [Robot]
botsWatchingThisLoc =
        (RID -> Maybe Robot) -> [RID] -> [Robot]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (RID -> IntMap Robot -> Maybe Robot
forall a. RID -> IntMap a -> Maybe a
`IM.lookup` IntMap Robot
rMap) ([RID] -> [Robot]) -> [RID] -> [Robot]
forall a b. (a -> b) -> a -> b
$
          IntSet -> [RID]
IS.toList (IntSet -> [RID]) -> IntSet -> [RID]
forall a b. (a -> b) -> a -> b
$
            Cosmic Location -> MonoidMap (Cosmic Location) IntSet -> IntSet
forall k v. (Ord k, Monoid v) => k -> MonoidMap k v -> v
MM.get Cosmic Location
loc MonoidMap (Cosmic Location) IntSet
watchingMap

      -- Step 2: Get the target wake time for each of these robots
      wakeTimes :: [(RID, TickNumber)]
      wakeTimes :: [(RID, TickNumber)]
wakeTimes = (Robot -> Maybe (RID, TickNumber))
-> [Robot] -> [(RID, TickNumber)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((RID, Maybe TickNumber) -> Maybe (RID, TickNumber)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => (RID, f a) -> f (RID, a)
sequenceA ((RID, Maybe TickNumber) -> Maybe (RID, TickNumber))
-> (Robot -> (RID, Maybe TickNumber))
-> Robot
-> Maybe (RID, TickNumber)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Getting RID Robot RID -> Robot -> RID
forall r a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Reader r) sig m =>
Getting a r a -> m a
view Getting RID Robot RID
Getter Robot RID
robotID (Robot -> RID)
-> (Robot -> Maybe TickNumber) -> Robot -> (RID, Maybe TickNumber)
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')
&&& Robot -> Maybe TickNumber
waitingUntil)) [Robot]
botsWatchingThisLoc

      wakeTimesToPurge :: MonoidMap TickNumber (S.Set RID)
      wakeTimesToPurge :: MonoidMap TickNumber (Set RID)
wakeTimesToPurge = ((RID, TickNumber)
 -> MonoidMap TickNumber (Set RID)
 -> MonoidMap TickNumber (Set RID))
-> MonoidMap TickNumber (Set RID)
-> [(RID, TickNumber)]
-> MonoidMap TickNumber (Set RID)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((RID
 -> TickNumber
 -> MonoidMap TickNumber (Set RID)
 -> MonoidMap TickNumber (Set RID))
-> (RID, TickNumber)
-> MonoidMap TickNumber (Set RID)
-> MonoidMap TickNumber (Set RID)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Set RID -> Set RID)
-> TickNumber
-> MonoidMap TickNumber (Set RID)
-> MonoidMap TickNumber (Set RID)
forall k v.
(Ord k, MonoidNull v) =>
(v -> v) -> k -> MonoidMap k v -> MonoidMap k v
MM.adjust ((Set RID -> Set RID)
 -> TickNumber
 -> MonoidMap TickNumber (Set RID)
 -> MonoidMap TickNumber (Set RID))
-> (RID -> Set RID -> Set RID)
-> RID
-> TickNumber
-> MonoidMap TickNumber (Set RID)
-> MonoidMap TickNumber (Set RID)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RID -> Set RID -> Set RID
forall a. Ord a => a -> Set a -> Set a
S.insert)) MonoidMap TickNumber (Set RID)
forall a. Monoid a => a
mempty [(RID, TickNumber)]
wakeTimes

      -- Step 3: Take these robots out of their time-indexed slot in "waitingRobots".
      -- To preserve performance, this should be done without iterating over the
      -- entire "waitingRobots" map.
      filteredWaiting :: MonoidMap TickNumber [RID]
      filteredWaiting :: MonoidMap TickNumber [RID]
filteredWaiting = (TickNumber
 -> Set RID
 -> MonoidMap TickNumber [RID]
 -> MonoidMap TickNumber [RID])
-> MonoidMap TickNumber [RID]
-> MonoidMap TickNumber (Set RID)
-> MonoidMap TickNumber [RID]
forall k v r. (k -> v -> r -> r) -> r -> MonoidMap k v -> r
MM.foldrWithKey TickNumber
-> Set RID
-> MonoidMap TickNumber [RID]
-> MonoidMap TickNumber [RID]
forall {k} {a}.
(Ord k, Ord a) =>
k -> Set a -> MonoidMap k [a] -> MonoidMap k [a]
f MonoidMap TickNumber [RID]
waitingMap MonoidMap TickNumber (Set RID)
wakeTimesToPurge
       where
        f :: k -> Set a -> MonoidMap k [a] -> MonoidMap k [a]
f k
k Set a
botsToRemove = ([a] -> [a]) -> k -> MonoidMap k [a] -> MonoidMap k [a]
forall k v.
(Ord k, MonoidNull v) =>
(v -> v) -> k -> MonoidMap k v -> MonoidMap k v
MM.adjust ((a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter (a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.notMember` Set a
botsToRemove)) k
k

      -- Step 4: Re-add the watching bots to be awakened ASAP:
      wakeableBotIds :: [RID]
wakeableBotIds = ((RID, TickNumber) -> RID) -> [(RID, TickNumber)] -> [RID]
forall a b. (a -> b) -> [a] -> [b]
map (RID, TickNumber) -> RID
forall a b. (a, b) -> a
fst [(RID, TickNumber)]
wakeTimes

      -- It is crucial that only robots with a larger RID than the current robot
      -- be scheduled for the *same* tick, since within a given tick we iterate over
      -- robots in increasing order of RID.
      -- See note in 'iterateRobots'.
      ([RID]
currTickWakeable, [RID]
nextTickWakeable) = (RID -> Bool) -> [RID] -> ([RID], [RID])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (RID -> RID -> Bool
forall a. Ord a => a -> a -> Bool
> RID
myID) [RID]
wakeableBotIds
      wakeTimeGroups :: [(TickNumber, [RID])]
wakeTimeGroups =
        [ (TickNumber
currentTick, [RID]
currTickWakeable)
        , (RID -> TickNumber -> TickNumber
addTicks RID
1 TickNumber
currentTick, [RID]
nextTickWakeable)
        ]
      newInsertions :: MonoidMap TickNumber [RID]
newInsertions = [(TickNumber, [RID])] -> MonoidMap TickNumber [RID]
forall k v. (Ord k, MonoidNull v) => [(k, v)] -> MonoidMap k v
MM.fromList [(TickNumber, [RID])]
wakeTimeGroups

  -- Contract: This must be emptied immediately
  -- in 'iterateRobots'
  ([RID] -> Identity [RID]) -> Robots -> Identity Robots
Lens' Robots [RID]
currentTickWakeableBots (([RID] -> Identity [RID]) -> Robots -> Identity Robots)
-> [RID] -> m ()
forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= [RID]
currTickWakeable

  -- NOTE: There are two "sources of truth" for the waiting state of robots:
  -- 1. In the GameState via "internalWaitingRobots"
  -- 2. In each robot, via the CESK machine state

  -- 1. Update the game state
  (MonoidMap TickNumber [RID]
 -> Identity (MonoidMap TickNumber [RID]))
-> Robots -> Identity Robots
Lens' Robots (MonoidMap TickNumber [RID])
internalWaitingRobots ((MonoidMap TickNumber [RID]
  -> Identity (MonoidMap TickNumber [RID]))
 -> Robots -> Identity Robots)
-> MonoidMap TickNumber [RID] -> m ()
forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= MonoidMap TickNumber [RID]
filteredWaiting MonoidMap TickNumber [RID]
-> MonoidMap TickNumber [RID] -> MonoidMap TickNumber [RID]
forall a. Semigroup a => a -> a -> a
<> MonoidMap TickNumber [RID]
newInsertions

  -- 2. Update the machine of each robot
  [(TickNumber, [RID])] -> ((TickNumber, [RID]) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(TickNumber, [RID])]
wakeTimeGroups (((TickNumber, [RID]) -> m ()) -> m ())
-> ((TickNumber, [RID]) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(TickNumber
newWakeTime, [RID]
wakeableBots) ->
    [RID] -> (RID -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [RID]
wakeableBots ((RID -> m ()) -> m ()) -> (RID -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \RID
rid ->
      (IntMap Robot -> Identity (IntMap Robot))
-> Robots -> Identity Robots
Lens' Robots (IntMap Robot)
robotMap ((IntMap Robot -> Identity (IntMap Robot))
 -> Robots -> Identity Robots)
-> ((CESK -> Identity CESK)
    -> IntMap Robot -> Identity (IntMap Robot))
-> (CESK -> Identity CESK)
-> Robots
-> Identity Robots
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (IntMap Robot)
-> Lens' (IntMap Robot) (Maybe (IxValue (IntMap Robot)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at RID
Index (IntMap Robot)
rid ((Maybe Robot -> Identity (Maybe Robot))
 -> IntMap Robot -> Identity (IntMap Robot))
-> ((CESK -> Identity CESK)
    -> Maybe Robot -> Identity (Maybe Robot))
-> (CESK -> Identity CESK)
-> IntMap Robot
-> Identity (IntMap Robot)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Robot -> Identity Robot) -> Maybe Robot -> Identity (Maybe Robot)
forall a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Maybe a) (f (Maybe b))
_Just ((Robot -> Identity Robot)
 -> Maybe Robot -> Identity (Maybe Robot))
-> ((CESK -> Identity CESK) -> Robot -> Identity Robot)
-> (CESK -> Identity CESK)
-> Maybe Robot
-> Identity (Maybe Robot)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CESK -> Identity CESK) -> Robot -> Identity Robot
Lens' Robot CESK
machine ((CESK -> Identity CESK) -> Robots -> Identity Robots)
-> (CESK -> CESK) -> m ()
forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= \case
        Waiting TickNumber
_ CESK
c -> TickNumber -> CESK -> CESK
Waiting TickNumber
newWakeTime CESK
c
        CESK
x -> CESK
x

deleteRobot :: (Has (State Robots) sig m) => RID -> m ()
deleteRobot :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State Robots) sig m =>
RID -> m ()
deleteRobot RID
rn = do
  (IntSet -> Identity IntSet) -> Robots -> Identity Robots
Lens' Robots IntSet
internalActiveRobots ((IntSet -> Identity IntSet) -> Robots -> Identity Robots)
-> (IntSet -> IntSet) -> m ()
forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= RID -> IntSet -> IntSet
IS.delete RID
rn
  Maybe Robot
mrobot <- (IntMap Robot -> (Maybe Robot, IntMap Robot))
-> Robots -> (Maybe Robot, Robots)
Lens' Robots (IntMap Robot)
robotMap ((IntMap Robot -> (Maybe Robot, IntMap Robot))
 -> Robots -> (Maybe Robot, Robots))
-> ((Maybe Robot -> (Maybe Robot, Maybe Robot))
    -> IntMap Robot -> (Maybe Robot, IntMap Robot))
-> (Maybe Robot -> (Maybe Robot, Maybe Robot))
-> Robots
-> (Maybe Robot, Robots)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (IntMap Robot)
-> Lens' (IntMap Robot) (Maybe (IxValue (IntMap Robot)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at RID
Index (IntMap Robot)
rn ((Maybe Robot -> (Maybe Robot, Maybe Robot))
 -> Robots -> (Maybe Robot, Robots))
-> Maybe Robot -> m (Maybe Robot)
forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a b.
Has (State s) sig m =>
LensLike ((,) a) s s a b -> b -> m a
<<.= Maybe Robot
forall a. Maybe a
Nothing
  Maybe Robot
mrobot Maybe Robot -> (Robot -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
`forM_` \Robot
robot -> do
    -- Delete the robot from the index of robots by location.
    Cosmic Location -> RID -> m ()
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State Robots) sig m =>
Cosmic Location -> RID -> m ()
removeRobotFromLocationMap (Robot
robot Robot
-> Getting (Cosmic Location) Robot (Cosmic Location)
-> Cosmic Location
forall s a. s -> Getting a s a -> a
^. Getting (Cosmic Location) Robot (Cosmic Location)
Getter Robot (Cosmic Location)
robotLocation) RID
rn

-- | Makes sure empty sets don't hang around in the
-- 'robotsByLocation' map.  We don't want a key with an
-- empty set at every location any robot has ever
-- visited!
removeRobotFromLocationMap ::
  (Has (State Robots) sig m) =>
  Cosmic Location ->
  RID ->
  m ()
removeRobotFromLocationMap :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State Robots) sig m =>
Cosmic Location -> RID -> m ()
removeRobotFromLocationMap (Cosmic SubworldName
oldSubworld Location
oldPlanar) RID
rid =
  (MonoidMap SubworldName (MonoidMap Location IntSet)
 -> Identity (MonoidMap SubworldName (MonoidMap Location IntSet)))
-> Robots -> Identity Robots
Lens' Robots (MonoidMap SubworldName (MonoidMap Location IntSet))
robotsByLocation
    ((MonoidMap SubworldName (MonoidMap Location IntSet)
  -> Identity (MonoidMap SubworldName (MonoidMap Location IntSet)))
 -> Robots -> Identity Robots)
-> (MonoidMap SubworldName (MonoidMap Location IntSet)
    -> MonoidMap SubworldName (MonoidMap Location IntSet))
-> m ()
forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= (MonoidMap Location IntSet -> MonoidMap Location IntSet)
-> SubworldName
-> MonoidMap SubworldName (MonoidMap Location IntSet)
-> MonoidMap SubworldName (MonoidMap Location IntSet)
forall k v.
(Ord k, MonoidNull v) =>
(v -> v) -> k -> MonoidMap k v -> MonoidMap k v
MM.adjust ((IntSet -> IntSet)
-> Location
-> MonoidMap Location IntSet
-> MonoidMap Location IntSet
forall k v.
(Ord k, MonoidNull v) =>
(v -> v) -> k -> MonoidMap k v -> MonoidMap k v
MM.adjust (RID -> IntSet -> IntSet
IS.delete RID
rid) Location
oldPlanar) SubworldName
oldSubworld

setRobotInfo :: RID -> [Robot] -> Robots -> Robots
setRobotInfo :: RID -> [Robot] -> Robots -> Robots
setRobotInfo RID
baseID [Robot]
robotList Robots
rState =
  ([Robot] -> Robots -> Robots
setRobotList [Robot]
robotList Robots
rState) {_focusedRobotID = baseID}
    Robots -> (Robots -> Robots) -> Robots
forall a b. a -> (a -> b) -> b
& (ViewCenterRule -> Identity ViewCenterRule)
-> Robots -> Identity Robots
Lens' Robots ViewCenterRule
viewCenterRule ((ViewCenterRule -> Identity ViewCenterRule)
 -> Robots -> Identity Robots)
-> ViewCenterRule -> Robots -> Robots
forall s t a b. ASetter s t a b -> b -> s -> t
.~ RID -> ViewCenterRule
VCRobot RID
baseID

setRobotList :: [Robot] -> Robots -> Robots
setRobotList :: [Robot] -> Robots -> Robots
setRobotList [Robot]
robotList Robots
rState =
  Robots
rState
    Robots -> (Robots -> Robots) -> Robots
forall a b. a -> (a -> b) -> b
& (IntMap Robot -> Identity (IntMap Robot))
-> Robots -> Identity Robots
Lens' Robots (IntMap Robot)
robotMap ((IntMap Robot -> Identity (IntMap Robot))
 -> Robots -> Identity Robots)
-> IntMap Robot -> Robots -> Robots
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [(RID, Robot)] -> IntMap Robot
forall a. [(RID, a)] -> IntMap a
IM.fromList ((Robot -> (RID, Robot)) -> [Robot] -> [(RID, Robot)]
forall a b. (a -> b) -> [a] -> [b]
map (Getting RID Robot RID -> Robot -> RID
forall r a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Reader r) sig m =>
Getting a r a -> m a
view Getting RID Robot RID
Getter Robot RID
robotID (Robot -> RID) -> (Robot -> Robot) -> Robot -> (RID, Robot)
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')
&&& Robot -> Robot
forall a. a -> a
id) [Robot]
robotList)
    Robots -> (Robots -> Robots) -> Robots
forall a b. a -> (a -> b) -> b
& (MonoidMap SubworldName (MonoidMap Location IntSet)
 -> Identity (MonoidMap SubworldName (MonoidMap Location IntSet)))
-> Robots -> Identity Robots
Lens' Robots (MonoidMap SubworldName (MonoidMap Location IntSet))
robotsByLocation ((MonoidMap SubworldName (MonoidMap Location IntSet)
  -> Identity (MonoidMap SubworldName (MonoidMap Location IntSet)))
 -> Robots -> Identity Robots)
-> MonoidMap SubworldName (MonoidMap Location IntSet)
-> Robots
-> Robots
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Robot] -> MonoidMap SubworldName (MonoidMap Location IntSet)
groupRobotsByLocation [Robot]
robotList
    Robots -> (Robots -> Robots) -> Robots
forall a b. a -> (a -> b) -> b
& (IntSet -> Identity IntSet) -> Robots -> Identity Robots
Lens' Robots IntSet
internalActiveRobots ((IntSet -> Identity IntSet) -> Robots -> Identity Robots)
-> IntSet -> Robots -> Robots
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Getting IntSet [Robot] RID -> [Robot] -> IntSet
forall s. Getting IntSet s RID -> s -> IntSet
setOf ((Robot -> Const IntSet Robot) -> [Robot] -> Const IntSet [Robot]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((Robot -> Const IntSet Robot) -> [Robot] -> Const IntSet [Robot])
-> ((RID -> Const IntSet RID) -> Robot -> Const IntSet Robot)
-> Getting IntSet [Robot] RID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RID -> Const IntSet RID) -> Robot -> Const IntSet Robot
Getter Robot RID
robotID) [Robot]
robotList
    Robots -> (Robots -> Robots) -> Robots
forall a b. a -> (a -> b) -> b
& (RobotNaming -> Identity RobotNaming) -> Robots -> Identity Robots
Lens' Robots RobotNaming
robotNaming ((RobotNaming -> Identity RobotNaming)
 -> Robots -> Identity Robots)
-> ((RID -> Identity RID) -> RobotNaming -> Identity RobotNaming)
-> (RID -> Identity RID)
-> Robots
-> Identity Robots
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RID -> Identity RID) -> RobotNaming -> Identity RobotNaming
Lens' RobotNaming RID
gensym ((RID -> Identity RID) -> Robots -> Identity Robots)
-> RID -> Robots -> Robots
forall s t a b. ASetter s t a b -> b -> s -> t
.~ RID
initGensym
 where
  initGensym :: RID
initGensym = [Robot] -> RID
forall a. [a] -> RID
forall (t :: * -> *) a. Foldable t => t a -> RID
length [Robot]
robotList RID -> RID -> RID
forall a. Num a => a -> a -> a
- RID
1

  groupRobotsByLocation :: [Robot] -> MonoidMap SubworldName (MonoidMap Location IntSet)
groupRobotsByLocation = (Robot
 -> MonoidMap SubworldName (MonoidMap Location IntSet)
 -> MonoidMap SubworldName (MonoidMap Location IntSet))
-> MonoidMap SubworldName (MonoidMap Location IntSet)
-> [Robot]
-> MonoidMap SubworldName (MonoidMap Location IntSet)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Robot
-> MonoidMap SubworldName (MonoidMap Location IntSet)
-> MonoidMap SubworldName (MonoidMap Location IntSet)
f MonoidMap SubworldName (MonoidMap Location IntSet)
forall a. Monoid a => a
mempty
   where
    f :: Robot
-> MonoidMap SubworldName (MonoidMap Location IntSet)
-> MonoidMap SubworldName (MonoidMap Location IntSet)
f Robot
r = (MonoidMap Location IntSet -> MonoidMap Location IntSet)
-> SubworldName
-> MonoidMap SubworldName (MonoidMap Location IntSet)
-> MonoidMap SubworldName (MonoidMap Location IntSet)
forall k v.
(Ord k, MonoidNull v) =>
(v -> v) -> k -> MonoidMap k v -> MonoidMap k v
MM.adjust (Robot -> MonoidMap Location IntSet -> MonoidMap Location IntSet
g Robot
r) (Robot
r Robot -> Getting SubworldName Robot SubworldName -> SubworldName
forall s a. s -> Getting a s a -> a
^. ((Cosmic Location -> Const SubworldName (Cosmic Location))
-> Robot -> Const SubworldName Robot
Getter Robot (Cosmic Location)
robotLocation ((Cosmic Location -> Const SubworldName (Cosmic Location))
 -> Robot -> Const SubworldName Robot)
-> Getting SubworldName (Cosmic Location) SubworldName
-> Getting SubworldName Robot SubworldName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting SubworldName (Cosmic Location) SubworldName
forall a (f :: * -> *).
Functor f =>
(SubworldName -> f SubworldName) -> Cosmic a -> f (Cosmic a)
subworld))
    g :: Robot -> MonoidMap Location IntSet -> MonoidMap Location IntSet
g Robot
r = (IntSet -> IntSet)
-> Location
-> MonoidMap Location IntSet
-> MonoidMap Location IntSet
forall k v.
(Ord k, MonoidNull v) =>
(v -> v) -> k -> MonoidMap k v -> MonoidMap k v
MM.adjust (RID -> IntSet -> IntSet
IS.insert (Robot
r Robot -> Getting RID Robot RID -> RID
forall s a. s -> Getting a s a -> a
^. Getting RID Robot RID
Getter Robot RID
robotID)) (Robot
r Robot -> Getting Location Robot Location -> Location
forall s a. s -> Getting a s a -> a
^. ((Cosmic Location -> Const Location (Cosmic Location))
-> Robot -> Const Location Robot
Getter Robot (Cosmic Location)
robotLocation ((Cosmic Location -> Const Location (Cosmic Location))
 -> Robot -> Const Location Robot)
-> Getting Location (Cosmic Location) Location
-> Getting Location Robot Location
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting Location (Cosmic Location) Location
forall a1 a2 (f :: * -> *).
Functor f =>
(a1 -> f a2) -> Cosmic a1 -> f (Cosmic a2)
planar))

-- | Modify the 'viewCenter' by applying an arbitrary function to the
--   current value.  Note that this also modifies the 'viewCenterRule'
--   to match.  After calling this function the 'viewCenterRule' will
--   specify a particular location, not a robot.
modifyViewCenter :: (Cosmic Location -> Cosmic Location) -> Robots -> Robots
modifyViewCenter :: (Cosmic Location -> Cosmic Location) -> Robots -> Robots
modifyViewCenter Cosmic Location -> Cosmic Location
update Robots
rInfo =
  Robots
rInfo
    Robots -> (Robots -> Robots) -> Robots
forall a b. a -> (a -> b) -> b
& case Robots
rInfo Robots
-> Getting ViewCenterRule Robots ViewCenterRule -> ViewCenterRule
forall s a. s -> Getting a s a -> a
^. Getting ViewCenterRule Robots ViewCenterRule
Lens' Robots ViewCenterRule
viewCenterRule of
      VCLocation Cosmic Location
l -> (ViewCenterRule -> Identity ViewCenterRule)
-> Robots -> Identity Robots
Lens' Robots ViewCenterRule
viewCenterRule ((ViewCenterRule -> Identity ViewCenterRule)
 -> Robots -> Identity Robots)
-> ViewCenterRule -> Robots -> Robots
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Cosmic Location -> ViewCenterRule
VCLocation (Cosmic Location -> Cosmic Location
update Cosmic Location
l)
      VCRobot RID
_ -> (ViewCenterRule -> Identity ViewCenterRule)
-> Robots -> Identity Robots
Lens' Robots ViewCenterRule
viewCenterRule ((ViewCenterRule -> Identity ViewCenterRule)
 -> Robots -> Identity Robots)
-> ViewCenterRule -> Robots -> Robots
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Cosmic Location -> ViewCenterRule
VCLocation (Cosmic Location -> Cosmic Location
update (Robots
rInfo Robots
-> Getting (Cosmic Location) Robots (Cosmic Location)
-> Cosmic Location
forall s a. s -> Getting a s a -> a
^. Getting (Cosmic Location) Robots (Cosmic Location)
Getter Robots (Cosmic Location)
viewCenter))

-- | "Unfocus" by modifying the view center rule to look at the
--   current location instead of a specific robot, and also set the
--   focused robot ID to an invalid value.  In classic mode this
--   causes the map view to become nothing but static.
unfocus :: Robots -> Robots
unfocus :: Robots -> Robots
unfocus = (\Robots
ri -> Robots
ri {_focusedRobotID = -1000}) (Robots -> Robots) -> (Robots -> Robots) -> Robots -> Robots
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Cosmic Location -> Cosmic Location) -> Robots -> Robots
modifyViewCenter Cosmic Location -> Cosmic Location
forall a. a -> a
id

-- | Recalculate the view center (and cache the result in the
--   'viewCenter' field) based on the current 'viewCenterRule'.  If
--   the 'viewCenterRule' specifies a robot which does not exist,
--   simply leave the current 'viewCenter' as it is.
recalcViewCenter :: Robots -> Robots
recalcViewCenter :: Robots -> Robots
recalcViewCenter Robots
rInfo =
  Robots
rInfo
    { _viewCenter = newViewCenter
    }
 where
  newViewCenter :: Cosmic Location
newViewCenter =
    Cosmic Location -> Maybe (Cosmic Location) -> Cosmic Location
forall a. a -> Maybe a -> a
fromMaybe (Robots
rInfo Robots
-> Getting (Cosmic Location) Robots (Cosmic Location)
-> Cosmic Location
forall s a. s -> Getting a s a -> a
^. Getting (Cosmic Location) Robots (Cosmic Location)
Getter Robots (Cosmic Location)
viewCenter) (Maybe (Cosmic Location) -> Cosmic Location)
-> Maybe (Cosmic Location) -> Cosmic Location
forall a b. (a -> b) -> a -> b
$
      ViewCenterRule -> IntMap Robot -> Maybe (Cosmic Location)
applyViewCenterRule (Robots
rInfo Robots
-> Getting ViewCenterRule Robots ViewCenterRule -> ViewCenterRule
forall s a. s -> Getting a s a -> a
^. Getting ViewCenterRule Robots ViewCenterRule
Lens' Robots ViewCenterRule
viewCenterRule) (Robots
rInfo Robots
-> Getting (IntMap Robot) Robots (IntMap Robot) -> IntMap Robot
forall s a. s -> Getting a s a -> a
^. Getting (IntMap Robot) Robots (IntMap Robot)
Lens' Robots (IntMap Robot)
robotMap)

-- | Given a current mapping from robot names to robots, apply a
--   'ViewCenterRule' to derive the location it refers to.  The result
--   is 'Maybe' because the rule may refer to a robot which does not
--   exist.
applyViewCenterRule :: ViewCenterRule -> IntMap Robot -> Maybe (Cosmic Location)
applyViewCenterRule :: ViewCenterRule -> IntMap Robot -> Maybe (Cosmic Location)
applyViewCenterRule (VCLocation Cosmic Location
l) IntMap Robot
_ = Cosmic Location -> Maybe (Cosmic Location)
forall a. a -> Maybe a
Just Cosmic Location
l
applyViewCenterRule (VCRobot RID
name) IntMap Robot
m = IntMap Robot
m IntMap Robot
-> ((Cosmic Location
     -> Const (First (Cosmic Location)) (Cosmic Location))
    -> IntMap Robot -> Const (First (Cosmic Location)) (IntMap Robot))
-> Maybe (Cosmic Location)
forall s a. s -> Getting (First a) s a -> Maybe a
^? Index (IntMap Robot)
-> Lens' (IntMap Robot) (Maybe (IxValue (IntMap Robot)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at RID
Index (IntMap Robot)
name ((Maybe Robot -> Const (First (Cosmic Location)) (Maybe Robot))
 -> IntMap Robot -> Const (First (Cosmic Location)) (IntMap Robot))
-> ((Cosmic Location
     -> Const (First (Cosmic Location)) (Cosmic Location))
    -> Maybe Robot -> Const (First (Cosmic Location)) (Maybe Robot))
-> (Cosmic Location
    -> Const (First (Cosmic Location)) (Cosmic Location))
-> IntMap Robot
-> Const (First (Cosmic Location)) (IntMap Robot)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Robot -> Const (First (Cosmic Location)) Robot)
-> Maybe Robot -> Const (First (Cosmic Location)) (Maybe Robot)
forall a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Maybe a) (f (Maybe b))
_Just ((Robot -> Const (First (Cosmic Location)) Robot)
 -> Maybe Robot -> Const (First (Cosmic Location)) (Maybe Robot))
-> ((Cosmic Location
     -> Const (First (Cosmic Location)) (Cosmic Location))
    -> Robot -> Const (First (Cosmic Location)) Robot)
-> (Cosmic Location
    -> Const (First (Cosmic Location)) (Cosmic Location))
-> Maybe Robot
-> Const (First (Cosmic Location)) (Maybe Robot)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Cosmic Location
 -> Const (First (Cosmic Location)) (Cosmic Location))
-> Robot -> Const (First (Cosmic Location)) Robot
Getter Robot (Cosmic Location)
robotLocation