-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Pathfinding cache invalidation logic
--
-- == Overview
-- Each time the 'Path' command is invoked, the computed
-- shortest-path is placed in in a cache specific to the invoking robot.
-- If the 'Path' command is invoked again by that robot
-- with identical arguments and from the same position, or a position lying
-- on the previously computed path, then the shortest path shall
-- be retrieved from the cache instead of being recomputed.
--
-- If the 'Path' command is re-invoked with different arguments
-- or from a novel position, then the shortest-path shall be
-- recomputed and the cache overwritten with this new result.
--
-- Asynchronous to the event of invoking the 'Path' command,
-- there are a variety of events that may invalidate
-- a previously-computed shortest path between some
-- location and a destination, including adding or removing
-- particular entities at certain locations.
--
-- Certain events allow for partial re-use of the previously
-- computed path.
module Swarm.Game.Step.Path.Cache (
  retrieveCachedPath,
  revalidatePathCache,
  recordCache,
) where

import Control.Arrow (left, (&&&))
import Control.Carrier.State.Lazy
import Control.Effect.Lens
import Control.Lens ((^.))
import Control.Monad (unless)
import Data.Either.Extra (maybeToEither)
import Data.IntMap qualified as IM
import Data.List.NonEmpty (NonEmpty)
import Data.List.NonEmpty qualified as NE
import Data.Map qualified as M
import Data.Tuple.Extra (both)
import Swarm.Game.Entity
import Swarm.Game.Location
import Swarm.Game.Robot
import Swarm.Game.Robot.Walk
import Swarm.Game.Scenario.Topography.Terraform
import Swarm.Game.State
import Swarm.Game.Step.Path.Cache.DistanceLimit
import Swarm.Game.Step.Path.Type
import Swarm.Game.Step.Path.Walkability (checkUnwalkable)
import Swarm.Game.Step.RobotStepState
import Swarm.Game.Step.Util.Inspect (robotWithID)
import Swarm.Game.Universe (Cosmic (..), SubworldName)
import Swarm.Util (prependList, tails1)
import Swarm.Util.RingBuffer qualified as RB

-- | Fetch the previously computed shortest path from the cache.
-- Log success or the reason it failed.
retrieveCachedPath ::
  HasRobotStepState sig m =>
  WalkabilityContext ->
  PathfindingParameters (Cosmic Location) ->
  m (Either CacheRetreivalInapplicability [Location])
retrieveCachedPath :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
WalkabilityContext
-> PathfindingParameters (Cosmic Location)
-> m (Either CacheRetreivalInapplicability [Location])
retrieveCachedPath WalkabilityContext
currentWalkabilityContext PathfindingParameters (Cosmic Location)
newParms = do
  IntMap PathfindingCache
pcr <- Getting
  (IntMap PathfindingCache) GameState (IntMap PathfindingCache)
-> m (IntMap PathfindingCache)
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use (Getting
   (IntMap PathfindingCache) GameState (IntMap PathfindingCache)
 -> m (IntMap PathfindingCache))
-> Getting
     (IntMap PathfindingCache) GameState (IntMap PathfindingCache)
-> m (IntMap PathfindingCache)
forall a b. (a -> b) -> a -> b
$ (PathCaching -> Const (IntMap PathfindingCache) PathCaching)
-> GameState -> Const (IntMap PathfindingCache) GameState
Lens' GameState PathCaching
pathCaching ((PathCaching -> Const (IntMap PathfindingCache) PathCaching)
 -> GameState -> Const (IntMap PathfindingCache) GameState)
-> ((IntMap PathfindingCache
     -> Const (IntMap PathfindingCache) (IntMap PathfindingCache))
    -> PathCaching -> Const (IntMap PathfindingCache) PathCaching)
-> Getting
     (IntMap PathfindingCache) GameState (IntMap PathfindingCache)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IntMap PathfindingCache
 -> Const (IntMap PathfindingCache) (IntMap PathfindingCache))
-> PathCaching -> Const (IntMap PathfindingCache) PathCaching
Lens' PathCaching (IntMap PathfindingCache)
pathCachingRobots
  RID
rid <- Getting RID Robot RID -> m RID
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getting RID Robot RID
Getter Robot RID
robotID
  let eitherCachedPath :: Either CacheRetreivalInapplicability [Location]
eitherCachedPath = RID
-> IntMap PathfindingCache
-> Either CacheRetreivalInapplicability [Location]
guardFailures RID
rid IntMap PathfindingCache
pcr
      myEntry :: CacheRetrievalAttempt
      myEntry :: CacheRetrievalAttempt
myEntry = (CacheRetreivalInapplicability -> CacheRetrievalAttempt)
-> ([Location] -> CacheRetrievalAttempt)
-> Either CacheRetreivalInapplicability [Location]
-> CacheRetrievalAttempt
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either CacheRetreivalInapplicability -> CacheRetrievalAttempt
RecomputationRequired (CacheRetrievalAttempt -> [Location] -> CacheRetrievalAttempt
forall a b. a -> b -> a
const CacheRetrievalAttempt
Success) Either CacheRetreivalInapplicability [Location]
eitherCachedPath

  (PathCaching -> Identity PathCaching)
-> GameState -> Identity GameState
Lens' GameState PathCaching
pathCaching ((PathCaching -> Identity PathCaching)
 -> GameState -> Identity GameState)
-> ((RingBuffer CacheLogEntry
     -> Identity (RingBuffer CacheLogEntry))
    -> PathCaching -> Identity PathCaching)
-> (RingBuffer CacheLogEntry
    -> Identity (RingBuffer CacheLogEntry))
-> GameState
-> Identity GameState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RingBuffer CacheLogEntry -> Identity (RingBuffer CacheLogEntry))
-> PathCaching -> Identity PathCaching
Lens' PathCaching (RingBuffer CacheLogEntry)
pathCachingLog
    ((RingBuffer CacheLogEntry -> Identity (RingBuffer CacheLogEntry))
 -> GameState -> Identity GameState)
-> (RingBuffer CacheLogEntry -> RingBuffer CacheLogEntry) -> m ()
forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= CacheLogEntry
-> RingBuffer CacheLogEntry -> RingBuffer CacheLogEntry
forall a. a -> RingBuffer a -> RingBuffer a
RB.insert (RID -> CacheEvent -> CacheLogEntry
CacheLogEntry RID
rid (CacheEvent -> CacheLogEntry) -> CacheEvent -> CacheLogEntry
forall a b. (a -> b) -> a -> b
$ CacheRetrievalAttempt -> CacheEvent
RetrievalAttempt CacheRetrievalAttempt
myEntry)

  Either CacheRetreivalInapplicability [Location]
-> m (Either CacheRetreivalInapplicability [Location])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Either CacheRetreivalInapplicability [Location]
eitherCachedPath
 where
  PathfindingParameters Maybe Integer
currentDistanceLimit (Cosmic SubworldName
currentSubworld Location
currentRobotLoc) PathfindingTarget
target = PathfindingParameters (Cosmic Location)
newParms

  guardFailures :: RID
-> IntMap PathfindingCache
-> Either CacheRetreivalInapplicability [Location]
guardFailures RID
rid IntMap PathfindingCache
pcr = do
    -- Checks whether this robot has a cached path
    PathfindingCache
cached <- CacheRetreivalInapplicability
-> Maybe PathfindingCache
-> Either CacheRetreivalInapplicability PathfindingCache
forall a b. a -> Maybe b -> Either a b
maybeToEither CacheRetreivalInapplicability
NotCached (Maybe PathfindingCache
 -> Either CacheRetreivalInapplicability PathfindingCache)
-> Maybe PathfindingCache
-> Either CacheRetreivalInapplicability PathfindingCache
forall a b. (a -> b) -> a -> b
$ RID -> IntMap PathfindingCache -> Maybe PathfindingCache
forall a. RID -> IntMap a -> Maybe a
IM.lookup RID
rid IntMap PathfindingCache
pcr

    let PathfindingCache PathfindingParameters SubworldName
prevParms WalkabilityContext
prevWalkabilityContext Location
_targetLoc (CachedPath NonEmpty Location
pathCells (TailMap Map Location [Location]
ps)) = PathfindingCache
cached
        PathfindingParameters Maybe Integer
prevDistLimit SubworldName
previousSubworldName PathfindingTarget
t = PathfindingParameters SubworldName
prevParms

    -- Subworlds must match
    Bool
-> Either CacheRetreivalInapplicability ()
-> Either CacheRetreivalInapplicability ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (SubworldName
previousSubworldName SubworldName -> SubworldName -> Bool
forall a. Eq a => a -> a -> Bool
== SubworldName
currentSubworld) (Either CacheRetreivalInapplicability ()
 -> Either CacheRetreivalInapplicability ())
-> Either CacheRetreivalInapplicability ()
-> Either CacheRetreivalInapplicability ()
forall a b. (a -> b) -> a -> b
$
      CacheRetreivalInapplicability
-> Either CacheRetreivalInapplicability ()
forall a b. a -> Either a b
Left (CacheRetreivalInapplicability
 -> Either CacheRetreivalInapplicability ())
-> CacheRetreivalInapplicability
-> Either CacheRetreivalInapplicability ()
forall a b. (a -> b) -> a -> b
$
        DifferentArgument -> CacheRetreivalInapplicability
DifferentArg DifferentArgument
NewSubworld

    -- Pathfinding target type must match
    Bool
-> Either CacheRetreivalInapplicability ()
-> Either CacheRetreivalInapplicability ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (PathfindingTarget
t PathfindingTarget -> PathfindingTarget -> Bool
forall a. Eq a => a -> a -> Bool
== PathfindingTarget
target) (Either CacheRetreivalInapplicability ()
 -> Either CacheRetreivalInapplicability ())
-> Either CacheRetreivalInapplicability ()
-> Either CacheRetreivalInapplicability ()
forall a b. (a -> b) -> a -> b
$
      CacheRetreivalInapplicability
-> Either CacheRetreivalInapplicability ()
forall a b. a -> Either a b
Left (CacheRetreivalInapplicability
 -> Either CacheRetreivalInapplicability ())
-> CacheRetreivalInapplicability
-> Either CacheRetreivalInapplicability ()
forall a b. (a -> b) -> a -> b
$
        DifferentArgument -> CacheRetreivalInapplicability
DifferentArg DifferentArgument
NewTargetType

    -- Walkability context must match
    Bool
-> Either CacheRetreivalInapplicability ()
-> Either CacheRetreivalInapplicability ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (WalkabilityContext
currentWalkabilityContext WalkabilityContext -> WalkabilityContext -> Bool
forall a. Eq a => a -> a -> Bool
== WalkabilityContext
prevWalkabilityContext) (Either CacheRetreivalInapplicability ()
 -> Either CacheRetreivalInapplicability ())
-> Either CacheRetreivalInapplicability ()
-> Either CacheRetreivalInapplicability ()
forall a b. (a -> b) -> a -> b
$
      CacheRetreivalInapplicability
-> Either CacheRetreivalInapplicability ()
forall a b. a -> Either a b
Left (CacheRetreivalInapplicability
 -> Either CacheRetreivalInapplicability ())
-> CacheRetreivalInapplicability
-> Either CacheRetreivalInapplicability ()
forall a b. (a -> b) -> a -> b
$
        DifferentArgument -> CacheRetreivalInapplicability
DifferentArg DifferentArgument
NewWalkabilityContext

    (DistanceLimitChange -> CacheRetreivalInapplicability)
-> Either DistanceLimitChange ()
-> Either CacheRetreivalInapplicability ()
forall b c d. (b -> c) -> Either b d -> Either c d
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left (DifferentArgument -> CacheRetreivalInapplicability
DifferentArg (DifferentArgument -> CacheRetreivalInapplicability)
-> (DistanceLimitChange -> DifferentArgument)
-> DistanceLimitChange
-> CacheRetreivalInapplicability
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DistanceLimitChange -> DifferentArgument
NewDistanceLimit) (Either DistanceLimitChange ()
 -> Either CacheRetreivalInapplicability ())
-> Either DistanceLimitChange ()
-> Either CacheRetreivalInapplicability ()
forall a b. (a -> b) -> a -> b
$
      Location
-> NonEmpty Location
-> Maybe Integer
-> Maybe Integer
-> Either DistanceLimitChange ()
getDistanceLimitInvalidation Location
currentRobotLoc NonEmpty Location
pathCells Maybe Integer
currentDistanceLimit Maybe Integer
prevDistLimit

    -- Checks whether invoked from the same position or a position lying
    -- on the previously computed path
    CacheRetreivalInapplicability
-> Maybe [Location]
-> Either CacheRetreivalInapplicability [Location]
forall a b. a -> Maybe b -> Either a b
maybeToEither CacheRetreivalInapplicability
PositionOutsidePath (Maybe [Location]
 -> Either CacheRetreivalInapplicability [Location])
-> Maybe [Location]
-> Either CacheRetreivalInapplicability [Location]
forall a b. (a -> b) -> a -> b
$ Location -> Map Location [Location] -> Maybe [Location]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Location
currentRobotLoc Map Location [Location]
ps

-- | Store a newly computed shortest path in the cache.
recordCache ::
  HasRobotStepState sig m =>
  PathfindingParameters SubworldName ->
  WalkabilityContext ->
  -- | includes robot starting position
  NonEmpty Location ->
  m ()
recordCache :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
PathfindingParameters SubworldName
-> WalkabilityContext -> NonEmpty Location -> m ()
recordCache PathfindingParameters SubworldName
parms WalkabilityContext
wc NonEmpty Location
pathLocs = do
  RID
rid <- Getting RID Robot RID -> m RID
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getting RID Robot RID
Getter Robot RID
robotID
  (PathCaching -> Identity PathCaching)
-> GameState -> Identity GameState
Lens' GameState PathCaching
pathCaching ((PathCaching -> Identity PathCaching)
 -> GameState -> Identity GameState)
-> ((IntMap PathfindingCache -> Identity (IntMap PathfindingCache))
    -> PathCaching -> Identity PathCaching)
-> (IntMap PathfindingCache -> Identity (IntMap PathfindingCache))
-> GameState
-> Identity GameState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IntMap PathfindingCache -> Identity (IntMap PathfindingCache))
-> PathCaching -> Identity PathCaching
Lens' PathCaching (IntMap PathfindingCache)
pathCachingRobots ((IntMap PathfindingCache -> Identity (IntMap PathfindingCache))
 -> GameState -> Identity GameState)
-> (IntMap PathfindingCache -> IntMap PathfindingCache) -> m ()
forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= RID
-> PathfindingCache
-> IntMap PathfindingCache
-> IntMap PathfindingCache
forall a. RID -> a -> IntMap a -> IntMap a
IM.insert RID
rid PathfindingCache
newCache
 where
  newCache :: PathfindingCache
newCache = PathfindingParameters SubworldName
-> WalkabilityContext -> Location -> CachedPath -> PathfindingCache
PathfindingCache PathfindingParameters SubworldName
parms WalkabilityContext
wc (NonEmpty Location -> Location
forall a. NonEmpty a -> a
NE.last NonEmpty Location
pathLocs) (CachedPath -> PathfindingCache) -> CachedPath -> PathfindingCache
forall a b. (a -> b) -> a -> b
$ NonEmpty Location -> TailMap -> CachedPath
CachedPath NonEmpty Location
pathLocs (TailMap -> CachedPath) -> TailMap -> CachedPath
forall a b. (a -> b) -> a -> b
$ NonEmpty Location -> TailMap
mkTailMap NonEmpty Location
pathLocs

-- | For every non-empty suffix of the path, place its tail in a map keyed
-- by its head.
mkTailMap :: NonEmpty Location -> TailMap
mkTailMap :: NonEmpty Location -> TailMap
mkTailMap NonEmpty Location
pathLocs = Map Location [Location] -> TailMap
TailMap Map Location [Location]
locsMap
 where
  locsMap :: Map Location [Location]
locsMap = [(Location, [Location])] -> Map Location [Location]
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Location, [Location])] -> Map Location [Location])
-> (NonEmpty (NonEmpty Location) -> [(Location, [Location])])
-> NonEmpty (NonEmpty Location)
-> Map Location [Location]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (Location, [Location]) -> [(Location, [Location])]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty (Location, [Location]) -> [(Location, [Location])])
-> (NonEmpty (NonEmpty Location)
    -> NonEmpty (Location, [Location]))
-> NonEmpty (NonEmpty Location)
-> [(Location, [Location])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NonEmpty Location -> (Location, [Location]))
-> NonEmpty (NonEmpty Location) -> NonEmpty (Location, [Location])
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map (NonEmpty Location -> Location
forall a. NonEmpty a -> a
NE.head (NonEmpty Location -> Location)
-> (NonEmpty Location -> [Location])
-> NonEmpty Location
-> (Location, [Location])
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')
&&& NonEmpty Location -> [Location]
forall a. NonEmpty a -> [a]
NE.tail) (NonEmpty (NonEmpty Location) -> Map Location [Location])
-> NonEmpty (NonEmpty Location) -> Map Location [Location]
forall a b. (a -> b) -> a -> b
$ NonEmpty Location -> NonEmpty (NonEmpty Location)
forall a. NonEmpty a -> NonEmpty (NonEmpty a)
tails1 NonEmpty Location
pathLocs

-- |
-- Returns either a 'Left' which mandates cache invalidation (with a reason),
-- or a 'Right' containing a 'Maybe'; 'Nothing' indicates the cache should
-- remain unchanged, while 'Just' supplies a modified cache entry.
--
-- Cache is affected by modification of:
--
-- * cell walkability (i.e., an entity is placed or removed
--   that is "unwalkable" (blacklist) or "exclusively walkable" (whitelist)
--   with respect to the invoking robot
-- * "target" entities (if the `path` command had been invoked
--   with the modified entity as a target). Note that it is impossible
--   to find a path to an "unwalkable" target, so this nonsensical case
--   is ignored for the purpose of cache invalidation.
perhapsInvalidateForRobot ::
  WalkabilityContext ->
  -- | location of modified cell
  Cosmic Location ->
  -- | nature of entity modification
  CellModification Entity ->
  PathfindingCache ->
  Either InvalidationReason (Maybe PathfindingCache)
perhapsInvalidateForRobot :: WalkabilityContext
-> Cosmic Location
-> CellModification Entity
-> PathfindingCache
-> Either InvalidationReason (Maybe PathfindingCache)
perhapsInvalidateForRobot
  WalkabilityContext
walkInfo
  (Cosmic SubworldName
swn Location
entityLoc)
  CellModification Entity
entityModification
  oldCache :: PathfindingCache
oldCache@(PathfindingCache PathfindingParameters SubworldName
parms WalkabilityContext
_previousWalkabilityInfo Location
destLoc CachedPath
p)
    | SubworldName
swn SubworldName -> SubworldName -> Bool
forall a. Eq a => a -> a -> Bool
/= SubworldName
pathSubworld = Maybe PathfindingCache
-> Either InvalidationReason (Maybe PathfindingCache)
forall a b. b -> Either a b
Right Maybe PathfindingCache
forall a. Maybe a
Nothing
    | Bool
otherwise = case CellModification Entity
entityModification of
        Swap Entity
oldEntity Entity
newEntity -> (Maybe Entity, Maybe Entity)
-> Either InvalidationReason (Maybe PathfindingCache)
deriveBarrierModification ((Maybe Entity, Maybe Entity)
 -> Either InvalidationReason (Maybe PathfindingCache))
-> (Maybe Entity, Maybe Entity)
-> Either InvalidationReason (Maybe PathfindingCache)
forall a b. (a -> b) -> a -> b
$ (Entity -> Maybe Entity)
-> (Entity, Entity) -> (Maybe Entity, Maybe Entity)
forall a b. (a -> b) -> (a, a) -> (b, b)
both Entity -> Maybe Entity
forall a. a -> Maybe a
Just (Entity
oldEntity, Entity
newEntity)
        Remove Entity
oldEntity -> (Maybe Entity, Maybe Entity)
-> Either InvalidationReason (Maybe PathfindingCache)
deriveBarrierModification (Entity -> Maybe Entity
forall a. a -> Maybe a
Just Entity
oldEntity, Maybe Entity
forall a. Maybe a
Nothing)
        Add Entity
newEntity -> (Maybe Entity, Maybe Entity)
-> Either InvalidationReason (Maybe PathfindingCache)
deriveBarrierModification (Maybe Entity
forall a. Maybe a
Nothing, Entity -> Maybe Entity
forall a. a -> Maybe a
Just Entity
newEntity)
   where
    PathfindingParameters Maybe Integer
_distLimit SubworldName
pathSubworld PathfindingTarget
tgt = PathfindingParameters SubworldName
parms
    CachedPath NonEmpty Location
origPath (TailMap Map Location [Location]
locmap) = CachedPath
p

    isWalkable :: Maybe Entity -> Bool
isWalkable = Maybe MoveFailureMode -> Bool
forall a. Maybe a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Maybe MoveFailureMode -> Bool)
-> (Maybe Entity -> Maybe MoveFailureMode) -> Maybe Entity -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WalkabilityContext -> Maybe Entity -> Maybe MoveFailureMode
checkUnwalkable WalkabilityContext
walkInfo
    isOnPath :: Bool
isOnPath = Location
entityLoc Location -> Map Location [Location] -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.member` Map Location [Location]
locmap

    -- NOTE: oldContent and newContent are guaranteed to be different,
    -- because the 'Swap' constructor enforces such.
    deriveBarrierModification :: (Maybe Entity, Maybe Entity)
-> Either InvalidationReason (Maybe PathfindingCache)
deriveBarrierModification change :: (Maybe Entity, Maybe Entity)
change@(Maybe Entity
_oldContent, Maybe Entity
newContent) =
      case PathfindingTarget
tgt of
        LocationTarget Location
_locTarget -> Either InvalidationReason (Maybe PathfindingCache)
forall {a}. Either InvalidationReason (Maybe a)
barrierChange
        -- If the location of the changed entity was the terminus
        -- of the path, and the path search is "by entity", then
        -- we know that the path must be invalidated due to removal
        -- of the goal.
        -- Also, we know that a "target entity" on the path will
        -- only ever exist the path's terminus; otherwise the
        -- terminus would have been earlier!
        EntityTarget EntityName
targetEntityName -> EntityName -> Either InvalidationReason (Maybe PathfindingCache)
handleEntityTarget EntityName
targetEntityName
     where
      handleEntityTarget :: EntityName -> Either InvalidationReason (Maybe PathfindingCache)
handleEntityTarget EntityName
targetEntityName
        | Location
destLoc Location -> Location -> Bool
forall a. Eq a => a -> a -> Bool
== Location
entityLoc = InvalidationReason
-> Either InvalidationReason (Maybe PathfindingCache)
forall a b. a -> Either a b
Left InvalidationReason
TargetEntityRemoved
        | Bool -> (Entity -> Bool) -> Maybe Entity -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True ((EntityName -> EntityName -> Bool
forall a. Eq a => a -> a -> Bool
/= EntityName
targetEntityName) (EntityName -> Bool) -> (Entity -> EntityName) -> Entity -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Entity -> Getting EntityName Entity EntityName -> EntityName
forall s a. s -> Getting a s a -> a
^. Getting EntityName Entity EntityName
Lens' Entity EntityName
entityName)) Maybe Entity
newContent = Either InvalidationReason (Maybe PathfindingCache)
forall {a}. Either InvalidationReason (Maybe a)
barrierChange
        | Bool
isOnPath = Maybe PathfindingCache
-> Either InvalidationReason (Maybe PathfindingCache)
forall a b. b -> Either a b
Right (Maybe PathfindingCache
 -> Either InvalidationReason (Maybe PathfindingCache))
-> Maybe PathfindingCache
-> Either InvalidationReason (Maybe PathfindingCache)
forall a b. (a -> b) -> a -> b
$ PathfindingCache -> Maybe PathfindingCache
forall a. a -> Maybe a
Just (PathfindingCache -> Maybe PathfindingCache)
-> PathfindingCache -> Maybe PathfindingCache
forall a b. (a -> b) -> a -> b
$ NonEmpty Location
-> Location -> PathfindingCache -> PathfindingCache
truncatePath NonEmpty Location
origPath Location
entityLoc PathfindingCache
oldCache
        | Bool
otherwise = InvalidationReason
-> Either InvalidationReason (Maybe PathfindingCache)
forall a b. a -> Either a b
Left InvalidationReason
TargetEntityAddedOutsidePath

      walkabilityPair :: (Bool, Bool)
walkabilityPair = (Maybe Entity -> Bool)
-> (Maybe Entity, Maybe Entity) -> (Bool, Bool)
forall a b. (a -> b) -> (a, a) -> (b, b)
both Maybe Entity -> Bool
isWalkable (Maybe Entity, Maybe Entity)
change
      barrierChange :: Either InvalidationReason (Maybe a)
barrierChange
        | (Bool -> Bool -> Bool) -> (Bool, Bool) -> Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Bool, Bool)
walkabilityPair = Maybe a -> Either InvalidationReason (Maybe a)
forall a b. b -> Either a b
Right Maybe a
forall a. Maybe a
Nothing
        | (Bool, Bool) -> Bool
forall a b. (a, b) -> b
snd (Bool, Bool)
walkabilityPair = InvalidationReason -> Either InvalidationReason (Maybe a)
forall a b. a -> Either a b
Left InvalidationReason
UnwalkableRemoved
        | Bool
isOnPath = InvalidationReason -> Either InvalidationReason (Maybe a)
forall a b. a -> Either a b
Left InvalidationReason
UnwalkableOntoPath
        -- addition of a barrier outside of the path is irrelevant.
        | Bool
otherwise = Maybe a -> Either InvalidationReason (Maybe a)
forall a b. b -> Either a b
Right Maybe a
forall a. Maybe a
Nothing

-- | If the newly-added target entity lies on the existing path,
-- truncate the path to set it as the goal.
truncatePath ::
  NonEmpty Location ->
  Location ->
  PathfindingCache ->
  PathfindingCache
truncatePath :: NonEmpty Location
-> Location -> PathfindingCache -> PathfindingCache
truncatePath NonEmpty Location
origPath Location
entityLoc PathfindingCache
oldCache =
  PathfindingCache
oldCache {cachedPath = CachedPath truncPath $ mkTailMap truncPath}
 where
  truncPath :: NonEmpty Location
truncPath = [Location] -> NonEmpty Location -> NonEmpty Location
forall a. [a] -> NonEmpty a -> NonEmpty a
prependList [Location]
truncPathExcludingEntityLoc (NonEmpty Location -> NonEmpty Location)
-> NonEmpty Location -> NonEmpty Location
forall a b. (a -> b) -> a -> b
$ Location -> NonEmpty Location
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Location
entityLoc
  truncPathExcludingEntityLoc :: [Location]
truncPathExcludingEntityLoc = (Location -> Bool) -> [Location] -> [Location]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Location -> Location -> Bool
forall a. Eq a => a -> a -> Bool
== Location
entityLoc) ([Location] -> [Location]) -> [Location] -> [Location]
forall a b. (a -> b) -> a -> b
$ NonEmpty Location -> [Location]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty Location
origPath

-- | Given an event that entails the modification of some cell,
-- check whether a shortest-path previously computed for a
-- given robot is still valid or can be updated.
revalidatePathCache ::
  (Has (State GameState) sig m) =>
  Cosmic Location ->
  CellModification Entity ->
  (RID, PathfindingCache) ->
  m ()
revalidatePathCache :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
Cosmic Location
-> CellModification Entity -> (RID, PathfindingCache) -> m ()
revalidatePathCache Cosmic Location
entityLoc CellModification Entity
entityModification (RID
rid, PathfindingCache
pc) = do
  Maybe Robot
maybeRobot <- RID -> m (Maybe Robot)
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
RID -> m (Maybe Robot)
robotWithID RID
rid
  let (CacheEvent
logEntry, IntMap PathfindingCache -> IntMap PathfindingCache
updateFunc) = Either InvalidationReason (Maybe PathfindingCache)
-> (CacheEvent, IntMap PathfindingCache -> IntMap PathfindingCache)
forall {a}.
Either InvalidationReason (Maybe a)
-> (CacheEvent, IntMap a -> IntMap a)
getCacheUpdate (Either InvalidationReason (Maybe PathfindingCache)
 -> (CacheEvent,
     IntMap PathfindingCache -> IntMap PathfindingCache))
-> Either InvalidationReason (Maybe PathfindingCache)
-> (CacheEvent, IntMap PathfindingCache -> IntMap PathfindingCache)
forall a b. (a -> b) -> a -> b
$ Maybe Robot -> Either InvalidationReason (Maybe PathfindingCache)
checkPath Maybe Robot
maybeRobot
  (PathCaching -> Identity PathCaching)
-> GameState -> Identity GameState
Lens' GameState PathCaching
pathCaching ((PathCaching -> Identity PathCaching)
 -> GameState -> Identity GameState)
-> ((IntMap PathfindingCache -> Identity (IntMap PathfindingCache))
    -> PathCaching -> Identity PathCaching)
-> (IntMap PathfindingCache -> Identity (IntMap PathfindingCache))
-> GameState
-> Identity GameState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IntMap PathfindingCache -> Identity (IntMap PathfindingCache))
-> PathCaching -> Identity PathCaching
Lens' PathCaching (IntMap PathfindingCache)
pathCachingRobots ((IntMap PathfindingCache -> Identity (IntMap PathfindingCache))
 -> GameState -> Identity GameState)
-> (IntMap PathfindingCache -> IntMap PathfindingCache) -> m ()
forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= IntMap PathfindingCache -> IntMap PathfindingCache
updateFunc
  (PathCaching -> Identity PathCaching)
-> GameState -> Identity GameState
Lens' GameState PathCaching
pathCaching ((PathCaching -> Identity PathCaching)
 -> GameState -> Identity GameState)
-> ((RingBuffer CacheLogEntry
     -> Identity (RingBuffer CacheLogEntry))
    -> PathCaching -> Identity PathCaching)
-> (RingBuffer CacheLogEntry
    -> Identity (RingBuffer CacheLogEntry))
-> GameState
-> Identity GameState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RingBuffer CacheLogEntry -> Identity (RingBuffer CacheLogEntry))
-> PathCaching -> Identity PathCaching
Lens' PathCaching (RingBuffer CacheLogEntry)
pathCachingLog ((RingBuffer CacheLogEntry -> Identity (RingBuffer CacheLogEntry))
 -> GameState -> Identity GameState)
-> (RingBuffer CacheLogEntry -> RingBuffer CacheLogEntry) -> m ()
forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= CacheLogEntry
-> RingBuffer CacheLogEntry -> RingBuffer CacheLogEntry
forall a. a -> RingBuffer a -> RingBuffer a
RB.insert (RID -> CacheEvent -> CacheLogEntry
CacheLogEntry RID
rid CacheEvent
logEntry)
 where
  checkPath :: Maybe Robot -> Either InvalidationReason (Maybe PathfindingCache)
checkPath = \case
    Maybe Robot
Nothing -> InvalidationReason
-> Either InvalidationReason (Maybe PathfindingCache)
forall a b. a -> Either a b
Left InvalidationReason
NonexistentRobot
    Just Robot
bot ->
      WalkabilityContext
-> Cosmic Location
-> CellModification Entity
-> PathfindingCache
-> Either InvalidationReason (Maybe PathfindingCache)
perhapsInvalidateForRobot
        (Getting WalkabilityContext Robot WalkabilityContext
-> Robot -> WalkabilityContext
forall r a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Reader r) sig m =>
Getting a r a -> m a
view Getting WalkabilityContext Robot WalkabilityContext
Getter Robot WalkabilityContext
walkabilityContext Robot
bot)
        Cosmic Location
entityLoc
        CellModification Entity
entityModification
        PathfindingCache
pc

  getCacheUpdate :: Either InvalidationReason (Maybe a)
-> (CacheEvent, IntMap a -> IntMap a)
getCacheUpdate = \case
    Left InvalidationReason
reason -> (InvalidationReason -> CacheEvent
Invalidate InvalidationReason
reason, RID -> IntMap a -> IntMap a
forall a. RID -> IntMap a -> IntMap a
IM.delete RID
rid)
    Right Maybe a
maybeReplacement -> case Maybe a
maybeReplacement of
      Maybe a
Nothing -> (CachePreservationMode -> CacheEvent
Preserve CachePreservationMode
Unmodified, IntMap a -> IntMap a
forall a. a -> a
id)
      Just a
newCache -> (CachePreservationMode -> CacheEvent
Preserve CachePreservationMode
PathTruncated, RID -> a -> IntMap a -> IntMap a
forall a. RID -> a -> IntMap a -> IntMap a
IM.insert RID
rid a
newCache)