{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}

-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Helper functions for "Swarm.Game.Step.Const" commands
module Swarm.Game.Step.Util.Command where

import Control.Carrier.State.Lazy
import Control.Carrier.Throw.Either (ThrowC, runThrow)
import Control.Effect.Error
import Control.Effect.Lens
import Control.Effect.Lift
import Control.Lens as Lens hiding (Const, distrib, from, parts, use, uses, view, (%=), (+=), (.=), (<+=), (<>=))
import Control.Monad (forM_, unless, when)
import Data.IntSet qualified as IS
import Data.List (find)
import Data.List.NonEmpty qualified as NE
import Data.Map qualified as M
import Data.MonoidMap qualified as MM
import Data.Sequence qualified as Seq
import Data.Set (Set)
import Data.Set qualified as S
import Data.Text (Text)
import Data.Text qualified as T
import Data.Time (getZonedTime)
import Data.Tuple (swap)
import Linear (zero)
import Swarm.Game.Achievement.Attainment
import Swarm.Game.Achievement.Definitions
import Swarm.Game.Achievement.Description (getValidityRequirements)
import Swarm.Game.CESK
import Swarm.Game.Device
import Swarm.Game.Display
import Swarm.Game.Entity hiding (empty, lookup, singleton, union)
import Swarm.Game.Entity qualified as E
import Swarm.Game.Exception
import Swarm.Game.Land
import Swarm.Game.Location
import Swarm.Game.Recipe
import Swarm.Game.Robot
import Swarm.Game.Robot.Concrete
import Swarm.Game.Robot.Walk (emptyExceptions)
import Swarm.Game.Scenario.Status (getScenarioPath)
import Swarm.Game.Scenario.Topography.Navigation.Portal (Navigation (..), destination, reorientation)
import Swarm.Game.State
import Swarm.Game.State.Landscape
import Swarm.Game.State.Robot
import Swarm.Game.State.Substate
import Swarm.Game.Step.RobotStepState
import Swarm.Game.Step.Util
import Swarm.Game.Universe
import Swarm.Game.World qualified as W
import Swarm.Game.World.Coords
import Swarm.Language.Capability
import Swarm.Language.Pipeline.QQ (tmQ)
import Swarm.Language.Requirements.Type qualified as R
import Swarm.Language.Syntax
import Swarm.Language.Text.Markdown qualified as Markdown
import Swarm.Log
import Swarm.Util (applyWhen)
import System.Clock (TimeSpec)
import Prelude hiding (lookup)

data GrabbingCmd
  = Grab'
  | Harvest'
  | Swap'
  | Push'
  deriving (GrabbingCmd -> GrabbingCmd -> Bool
(GrabbingCmd -> GrabbingCmd -> Bool)
-> (GrabbingCmd -> GrabbingCmd -> Bool) -> Eq GrabbingCmd
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GrabbingCmd -> GrabbingCmd -> Bool
== :: GrabbingCmd -> GrabbingCmd -> Bool
$c/= :: GrabbingCmd -> GrabbingCmd -> Bool
/= :: GrabbingCmd -> GrabbingCmd -> Bool
Eq, Int -> GrabbingCmd -> ShowS
[GrabbingCmd] -> ShowS
GrabbingCmd -> String
(Int -> GrabbingCmd -> ShowS)
-> (GrabbingCmd -> String)
-> ([GrabbingCmd] -> ShowS)
-> Show GrabbingCmd
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GrabbingCmd -> ShowS
showsPrec :: Int -> GrabbingCmd -> ShowS
$cshow :: GrabbingCmd -> String
show :: GrabbingCmd -> String
$cshowList :: [GrabbingCmd] -> ShowS
showList :: [GrabbingCmd] -> ShowS
Show)

-- | Ensure that a robot is capable of executing a certain constant
--   (either because it has a device which gives it that capability,
--   or it is a system robot, or we are in creative mode).
--
-- For certain capabilities that require payment of inventory
-- items in order to be exercised, we pay the toll up front, regardless of
-- other conditions that may preclude the capability from eventually
-- being exercised (e.g. an obstacle that ultimately prevents a "move").
--
-- Note that there exist some code paths where the "toll"
-- is bypassed, e.g. see 'hasCapabilityFor'.
-- We should just try to avoid authoring scenarios that
-- include toll-gated devices for those particular capabilities.
--
-- Since this function has the side-effect of removing items from the
-- robot's inventory, we must be careful that it is executed exactly
-- once per command.
ensureCanExecute ::
  ( Has (State Robot) sig m
  , Has (State GameState) sig m
  , Has (Throw Exn) sig m
  ) =>
  Const ->
  m ()
ensureCanExecute :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State Robot) sig m, Has (State GameState) sig m,
 Has (Throw Exn) sig m) =>
Const -> m ()
ensureCanExecute Const
c =
  forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (State s) sig m =>
(s -> a) -> m a
gets @Robot (Const -> Robot -> Maybe Capability
constCapsFor Const
c) m (Maybe Capability) -> (Maybe Capability -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Capability -> m ()) -> Maybe Capability -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ \Capability
cap -> do
    Bool
isPrivileged <- m Bool
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m) =>
m Bool
isPrivilegedBot
    -- Privileged robots can execute commands regardless
    -- of equipped devices, and without expending
    -- a capability's exercise cost.
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isPrivileged (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      MultiEntityCapabilities Entity Text
robotCaps <- Getting
  (MultiEntityCapabilities Entity Text)
  Robot
  (MultiEntityCapabilities Entity Text)
-> m (MultiEntityCapabilities Entity Text)
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getting
  (MultiEntityCapabilities Entity Text)
  Robot
  (MultiEntityCapabilities Entity Text)
Getter Robot (MultiEntityCapabilities Entity Text)
robotCapabilities
      let capProviders :: Maybe (NonEmpty (DeviceUseCost Entity Text))
capProviders = Capability
-> Map Capability (NonEmpty (DeviceUseCost Entity Text))
-> Maybe (NonEmpty (DeviceUseCost Entity Text))
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Capability
cap (Map Capability (NonEmpty (DeviceUseCost Entity Text))
 -> Maybe (NonEmpty (DeviceUseCost Entity Text)))
-> Map Capability (NonEmpty (DeviceUseCost Entity Text))
-> Maybe (NonEmpty (DeviceUseCost Entity Text))
forall a b. (a -> b) -> a -> b
$ MultiEntityCapabilities Entity Text
-> Map Capability (NonEmpty (DeviceUseCost Entity Text))
forall e. Capabilities e -> Map Capability e
getMap MultiEntityCapabilities Entity Text
robotCaps
      case Maybe (NonEmpty (DeviceUseCost Entity Text))
capProviders of
        Maybe (NonEmpty (DeviceUseCost Entity Text))
Nothing -> Exn -> m ()
forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError (Exn -> m ()) -> Exn -> m ()
forall a b. (a -> b) -> a -> b
$ IncapableFix -> Requirements -> Term -> Exn
Incapable IncapableFix
FixByEquip (Capability -> Requirements
R.singletonCap Capability
cap) (Const -> Term
forall ty. Const -> Term' ty
TConst Const
c)
        Just NonEmpty (DeviceUseCost Entity Text)
rawCosts -> Const -> NonEmpty (DeviceUseCost Entity Text) -> m ()
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State Robot) sig m, Has (State GameState) sig m,
 Has (Throw Exn) sig m) =>
Const -> NonEmpty (DeviceUseCost Entity Text) -> m ()
payExerciseCost Const
c NonEmpty (DeviceUseCost Entity Text)
rawCosts

payExerciseCost ::
  ( Has (State Robot) sig m
  , Has (State GameState) sig m
  , Has (Throw Exn) sig m
  ) =>
  Const ->
  NE.NonEmpty (DeviceUseCost Entity EntityName) ->
  m ()
payExerciseCost :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State Robot) sig m, Has (State GameState) sig m,
 Has (Throw Exn) sig m) =>
Const -> NonEmpty (DeviceUseCost Entity Text) -> m ()
payExerciseCost Const
c NonEmpty (DeviceUseCost Entity Text)
rawCosts = do
  EntityMap
em <- Getting EntityMap GameState EntityMap -> m EntityMap
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use (Getting EntityMap GameState EntityMap -> m EntityMap)
-> Getting EntityMap GameState EntityMap -> m EntityMap
forall a b. (a -> b) -> a -> b
$ (Landscape -> Const EntityMap Landscape)
-> GameState -> Const EntityMap GameState
Lens' GameState Landscape
landscape ((Landscape -> Const EntityMap Landscape)
 -> GameState -> Const EntityMap GameState)
-> ((EntityMap -> Const EntityMap EntityMap)
    -> Landscape -> Const EntityMap Landscape)
-> Getting EntityMap GameState EntityMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TerrainEntityMaps -> Const EntityMap TerrainEntityMaps)
-> Landscape -> Const EntityMap Landscape
Lens' Landscape TerrainEntityMaps
terrainAndEntities ((TerrainEntityMaps -> Const EntityMap TerrainEntityMaps)
 -> Landscape -> Const EntityMap Landscape)
-> ((EntityMap -> Const EntityMap EntityMap)
    -> TerrainEntityMaps -> Const EntityMap TerrainEntityMaps)
-> (EntityMap -> Const EntityMap EntityMap)
-> Landscape
-> Const EntityMap Landscape
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EntityMap -> Const EntityMap EntityMap)
-> TerrainEntityMaps -> Const EntityMap TerrainEntityMaps
Lens' TerrainEntityMaps EntityMap
entityMap
  let eitherCosts :: Either Text (NonEmpty (DeviceUseCost Entity Entity))
eitherCosts = ((DeviceUseCost Entity Text
 -> Either Text (DeviceUseCost Entity Entity))
-> NonEmpty (DeviceUseCost Entity Text)
-> Either Text (NonEmpty (DeviceUseCost Entity Entity))
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) -> NonEmpty a -> f (NonEmpty b)
traverse ((DeviceUseCost Entity Text
  -> Either Text (DeviceUseCost Entity Entity))
 -> NonEmpty (DeviceUseCost Entity Text)
 -> Either Text (NonEmpty (DeviceUseCost Entity Entity)))
-> ((Text -> Either Text Entity)
    -> DeviceUseCost Entity Text
    -> Either Text (DeviceUseCost Entity Entity))
-> (Text -> Either Text Entity)
-> NonEmpty (DeviceUseCost Entity Text)
-> Either Text (NonEmpty (DeviceUseCost Entity Entity))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Either Text Entity)
-> DeviceUseCost Entity Text
-> Either Text (DeviceUseCost Entity Entity)
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) -> DeviceUseCost Entity a -> f (DeviceUseCost Entity b)
traverse) (Map Text Entity -> Text -> Either Text Entity
forall b. Map Text b -> Text -> Either Text b
lookupEntityE (Map Text Entity -> Text -> Either Text Entity)
-> Map Text Entity -> Text -> Either Text Entity
forall a b. (a -> b) -> a -> b
$ EntityMap -> Map Text Entity
entitiesByName EntityMap
em) NonEmpty (DeviceUseCost Entity Text)
rawCosts
  NonEmpty (DeviceUseCost Entity Entity)
costs <- case Either Text (NonEmpty (DeviceUseCost Entity Entity))
eitherCosts of
    -- NOTE: Entity references have been validated already at scenario load time,
    -- so we should never encounter this error.
    Left Text
e -> Exn -> m (NonEmpty (DeviceUseCost Entity Entity))
forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError (Exn -> m (NonEmpty (DeviceUseCost Entity Entity)))
-> Exn -> m (NonEmpty (DeviceUseCost Entity Entity))
forall a b. (a -> b) -> a -> b
$ Text -> Exn
Fatal Text
e
    Right NonEmpty (DeviceUseCost Entity Entity)
cs -> NonEmpty (DeviceUseCost Entity Entity)
-> m (NonEmpty (DeviceUseCost Entity Entity))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return NonEmpty (DeviceUseCost Entity Entity)
cs
  Inventory
inv <- Getting Inventory Robot Inventory -> m Inventory
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getting Inventory Robot Inventory
Lens' Robot Inventory
robotInventory
  let getMissingIngredients :: DeviceUseCost e Entity -> [(Int, Entity)]
getMissingIngredients = Inventory -> [(Int, Entity)] -> [(Int, Entity)]
findLacking Inventory
inv ([(Int, Entity)] -> [(Int, Entity)])
-> (DeviceUseCost e Entity -> [(Int, Entity)])
-> DeviceUseCost e Entity
-> [(Int, Entity)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExerciseCost Entity -> [(Int, Entity)]
forall e. ExerciseCost e -> IngredientList e
ingredients (ExerciseCost Entity -> [(Int, Entity)])
-> (DeviceUseCost e Entity -> ExerciseCost Entity)
-> DeviceUseCost e Entity
-> [(Int, Entity)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DeviceUseCost e Entity -> ExerciseCost Entity
forall e en. DeviceUseCost e en -> ExerciseCost en
useCost
      maybeFeasibleRecipe :: Maybe (DeviceUseCost Entity Entity)
maybeFeasibleRecipe = (DeviceUseCost Entity Entity -> Bool)
-> NonEmpty (DeviceUseCost Entity Entity)
-> Maybe (DeviceUseCost Entity Entity)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ([(Int, Entity)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([(Int, Entity)] -> Bool)
-> (DeviceUseCost Entity Entity -> [(Int, Entity)])
-> DeviceUseCost Entity Entity
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DeviceUseCost Entity Entity -> [(Int, Entity)]
forall {e}. DeviceUseCost e Entity -> [(Int, Entity)]
getMissingIngredients) (NonEmpty (DeviceUseCost Entity Entity)
 -> Maybe (DeviceUseCost Entity Entity))
-> NonEmpty (DeviceUseCost Entity Entity)
-> Maybe (DeviceUseCost Entity Entity)
forall a b. (a -> b) -> a -> b
$ NonEmpty (DeviceUseCost Entity Entity)
-> NonEmpty (DeviceUseCost Entity Entity)
forall a. Ord a => NonEmpty a -> NonEmpty a
NE.sort NonEmpty (DeviceUseCost Entity Entity)
costs
  case Maybe (DeviceUseCost Entity Entity)
maybeFeasibleRecipe of
    Maybe (DeviceUseCost Entity Entity)
Nothing ->
      Exn -> m ()
forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError (Exn -> m ()) -> Exn -> m ()
forall a b. (a -> b) -> a -> b
$
        IncapableFix -> Requirements -> Term -> Exn
Incapable IncapableFix
FixByObtainConsumables (DeviceUseCost Entity Entity -> Requirements
expenseToRequirement (DeviceUseCost Entity Entity -> Requirements)
-> DeviceUseCost Entity Entity -> Requirements
forall a b. (a -> b) -> a -> b
$ NonEmpty (DeviceUseCost Entity Entity)
-> DeviceUseCost Entity Entity
forall a. NonEmpty a -> a
NE.head NonEmpty (DeviceUseCost Entity Entity)
costs) (Const -> Term
forall ty. Const -> Term' ty
TConst Const
c)
    -- Consume the inventory
    Just DeviceUseCost Entity Entity
feasibleRecipe ->
      [(Int, Entity)] -> ((Int, Entity) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (ExerciseCost Entity -> [(Int, Entity)]
forall e. ExerciseCost e -> IngredientList e
ingredients (ExerciseCost Entity -> [(Int, Entity)])
-> (DeviceUseCost Entity Entity -> ExerciseCost Entity)
-> DeviceUseCost Entity Entity
-> [(Int, Entity)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DeviceUseCost Entity Entity -> ExerciseCost Entity
forall e en. DeviceUseCost e en -> ExerciseCost en
useCost (DeviceUseCost Entity Entity -> [(Int, Entity)])
-> DeviceUseCost Entity Entity -> [(Int, Entity)]
forall a b. (a -> b) -> a -> b
$ DeviceUseCost Entity Entity
feasibleRecipe) (((Int, Entity) -> m ()) -> m ())
-> ((Int, Entity) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(Int
cnt, Entity
e) ->
        (Inventory -> Identity Inventory) -> Robot -> Identity Robot
Lens' Robot Inventory
robotInventory ((Inventory -> Identity Inventory) -> Robot -> Identity Robot)
-> (Inventory -> Inventory) -> m ()
forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= Int -> Entity -> Inventory -> Inventory
deleteCount Int
cnt Entity
e
 where
  expenseToRequirement :: DeviceUseCost Entity Entity -> R.Requirements
  expenseToRequirement :: DeviceUseCost Entity Entity -> Requirements
expenseToRequirement (DeviceUseCost Entity
d (ExerciseCost [(Int, Entity)]
ingdts)) =
    Set Capability -> Set Text -> Map Text Int -> Requirements
R.Requirements Set Capability
forall a. Set a
S.empty (Text -> Set Text
forall a. a -> Set a
S.singleton (Text -> Set Text) -> Text -> Set Text
forall a b. (a -> b) -> a -> b
$ Entity
d Entity -> Getting Text Entity Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text Entity Text
Lens' Entity Text
entityName) Map Text Int
ingdtsMap
   where
    ingdtsMap :: Map Text Int
ingdtsMap = (Int -> Int -> Int) -> [(Text, Int)] -> Map Text Int
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) ([(Text, Int)] -> Map Text Int) -> [(Text, Int)] -> Map Text Int
forall a b. (a -> b) -> a -> b
$ ((Int, Entity) -> (Text, Int)) -> [(Int, Entity)] -> [(Text, Int)]
forall a b. (a -> b) -> [a] -> [b]
map ((Int, Text) -> (Text, Int)
forall a b. (a, b) -> (b, a)
swap ((Int, Text) -> (Text, Int))
-> ((Int, Entity) -> (Int, Text)) -> (Int, Entity) -> (Text, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Entity -> Text) -> (Int, Entity) -> (Int, Text)
forall a b. (a -> b) -> (Int, a) -> (Int, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Getting Text Entity Text -> Entity -> Text
forall r a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Reader r) sig m =>
Getting a r a -> m a
view Getting Text Entity Text
Lens' Entity Text
entityName)) [(Int, Entity)]
ingdts

-- | Clear watches that are out of range
purgeFarAwayWatches ::
  HasRobotStepState sig m => m ()
purgeFarAwayWatches :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
m ()
purgeFarAwayWatches = do
  Bool
privileged <- m Bool
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m) =>
m Bool
isPrivilegedBot
  Cosmic Location
myLoc <- Getting (Cosmic Location) Robot (Cosmic Location)
-> m (Cosmic Location)
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getting (Cosmic Location) Robot (Cosmic Location)
Getter Robot (Cosmic Location)
robotLocation
  Int
rid <- Getting Int Robot Int -> m Int
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getting Int Robot Int
Getter Robot Int
robotID

  let isNearby :: Cosmic Location -> Bool
isNearby = Bool -> Cosmic Location -> Cosmic Location -> Bool
isNearbyOrExempt Bool
privileged Cosmic Location
myLoc
      f :: Cosmic Location -> IntSet -> IntSet
f Cosmic Location
loc =
        Bool -> (IntSet -> IntSet) -> IntSet -> IntSet
forall a. Bool -> (a -> a) -> a -> a
applyWhen (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Cosmic Location -> Bool
isNearby Cosmic Location
loc) ((IntSet -> IntSet) -> IntSet -> IntSet)
-> (IntSet -> IntSet) -> IntSet -> IntSet
forall a b. (a -> b) -> a -> b
$
          Int -> IntSet -> IntSet
IS.delete Int
rid

  (Robots -> Identity Robots) -> GameState -> Identity GameState
Lens' GameState Robots
robotInfo ((Robots -> Identity Robots) -> GameState -> Identity GameState)
-> ((MonoidMap (Cosmic Location) IntSet
     -> Identity (MonoidMap (Cosmic Location) IntSet))
    -> Robots -> Identity Robots)
-> (MonoidMap (Cosmic Location) IntSet
    -> Identity (MonoidMap (Cosmic Location) IntSet))
-> GameState
-> Identity GameState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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))
 -> GameState -> Identity GameState)
-> (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 ()
%= (Cosmic Location -> IntSet -> IntSet)
-> MonoidMap (Cosmic Location) IntSet
-> MonoidMap (Cosmic Location) IntSet
forall v2 k v1.
MonoidNull v2 =>
(k -> v1 -> v2) -> MonoidMap k v1 -> MonoidMap k v2
MM.mapWithKey Cosmic Location -> IntSet -> IntSet
f

verbedGrabbingCmd :: GrabbingCmd -> Text
verbedGrabbingCmd :: GrabbingCmd -> Text
verbedGrabbingCmd = \case
  GrabbingCmd
Harvest' -> Text
"harvested"
  GrabbingCmd
Grab' -> Text
"grabbed"
  GrabbingCmd
Swap' -> Text
"swapped"
  GrabbingCmd
Push' -> Text
"pushed"

-- | Update the location of a robot, and simultaneously update the
--   'robotsByLocation' map, so we can always look up robots by
--   location.  This should be the /only/ way to update the location
--   of a robot.
-- Also implements teleportation by portals.
updateRobotLocation ::
  (HasRobotStepState sig m) =>
  Cosmic Location ->
  Cosmic Location ->
  m ()
updateRobotLocation :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Cosmic Location -> Cosmic Location -> m ()
updateRobotLocation Cosmic Location
oldLoc Cosmic Location
newLoc
  | Cosmic Location
oldLoc Cosmic Location -> Cosmic Location -> Bool
forall a. Eq a => a -> a -> Bool
== Cosmic Location
newLoc = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise = do
      Cosmic Location
newlocWithPortal <- Cosmic Location -> m (Cosmic Location)
forall {m :: * -> *} {sig :: (* -> *) -> * -> *}.
(Algebra sig m, Member (State Robot) sig,
 Member (State GameState) sig) =>
Cosmic Location -> m (Cosmic Location)
applyPortal Cosmic Location
newLoc
      Int
rid <- Getting Int Robot Int -> m Int
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getting Int Robot Int
Getter Robot Int
robotID
      StateC Robots Identity () -> m ()
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) b.
Has (State GameState) sig m =>
StateC Robots Identity b -> m b
zoomRobots (StateC Robots Identity () -> m ())
-> StateC Robots Identity () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        -- wakeWatchingRobots?
        Cosmic Location -> Int -> StateC Robots Identity ()
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State Robots) sig m =>
Cosmic Location -> Int -> m ()
removeRobotFromLocationMap Cosmic Location
oldLoc Int
rid
        Int -> Cosmic Location -> StateC Robots Identity ()
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State Robots) sig m =>
Int -> Cosmic Location -> m ()
addRobotToLocation Int
rid Cosmic Location
newlocWithPortal
      (Robot -> Robot) -> m ()
forall s (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
(s -> s) -> m ()
modify (Cosmic Location -> Robot -> Robot
unsafeSetRobotLocation Cosmic Location
newlocWithPortal)
      m ()
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
m ()
flagRedraw
 where
  applyPortal :: Cosmic Location -> m (Cosmic Location)
applyPortal Cosmic Location
loc = do
    Navigation (Map SubworldName) Location
lms <- Getting
  (Navigation (Map SubworldName) Location)
  GameState
  (Navigation (Map SubworldName) Location)
-> m (Navigation (Map SubworldName) Location)
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use (Getting
   (Navigation (Map SubworldName) Location)
   GameState
   (Navigation (Map SubworldName) Location)
 -> m (Navigation (Map SubworldName) Location))
-> Getting
     (Navigation (Map SubworldName) Location)
     GameState
     (Navigation (Map SubworldName) Location)
-> m (Navigation (Map SubworldName) Location)
forall a b. (a -> b) -> a -> b
$ (Landscape
 -> Const (Navigation (Map SubworldName) Location) Landscape)
-> GameState
-> Const (Navigation (Map SubworldName) Location) GameState
Lens' GameState Landscape
landscape ((Landscape
  -> Const (Navigation (Map SubworldName) Location) Landscape)
 -> GameState
 -> Const (Navigation (Map SubworldName) Location) GameState)
-> ((Navigation (Map SubworldName) Location
     -> Const
          (Navigation (Map SubworldName) Location)
          (Navigation (Map SubworldName) Location))
    -> Landscape
    -> Const (Navigation (Map SubworldName) Location) Landscape)
-> Getting
     (Navigation (Map SubworldName) Location)
     GameState
     (Navigation (Map SubworldName) Location)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Navigation (Map SubworldName) Location
 -> Const
      (Navigation (Map SubworldName) Location)
      (Navigation (Map SubworldName) Location))
-> Landscape
-> Const (Navigation (Map SubworldName) Location) Landscape
Lens' Landscape (Navigation (Map SubworldName) Location)
worldNavigation
    let maybePortalInfo :: Maybe (AnnotatedDestination Location)
maybePortalInfo = Cosmic Location
-> Map (Cosmic Location) (AnnotatedDestination Location)
-> Maybe (AnnotatedDestination Location)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Cosmic Location
loc (Map (Cosmic Location) (AnnotatedDestination Location)
 -> Maybe (AnnotatedDestination Location))
-> Map (Cosmic Location) (AnnotatedDestination Location)
-> Maybe (AnnotatedDestination Location)
forall a b. (a -> b) -> a -> b
$ Navigation (Map SubworldName) Location
-> Map (Cosmic Location) (AnnotatedDestination Location)
forall (additionalDimension :: * -> *) portalExitLoc.
Navigation additionalDimension portalExitLoc
-> Map (Cosmic Location) (AnnotatedDestination portalExitLoc)
portals Navigation (Map SubworldName) Location
lms
        updatedLoc :: Cosmic Location
updatedLoc = Cosmic Location
-> (AnnotatedDestination Location -> Cosmic Location)
-> Maybe (AnnotatedDestination Location)
-> Cosmic Location
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Cosmic Location
loc AnnotatedDestination Location -> Cosmic Location
forall a. AnnotatedDestination a -> Cosmic a
destination Maybe (AnnotatedDestination Location)
maybePortalInfo
        maybeTurn :: Maybe Direction
maybeTurn = AnnotatedDestination Location -> Direction
forall a. AnnotatedDestination a -> Direction
reorientation (AnnotatedDestination Location -> Direction)
-> Maybe (AnnotatedDestination Location) -> Maybe Direction
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (AnnotatedDestination Location)
maybePortalInfo
    Maybe Direction -> (Direction -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Direction
maybeTurn ((Direction -> m ()) -> m ()) -> (Direction -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Direction
d ->
      (Maybe (V2 Int32) -> Identity (Maybe (V2 Int32)))
-> Robot -> Identity Robot
Lens' Robot (Maybe (V2 Int32))
robotOrientation ((Maybe (V2 Int32) -> Identity (Maybe (V2 Int32)))
 -> Robot -> Identity Robot)
-> ((V2 Int32 -> Identity (V2 Int32))
    -> Maybe (V2 Int32) -> Identity (Maybe (V2 Int32)))
-> (V2 Int32 -> Identity (V2 Int32))
-> Robot
-> Identity Robot
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (V2 Int32 -> Identity (V2 Int32))
-> Maybe (V2 Int32) -> Identity (Maybe (V2 Int32))
forall a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Maybe a) (f (Maybe b))
_Just ((V2 Int32 -> Identity (V2 Int32)) -> Robot -> Identity Robot)
-> (V2 Int32 -> V2 Int32) -> m ()
forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= Direction -> V2 Int32 -> V2 Int32
applyTurn Direction
d
    Cosmic Location -> m (Cosmic Location)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Cosmic Location
updatedLoc

-- | Execute a stateful action on a target robot --- whether the
--   current one or another.
onTarget ::
  (HasRobotStepState sig m, Has (Lift IO) sig m) =>
  RID ->
  (forall sig' m'. (HasRobotStepState sig' m', Has (Lift IO) sig' m') => m' ()) ->
  m ()
onTarget :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(HasRobotStepState sig m, Has (Lift IO) sig m) =>
Int
-> (forall (sig' :: (* -> *) -> * -> *) (m' :: * -> *).
    (HasRobotStepState sig' m', Has (Lift IO) sig' m') =>
    m' ())
-> m ()
onTarget Int
rid forall (sig' :: (* -> *) -> * -> *) (m' :: * -> *).
(HasRobotStepState sig' m', Has (Lift IO) sig' m') =>
m' ()
act = do
  Int
myID <- Getting Int Robot Int -> m Int
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getting Int Robot Int
Getter Robot Int
robotID
  case Int
myID Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
rid of
    Bool
True -> m ()
forall (sig' :: (* -> *) -> * -> *) (m' :: * -> *).
(HasRobotStepState sig' m', Has (Lift IO) sig' m') =>
m' ()
act
    Bool
False -> do
      Maybe Robot
mtgt <- Getting (Maybe Robot) GameState (Maybe Robot) -> m (Maybe Robot)
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use ((Robots -> Const (Maybe Robot) Robots)
-> GameState -> Const (Maybe Robot) GameState
Lens' GameState Robots
robotInfo ((Robots -> Const (Maybe Robot) Robots)
 -> GameState -> Const (Maybe Robot) GameState)
-> ((Maybe Robot -> Const (Maybe Robot) (Maybe Robot))
    -> Robots -> Const (Maybe Robot) Robots)
-> Getting (Maybe Robot) GameState (Maybe Robot)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IntMap Robot -> Const (Maybe Robot) (IntMap Robot))
-> Robots -> Const (Maybe Robot) Robots
Lens' Robots (IntMap Robot)
robotMap ((IntMap Robot -> Const (Maybe Robot) (IntMap Robot))
 -> Robots -> Const (Maybe Robot) Robots)
-> ((Maybe Robot -> Const (Maybe Robot) (Maybe Robot))
    -> IntMap Robot -> Const (Maybe Robot) (IntMap Robot))
-> (Maybe Robot -> Const (Maybe Robot) (Maybe Robot))
-> Robots
-> Const (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 Int
Index (IntMap Robot)
rid)
      Maybe Robot -> (Robot -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Robot
mtgt ((Robot -> m ()) -> m ()) -> (Robot -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Robot
tgt -> do
        Robot
tgt' <- forall s (m :: * -> *) a. Functor m => s -> StateC s m a -> m s
execState @Robot Robot
tgt StateC Robot m ()
forall (sig' :: (* -> *) -> * -> *) (m' :: * -> *).
(HasRobotStepState sig' m', Has (Lift IO) sig' m') =>
m' ()
act
        StateC Robots Identity () -> m ()
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) b.
Has (State GameState) sig m =>
StateC Robots Identity b -> m b
zoomRobots (StateC Robots Identity () -> m ())
-> StateC Robots Identity () -> m ()
forall a b. (a -> b) -> a -> b
$
          if Robot
tgt' Robot -> Getting Bool Robot Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool Robot Bool
Lens' Robot Bool
selfDestruct
            then Int -> StateC Robots Identity ()
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State Robots) sig m =>
Int -> m ()
deleteRobot Int
rid
            else (IntMap Robot -> Identity (IntMap Robot))
-> Robots -> Identity Robots
Lens' Robots (IntMap Robot)
robotMap ((IntMap Robot -> Identity (IntMap Robot))
 -> Robots -> Identity Robots)
-> ((Robot -> Identity Robot)
    -> IntMap Robot -> Identity (IntMap Robot))
-> (Robot -> Identity Robot)
-> Robots
-> Identity Robots
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 Int
Index (IntMap Robot)
rid ((Robot -> Identity Robot) -> Robots -> Identity Robots)
-> Robot -> StateC Robots Identity ()
forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= Robot
tgt'

-- | Enforces validity of the robot's privileged status to receive
-- an achievement.
grantAchievementForRobot ::
  (HasRobotStepState sig m, Has (Lift IO) sig m) =>
  GameplayAchievement ->
  m ()
grantAchievementForRobot :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(HasRobotStepState sig m, Has (Lift IO) sig m) =>
GameplayAchievement -> m ()
grantAchievementForRobot GameplayAchievement
a = do
  Bool
sys <- Getting Bool Robot Bool -> m Bool
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getting Bool Robot Bool
Lens' Robot Bool
systemRobot
  let isValidRobotType :: Bool
isValidRobotType = Bool -> Bool
not Bool
sys Bool -> Bool -> Bool
|| SystemTypeValidity
robotTypeRequired SystemTypeValidity -> SystemTypeValidity -> Bool
forall a. Eq a => a -> a -> Bool
== SystemTypeValidity
ValidForSystemRobot
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isValidRobotType (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    GameplayAchievement -> m ()
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (Lift IO) sig m) =>
GameplayAchievement -> m ()
grantAchievement GameplayAchievement
a
 where
  ValidityConditions SystemTypeValidity
robotTypeRequired GameplayModeValidity
_ = GameplayAchievement -> ValidityConditions
getValidityRequirements GameplayAchievement
a

checkGameModeAchievementValidity ::
  Has (State GameState) sig m =>
  GameplayAchievement ->
  m Bool
checkGameModeAchievementValidity :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
GameplayAchievement -> m Bool
checkGameModeAchievementValidity GameplayAchievement
a = do
  Bool
creative <- Getting Bool GameState Bool -> m Bool
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getting Bool GameState Bool
Lens' GameState Bool
creativeMode
  Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not Bool
creative Bool -> Bool -> Bool
|| GameplayModeValidity
gameplayModeRequired GameplayModeValidity -> GameplayModeValidity -> Bool
forall a. Eq a => a -> a -> Bool
== GameplayModeValidity
ValidInCreativeMode
 where
  ValidityConditions SystemTypeValidity
_ GameplayModeValidity
gameplayModeRequired = GameplayAchievement -> ValidityConditions
getValidityRequirements GameplayAchievement
a

-- | NOTE: When possible, one should use the
-- 'grantAchievementForRobot' function instead of this one.
grantAchievement ::
  (Has (State GameState) sig m, Has (Lift IO) sig m) =>
  GameplayAchievement ->
  m ()
grantAchievement :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (Lift IO) sig m) =>
GameplayAchievement -> m ()
grantAchievement GameplayAchievement
a = do
  Bool
isGameModeValid <- GameplayAchievement -> m Bool
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
GameplayAchievement -> m Bool
checkGameModeAchievementValidity GameplayAchievement
a
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isGameModeValid (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    ZonedTime
currentTime <- IO ZonedTime -> m ZonedTime
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Lift IO) sig m =>
IO a -> m a
sendIO IO ZonedTime
getZonedTime
    Maybe ScenarioPath
scenarioPath <- Getting (Maybe ScenarioPath) GameState (Maybe ScenarioPath)
-> m (Maybe ScenarioPath)
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getting (Maybe ScenarioPath) GameState (Maybe ScenarioPath)
Lens' GameState (Maybe ScenarioPath)
currentScenarioPath
    (Discovery -> Identity Discovery)
-> GameState -> Identity GameState
Lens' GameState Discovery
discovery
      ((Discovery -> Identity Discovery)
 -> GameState -> Identity GameState)
-> ((Map GameplayAchievement Attainment
     -> Identity (Map GameplayAchievement Attainment))
    -> Discovery -> Identity Discovery)
-> (Map GameplayAchievement Attainment
    -> Identity (Map GameplayAchievement Attainment))
-> GameState
-> Identity GameState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map GameplayAchievement Attainment
 -> Identity (Map GameplayAchievement Attainment))
-> Discovery -> Identity Discovery
Lens' Discovery (Map GameplayAchievement Attainment)
gameAchievements
      ((Map GameplayAchievement Attainment
  -> Identity (Map GameplayAchievement Attainment))
 -> GameState -> Identity GameState)
-> (Map GameplayAchievement Attainment
    -> Map GameplayAchievement Attainment)
-> m ()
forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= (Attainment -> Attainment -> Attainment)
-> GameplayAchievement
-> Attainment
-> Map GameplayAchievement Attainment
-> Map GameplayAchievement Attainment
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith
        Attainment -> Attainment -> Attainment
forall a. Semigroup a => a -> a -> a
(<>)
        GameplayAchievement
a
        (CategorizedAchievement -> Maybe String -> ZonedTime -> Attainment
Attainment (GameplayAchievement -> CategorizedAchievement
GameplayAchievement GameplayAchievement
a) (ScenarioPath -> String
getScenarioPath (ScenarioPath -> String) -> Maybe ScenarioPath -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ScenarioPath
scenarioPath) ZonedTime
currentTime)

-- | Capabilities needed for a specific robot to evaluate or execute a
--   constant.  Right now, the only difference is whether the robot is
--   heavy or not when executing the 'Swarm.Language.Syntax.Move' command, but there might
--   be other exceptions added in the future.
constCapsFor :: Const -> Robot -> Maybe Capability
constCapsFor :: Const -> Robot -> Maybe Capability
constCapsFor Const
Move Robot
r
  | Robot
r Robot -> Getting Bool Robot Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool Robot Bool
Lens' Robot Bool
robotHeavy = Capability -> Maybe Capability
forall a. a -> Maybe a
Just Capability
CMoveHeavy
constCapsFor Const
Backup Robot
r
  | Robot
r Robot -> Getting Bool Robot Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool Robot Bool
Lens' Robot Bool
robotHeavy = Capability -> Maybe Capability
forall a. a -> Maybe a
Just Capability
CMoveHeavy
constCapsFor Const
Stride Robot
r
  | Robot
r Robot -> Getting Bool Robot Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool Robot Bool
Lens' Robot Bool
robotHeavy = Capability -> Maybe Capability
forall a. a -> Maybe a
Just Capability
CMoveHeavy
constCapsFor Const
c Robot
_ = Const -> Maybe Capability
constCaps Const
c

-- | Requires that the target location is within one cell.
-- Requirement is waived if the bot is privileged.
isNearbyOrExempt :: Bool -> Cosmic Location -> Cosmic Location -> Bool
isNearbyOrExempt :: Bool -> Cosmic Location -> Cosmic Location -> Bool
isNearbyOrExempt Bool
privileged Cosmic Location
myLoc Cosmic Location
otherLoc =
  Bool
privileged Bool -> Bool -> Bool
|| case (Location -> Location -> Int32)
-> Cosmic Location -> Cosmic Location -> DistanceMeasure Int32
forall a b.
(a -> a -> b) -> Cosmic a -> Cosmic a -> DistanceMeasure b
cosmoMeasure Location -> Location -> Int32
manhattan Cosmic Location
myLoc Cosmic Location
otherLoc of
    DistanceMeasure Int32
InfinitelyFar -> Bool
False
    Measurable Int32
x -> Int32
x Int32 -> Int32 -> Bool
forall a. Ord a => a -> a -> Bool
<= Int32
1

------------------------------------------------------------
-- Updating discovered entities, recipes, and commands
------------------------------------------------------------

-- | Update the global list of discovered entities, and check for new recipes.
updateDiscoveredEntities :: (HasRobotStepState sig m) => Entity -> m ()
updateDiscoveredEntities :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Entity -> m ()
updateDiscoveredEntities Entity
e = do
  Inventory
allDiscovered <- Getting Inventory GameState Inventory -> m Inventory
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use (Getting Inventory GameState Inventory -> m Inventory)
-> Getting Inventory GameState Inventory -> m Inventory
forall a b. (a -> b) -> a -> b
$ (Discovery -> Const Inventory Discovery)
-> GameState -> Const Inventory GameState
Lens' GameState Discovery
discovery ((Discovery -> Const Inventory Discovery)
 -> GameState -> Const Inventory GameState)
-> ((Inventory -> Const Inventory Inventory)
    -> Discovery -> Const Inventory Discovery)
-> Getting Inventory GameState Inventory
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Inventory -> Const Inventory Inventory)
-> Discovery -> Const Inventory Discovery
Lens' Discovery Inventory
allDiscoveredEntities
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Entity -> Inventory -> Bool
E.contains0plus Entity
e Inventory
allDiscovered) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    let newAllDiscovered :: Inventory
newAllDiscovered = Int -> Entity -> Inventory -> Inventory
E.insertCount Int
1 Entity
e Inventory
allDiscovered
    (Inventory, Inventory) -> Entity -> m ()
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
(Inventory, Inventory) -> Entity -> m ()
updateAvailableRecipes (Inventory
newAllDiscovered, Inventory
newAllDiscovered) Entity
e
    Entity -> m ()
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
Entity -> m ()
updateAvailableCommands Entity
e
    (Discovery -> Identity Discovery)
-> GameState -> Identity GameState
Lens' GameState Discovery
discovery ((Discovery -> Identity Discovery)
 -> GameState -> Identity GameState)
-> ((Inventory -> Identity Inventory)
    -> Discovery -> Identity Discovery)
-> (Inventory -> Identity Inventory)
-> GameState
-> Identity GameState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Inventory -> Identity Inventory)
-> Discovery -> Identity Discovery
Lens' Discovery Inventory
allDiscoveredEntities ((Inventory -> Identity Inventory)
 -> GameState -> Identity GameState)
-> Inventory -> m ()
forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= Inventory
newAllDiscovered

-- | Update the availableRecipes list.
-- This implementation is not efficient:
-- * Every time we discover a new entity, we iterate through the entire list of recipes to see which ones we can make.
--   Trying to do something more clever seems like it would definitely be a case of premature optimization.
--   One doesn't discover new entities all that often.
-- * For each usable recipe, we do a linear search through the list of known recipes to see if we already know it.
--   This is a little more troubling, since it's quadratic in the number of recipes.
--   But it probably doesn't really make that much difference until we get up to thousands of recipes.
updateAvailableRecipes :: Has (State GameState) sig m => (Inventory, Inventory) -> Entity -> m ()
updateAvailableRecipes :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
(Inventory, Inventory) -> Entity -> m ()
updateAvailableRecipes (Inventory, Inventory)
invs Entity
e = do
  IntMap [Recipe Entity]
allInRecipes <- Getting (IntMap [Recipe Entity]) GameState (IntMap [Recipe Entity])
-> m (IntMap [Recipe Entity])
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use (Getting
   (IntMap [Recipe Entity]) GameState (IntMap [Recipe Entity])
 -> m (IntMap [Recipe Entity]))
-> Getting
     (IntMap [Recipe Entity]) GameState (IntMap [Recipe Entity])
-> m (IntMap [Recipe Entity])
forall a b. (a -> b) -> a -> b
$ (Recipes -> Const (IntMap [Recipe Entity]) Recipes)
-> GameState -> Const (IntMap [Recipe Entity]) GameState
Lens' GameState Recipes
recipesInfo ((Recipes -> Const (IntMap [Recipe Entity]) Recipes)
 -> GameState -> Const (IntMap [Recipe Entity]) GameState)
-> ((IntMap [Recipe Entity]
     -> Const (IntMap [Recipe Entity]) (IntMap [Recipe Entity]))
    -> Recipes -> Const (IntMap [Recipe Entity]) Recipes)
-> Getting
     (IntMap [Recipe Entity]) GameState (IntMap [Recipe Entity])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IntMap [Recipe Entity]
 -> Const (IntMap [Recipe Entity]) (IntMap [Recipe Entity]))
-> Recipes -> Const (IntMap [Recipe Entity]) Recipes
Lens' Recipes (IntMap [Recipe Entity])
recipesIn
  let entityRecipes :: [Recipe Entity]
entityRecipes = IntMap [Recipe Entity] -> Entity -> [Recipe Entity]
recipesFor IntMap [Recipe Entity]
allInRecipes Entity
e
      usableRecipes :: [Recipe Entity]
usableRecipes = (Recipe Entity -> Bool) -> [Recipe Entity] -> [Recipe Entity]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Inventory, Inventory) -> Recipe Entity -> Bool
knowsIngredientsFor (Inventory, Inventory)
invs) [Recipe Entity]
entityRecipes
  [Recipe Entity]
knownRecipes <- Getting [Recipe Entity] GameState [Recipe Entity]
-> m [Recipe Entity]
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use (Getting [Recipe Entity] GameState [Recipe Entity]
 -> m [Recipe Entity])
-> Getting [Recipe Entity] GameState [Recipe Entity]
-> m [Recipe Entity]
forall a b. (a -> b) -> a -> b
$ (Discovery -> Const [Recipe Entity] Discovery)
-> GameState -> Const [Recipe Entity] GameState
Lens' GameState Discovery
discovery ((Discovery -> Const [Recipe Entity] Discovery)
 -> GameState -> Const [Recipe Entity] GameState)
-> (([Recipe Entity] -> Const [Recipe Entity] [Recipe Entity])
    -> Discovery -> Const [Recipe Entity] Discovery)
-> Getting [Recipe Entity] GameState [Recipe Entity]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Notifications (Recipe Entity)
 -> Const [Recipe Entity] (Notifications (Recipe Entity)))
-> Discovery -> Const [Recipe Entity] Discovery
Lens' Discovery (Notifications (Recipe Entity))
availableRecipes ((Notifications (Recipe Entity)
  -> Const [Recipe Entity] (Notifications (Recipe Entity)))
 -> Discovery -> Const [Recipe Entity] Discovery)
-> (([Recipe Entity] -> Const [Recipe Entity] [Recipe Entity])
    -> Notifications (Recipe Entity)
    -> Const [Recipe Entity] (Notifications (Recipe Entity)))
-> ([Recipe Entity] -> Const [Recipe Entity] [Recipe Entity])
-> Discovery
-> Const [Recipe Entity] Discovery
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Recipe Entity] -> Const [Recipe Entity] [Recipe Entity])
-> Notifications (Recipe Entity)
-> Const [Recipe Entity] (Notifications (Recipe Entity))
forall a1 a2 (f :: * -> *).
Functor f =>
([a1] -> f [a2]) -> Notifications a1 -> f (Notifications a2)
notificationsContent
  let newRecipes :: [Recipe Entity]
newRecipes = (Recipe Entity -> Bool) -> [Recipe Entity] -> [Recipe Entity]
forall a. (a -> Bool) -> [a] -> [a]
filter (Recipe Entity -> [Recipe Entity] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Recipe Entity]
knownRecipes) [Recipe Entity]
usableRecipes
      newCount :: Int
newCount = [Recipe Entity] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Recipe Entity]
newRecipes
  (Discovery -> Identity Discovery)
-> GameState -> Identity GameState
Lens' GameState Discovery
discovery ((Discovery -> Identity Discovery)
 -> GameState -> Identity GameState)
-> ((Notifications (Recipe Entity)
     -> Identity (Notifications (Recipe Entity)))
    -> Discovery -> Identity Discovery)
-> (Notifications (Recipe Entity)
    -> Identity (Notifications (Recipe Entity)))
-> GameState
-> Identity GameState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Notifications (Recipe Entity)
 -> Identity (Notifications (Recipe Entity)))
-> Discovery -> Identity Discovery
Lens' Discovery (Notifications (Recipe Entity))
availableRecipes ((Notifications (Recipe Entity)
  -> Identity (Notifications (Recipe Entity)))
 -> GameState -> Identity GameState)
-> (Notifications (Recipe Entity) -> Notifications (Recipe Entity))
-> m ()
forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= Notifications (Recipe Entity)
-> Notifications (Recipe Entity) -> Notifications (Recipe Entity)
forall a. Monoid a => a -> a -> a
mappend (Int -> Bool -> [Recipe Entity] -> Notifications (Recipe Entity)
forall a. Int -> Bool -> [a] -> Notifications a
Notifications Int
newCount (Int
newCount Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) [Recipe Entity]
newRecipes)
  Entity -> m ()
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
Entity -> m ()
updateAvailableCommands Entity
e

updateAvailableCommands :: Has (State GameState) sig m => Entity -> m ()
updateAvailableCommands :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
Entity -> m ()
updateAvailableCommands Entity
e = do
  let newCaps :: Map Capability (ExerciseCost Text)
newCaps = Capabilities (ExerciseCost Text)
-> Map Capability (ExerciseCost Text)
forall e. Capabilities e -> Map Capability e
getMap (Capabilities (ExerciseCost Text)
 -> Map Capability (ExerciseCost Text))
-> Capabilities (ExerciseCost Text)
-> Map Capability (ExerciseCost Text)
forall a b. (a -> b) -> a -> b
$ Entity
e Entity
-> Getting
     (Capabilities (ExerciseCost Text))
     Entity
     (Capabilities (ExerciseCost Text))
-> Capabilities (ExerciseCost Text)
forall s a. s -> Getting a s a -> a
^. Getting
  (Capabilities (ExerciseCost Text))
  Entity
  (Capabilities (ExerciseCost Text))
Lens' Entity (Capabilities (ExerciseCost Text))
entityCapabilities
      keepConsts :: Maybe Capability -> Bool
keepConsts = \case
        Just Capability
cap -> Capability
cap Capability -> Map Capability (ExerciseCost Text) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.member` Map Capability (ExerciseCost Text)
newCaps
        Maybe Capability
Nothing -> Bool
False
      entityConsts :: [Const]
entityConsts = (Const -> Bool) -> [Const] -> [Const]
forall a. (a -> Bool) -> [a] -> [a]
filter (Maybe Capability -> Bool
keepConsts (Maybe Capability -> Bool)
-> (Const -> Maybe Capability) -> Const -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Const -> Maybe Capability
constCaps) [Const]
allConst
  [Const]
knownCommands <- Getting [Const] GameState [Const] -> m [Const]
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use (Getting [Const] GameState [Const] -> m [Const])
-> Getting [Const] GameState [Const] -> m [Const]
forall a b. (a -> b) -> a -> b
$ (Discovery -> Const [Const] Discovery)
-> GameState -> Const [Const] GameState
Lens' GameState Discovery
discovery ((Discovery -> Const [Const] Discovery)
 -> GameState -> Const [Const] GameState)
-> (([Const] -> Const [Const] [Const])
    -> Discovery -> Const [Const] Discovery)
-> Getting [Const] GameState [Const]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Notifications Const -> Const [Const] (Notifications Const))
-> Discovery -> Const [Const] Discovery
Lens' Discovery (Notifications Const)
availableCommands ((Notifications Const -> Const [Const] (Notifications Const))
 -> Discovery -> Const [Const] Discovery)
-> (([Const] -> Const [Const] [Const])
    -> Notifications Const -> Const [Const] (Notifications Const))
-> ([Const] -> Const [Const] [Const])
-> Discovery
-> Const [Const] Discovery
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Const] -> Const [Const] [Const])
-> Notifications Const -> Const [Const] (Notifications Const)
forall a1 a2 (f :: * -> *).
Functor f =>
([a1] -> f [a2]) -> Notifications a1 -> f (Notifications a2)
notificationsContent
  let newCommands :: [Const]
newCommands = (Const -> Bool) -> [Const] -> [Const]
forall a. (a -> Bool) -> [a] -> [a]
filter (Const -> [Const] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Const]
knownCommands) [Const]
entityConsts
      newCount :: Int
newCount = [Const] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Const]
newCommands
  (Discovery -> Identity Discovery)
-> GameState -> Identity GameState
Lens' GameState Discovery
discovery ((Discovery -> Identity Discovery)
 -> GameState -> Identity GameState)
-> ((Notifications Const -> Identity (Notifications Const))
    -> Discovery -> Identity Discovery)
-> (Notifications Const -> Identity (Notifications Const))
-> GameState
-> Identity GameState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Notifications Const -> Identity (Notifications Const))
-> Discovery -> Identity Discovery
Lens' Discovery (Notifications Const)
availableCommands ((Notifications Const -> Identity (Notifications Const))
 -> GameState -> Identity GameState)
-> (Notifications Const -> Notifications Const) -> m ()
forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= Notifications Const -> Notifications Const -> Notifications Const
forall a. Monoid a => a -> a -> a
mappend (Int -> Bool -> [Const] -> Notifications Const
forall a. Int -> Bool -> [a] -> Notifications a
Notifications Int
newCount (Int
newCount Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) [Const]
newCommands)

------------------------------------------------------------
-- The "watch" command
------------------------------------------------------------

addWatchedLocation ::
  HasRobotStepState sig m =>
  Cosmic Location ->
  m ()
addWatchedLocation :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Cosmic Location -> m ()
addWatchedLocation Cosmic Location
loc = do
  Int
rid <- Getting Int Robot Int -> m Int
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getting Int Robot Int
Getter Robot Int
robotID
  (Robots -> Identity Robots) -> GameState -> Identity GameState
Lens' GameState Robots
robotInfo ((Robots -> Identity Robots) -> GameState -> Identity GameState)
-> ((MonoidMap (Cosmic Location) IntSet
     -> Identity (MonoidMap (Cosmic Location) IntSet))
    -> Robots -> Identity Robots)
-> (MonoidMap (Cosmic Location) IntSet
    -> Identity (MonoidMap (Cosmic Location) IntSet))
-> GameState
-> Identity GameState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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))
 -> GameState -> Identity GameState)
-> (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)
-> Cosmic Location
-> MonoidMap (Cosmic Location) IntSet
-> MonoidMap (Cosmic Location) IntSet
forall k v.
(Ord k, MonoidNull v) =>
(v -> v) -> k -> MonoidMap k v -> MonoidMap k v
MM.adjust (Int -> IntSet -> IntSet
IS.insert Int
rid) Cosmic Location
loc

-- | Give some entities from a parent robot (the robot represented by
--   the ambient @State Robot@ effect) to a child robot (represented
--   by the given 'RID') as part of a 'Swarm.Language.Syntax.Build'
--   or 'Swarm.Language.Syntax.Reprogram' command.
--   The first 'Inventory' is devices to be equipped, and the second
--   is entities to be transferred.
--
--   In classic mode, the entities will be /transferred/ (that is,
--   removed from the parent robot's inventory); in creative mode, the
--   entities will be copied/created, that is, no entities will be
--   removed from the parent robot.
provisionChild ::
  (HasRobotStepState sig m) =>
  RID ->
  Inventory ->
  Inventory ->
  m ()
provisionChild :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Int -> Inventory -> Inventory -> m ()
provisionChild Int
childID Inventory
toEquip Inventory
toGive = do
  -- Equip and give devices to child
  StateC Robots Identity () -> m ()
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) b.
Has (State GameState) sig m =>
StateC Robots Identity b -> m b
zoomRobots (StateC Robots Identity () -> m ())
-> StateC Robots Identity () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    (IntMap Robot -> Identity (IntMap Robot))
-> Robots -> Identity Robots
Lens' Robots (IntMap Robot)
robotMap ((IntMap Robot -> Identity (IntMap Robot))
 -> Robots -> Identity Robots)
-> ((Inventory -> Identity Inventory)
    -> IntMap Robot -> Identity (IntMap Robot))
-> (Inventory -> Identity Inventory)
-> Robots
-> Identity Robots
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 Int
Index (IntMap Robot)
childID ((Robot -> Identity Robot)
 -> IntMap Robot -> Identity (IntMap Robot))
-> ((Inventory -> Identity Inventory) -> Robot -> Identity Robot)
-> (Inventory -> Identity Inventory)
-> IntMap Robot
-> Identity (IntMap Robot)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Inventory -> Identity Inventory) -> Robot -> Identity Robot
Lens' Robot Inventory
equippedDevices ((Inventory -> Identity Inventory) -> Robots -> Identity Robots)
-> (Inventory -> Inventory) -> StateC Robots Identity ()
forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= Inventory -> Inventory -> Inventory
E.union Inventory
toEquip
    (IntMap Robot -> Identity (IntMap Robot))
-> Robots -> Identity Robots
Lens' Robots (IntMap Robot)
robotMap ((IntMap Robot -> Identity (IntMap Robot))
 -> Robots -> Identity Robots)
-> ((Inventory -> Identity Inventory)
    -> IntMap Robot -> Identity (IntMap Robot))
-> (Inventory -> Identity Inventory)
-> Robots
-> Identity Robots
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 Int
Index (IntMap Robot)
childID ((Robot -> Identity Robot)
 -> IntMap Robot -> Identity (IntMap Robot))
-> ((Inventory -> Identity Inventory) -> Robot -> Identity Robot)
-> (Inventory -> Identity Inventory)
-> IntMap Robot
-> Identity (IntMap Robot)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Inventory -> Identity Inventory) -> Robot -> Identity Robot
Lens' Robot Inventory
robotInventory ((Inventory -> Identity Inventory) -> Robots -> Identity Robots)
-> (Inventory -> Inventory) -> StateC Robots Identity ()
forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= Inventory -> Inventory -> Inventory
E.union Inventory
toGive

  -- Delete all items from parent in classic mode
  Bool
creative <- Getting Bool GameState Bool -> m Bool
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getting Bool GameState Bool
Lens' GameState Bool
creativeMode
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
creative (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    (Inventory -> Identity Inventory) -> Robot -> Identity Robot
Lens' Robot Inventory
robotInventory ((Inventory -> Identity Inventory) -> Robot -> Identity Robot)
-> (Inventory -> Inventory) -> m ()
forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= (Inventory -> Inventory -> Inventory
`E.difference` (Inventory
toEquip Inventory -> Inventory -> Inventory
`E.union` Inventory
toGive))

------------------------------------------------------------
-- Exceptions and validation
------------------------------------------------------------

-- | Create an exception about a command failing, with an achievement
cmdExnWithAchievement :: Const -> [Text] -> GameplayAchievement -> Exn
cmdExnWithAchievement :: Const -> [Text] -> GameplayAchievement -> Exn
cmdExnWithAchievement Const
c [Text]
parts GameplayAchievement
a = Const -> Text -> Maybe GameplayAchievement -> Exn
CmdFailed Const
c ([Text] -> Text
T.unwords [Text]
parts) (Maybe GameplayAchievement -> Exn)
-> Maybe GameplayAchievement -> Exn
forall a b. (a -> b) -> a -> b
$ GameplayAchievement -> Maybe GameplayAchievement
forall a. a -> Maybe a
Just GameplayAchievement
a

-- | Raise an exception about a command failing with a formatted error message.
raise :: (Has (Throw Exn) sig m) => Const -> [Text] -> m a
raise :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Const -> [Text] -> m a
raise Const
c [Text]
parts = Exn -> m a
forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError (Const -> [Text] -> Exn
cmdExn Const
c [Text]
parts)

-- | Run a subcomputation that might throw an exception in a context
--   where we are returning a CESK machine; any exception will be
--   turned into an 'Up' state.
withExceptions :: Monad m => Store -> Cont -> ThrowC Exn m CESK -> m CESK
withExceptions :: forall (m :: * -> *).
Monad m =>
Store -> Cont -> ThrowC Exn m CESK -> m CESK
withExceptions Store
s Cont
k ThrowC Exn m CESK
m = do
  Either Exn CESK
res <- ThrowC Exn m CESK -> m (Either Exn CESK)
forall e (m :: * -> *) a. ThrowC e m a -> m (Either e a)
runThrow ThrowC Exn m CESK
m
  case Either Exn CESK
res of
    Left Exn
exn -> CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ Exn -> Store -> Cont -> CESK
Up Exn
exn Store
s Cont
k
    Right CESK
a -> CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return CESK
a

-- | Print some text via the robot's log.
traceLog :: (Has (State GameState) sig m, Has (State Robot) sig m) => RobotLogSource -> Severity -> Text -> m LogEntry
traceLog :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m) =>
RobotLogSource -> Severity -> Text -> m LogEntry
traceLog RobotLogSource
source Severity
sev Text
msg = do
  LogEntry
m <- RobotLogSource -> Severity -> Text -> m LogEntry
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m) =>
RobotLogSource -> Severity -> Text -> m LogEntry
createLogEntry RobotLogSource
source Severity
sev Text
msg
  (Seq LogEntry -> Identity (Seq LogEntry))
-> Robot -> Identity Robot
Lens' Robot (Seq LogEntry)
robotLog ((Seq LogEntry -> Identity (Seq LogEntry))
 -> Robot -> Identity Robot)
-> (Seq LogEntry -> Seq LogEntry) -> m ()
forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= (Seq LogEntry -> LogEntry -> Seq LogEntry
forall a. Seq a -> a -> Seq a
Seq.|> LogEntry
m)
  LogEntry -> m LogEntry
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return LogEntry
m

updateWorldAndRobots ::
  (HasRobotStepState sig m) =>
  Const ->
  [WorldUpdate Entity] ->
  [RobotUpdate] ->
  m ()
updateWorldAndRobots :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Const -> [WorldUpdate Entity] -> [RobotUpdate] -> m ()
updateWorldAndRobots Const
cmd [WorldUpdate Entity]
wf [RobotUpdate]
rf = do
  (WorldUpdate Entity -> m ()) -> [WorldUpdate Entity] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Const -> WorldUpdate Entity -> m ()
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Const -> WorldUpdate Entity -> m ()
updateWorld Const
cmd) [WorldUpdate Entity]
wf
  [RobotUpdate] -> m ()
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m) =>
[RobotUpdate] -> m ()
applyRobotUpdates [RobotUpdate]
rf
  m ()
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
m ()
flagRedraw

-- | Format a set of suggested devices for use in an error message,
--   in the format @device1 or device2 or ... or deviceN@.
formatDevices :: Set Entity -> Text
formatDevices :: Set Entity -> Text
formatDevices = Text -> [Text] -> Text
T.intercalate Text
" or " ([Text] -> Text) -> (Set Entity -> [Text]) -> Set Entity -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Entity -> Text) -> [Entity] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Entity -> Getting Text Entity Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text Entity Text
Lens' Entity Text
entityName) ([Entity] -> [Text])
-> (Set Entity -> [Entity]) -> Set Entity -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Entity -> [Entity]
forall a. Set a -> [a]
S.toList

------------------------------------------------------------
-- Debugging
------------------------------------------------------------

-- | Create a log entry given current robot and game time in ticks
--   noting whether it has been said.
--
--   This is the more generic version used both for (recorded) said
--   messages and normal logs.
createLogEntry ::
  (Has (State GameState) sig m, Has (State Robot) sig m) =>
  RobotLogSource ->
  Severity ->
  Text ->
  m LogEntry
createLogEntry :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m) =>
RobotLogSource -> Severity -> Text -> m LogEntry
createLogEntry RobotLogSource
source Severity
sev Text
msg = do
  Int
rid <- Getting Int Robot Int -> m Int
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getting Int Robot Int
Getter Robot Int
robotID
  Text
rn <- Getting Text Robot Text -> m Text
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getting Text Robot Text
Lens' Robot Text
robotName
  TickNumber
time <- Getting TickNumber GameState TickNumber -> m TickNumber
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use (Getting TickNumber GameState TickNumber -> m TickNumber)
-> Getting TickNumber GameState TickNumber -> m TickNumber
forall a b. (a -> b) -> a -> b
$ (TemporalState -> Const TickNumber TemporalState)
-> GameState -> Const TickNumber GameState
Lens' GameState TemporalState
temporal ((TemporalState -> Const TickNumber TemporalState)
 -> GameState -> Const TickNumber GameState)
-> ((TickNumber -> Const TickNumber TickNumber)
    -> TemporalState -> Const TickNumber TemporalState)
-> Getting TickNumber GameState TickNumber
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TickNumber -> Const TickNumber TickNumber)
-> TemporalState -> Const TickNumber TemporalState
Lens' TemporalState TickNumber
ticks
  Cosmic Location
loc <- Getting (Cosmic Location) Robot (Cosmic Location)
-> m (Cosmic Location)
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getting (Cosmic Location) Robot (Cosmic Location)
Getter Robot (Cosmic Location)
robotLocation
  LogEntry -> m LogEntry
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LogEntry -> m LogEntry) -> LogEntry -> m LogEntry
forall a b. (a -> b) -> a -> b
$ TickNumber -> LogSource -> Severity -> Text -> Text -> LogEntry
LogEntry TickNumber
time (RobotLogSource -> Int -> Cosmic Location -> LogSource
RobotLog RobotLogSource
source Int
rid Cosmic Location
loc) Severity
sev Text
rn Text
msg

-- | replace some entity in the world with another entity
updateWorld ::
  HasRobotStepState sig m =>
  Const ->
  WorldUpdate Entity ->
  m ()
updateWorld :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Const -> WorldUpdate Entity -> m ()
updateWorld Const
c (ReplaceEntity Cosmic Location
loc Entity
eThen Maybe Entity
down) = do
  MultiWorld Int Entity
w <- Getting (MultiWorld Int Entity) GameState (MultiWorld Int Entity)
-> m (MultiWorld Int Entity)
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use (Getting (MultiWorld Int Entity) GameState (MultiWorld Int Entity)
 -> m (MultiWorld Int Entity))
-> Getting
     (MultiWorld Int Entity) GameState (MultiWorld Int Entity)
-> m (MultiWorld Int Entity)
forall a b. (a -> b) -> a -> b
$ (Landscape -> Const (MultiWorld Int Entity) Landscape)
-> GameState -> Const (MultiWorld Int Entity) GameState
Lens' GameState Landscape
landscape ((Landscape -> Const (MultiWorld Int Entity) Landscape)
 -> GameState -> Const (MultiWorld Int Entity) GameState)
-> ((MultiWorld Int Entity
     -> Const (MultiWorld Int Entity) (MultiWorld Int Entity))
    -> Landscape -> Const (MultiWorld Int Entity) Landscape)
-> Getting
     (MultiWorld Int Entity) GameState (MultiWorld Int Entity)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MultiWorld Int Entity
 -> Const (MultiWorld Int Entity) (MultiWorld Int Entity))
-> Landscape -> Const (MultiWorld Int Entity) Landscape
Lens' Landscape (MultiWorld Int Entity)
multiWorld
  let eNow :: Maybe Entity
eNow = Cosmic Coords -> MultiWorld Int Entity -> Maybe Entity
forall t e. Cosmic Coords -> MultiWorld t e -> Maybe e
W.lookupCosmicEntity ((Location -> Coords) -> Cosmic Location -> Cosmic Coords
forall a b. (a -> b) -> Cosmic a -> Cosmic b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Location -> Coords
locToCoords Cosmic Location
loc) MultiWorld Int Entity
w
  -- Can fail if a robot started a multi-tick "drill" operation on some entity
  -- and meanwhile another entity swaps it out from under them.
  if Entity -> Maybe Entity
forall a. a -> Maybe a
Just Entity
eThen Maybe Entity -> Maybe Entity -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Entity
eNow
    then Exn -> m ()
forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError (Exn -> m ()) -> Exn -> m ()
forall a b. (a -> b) -> a -> b
$ Const -> [Text] -> Exn
cmdExn Const
c [Text
"The", Entity
eThen Entity -> Getting Text Entity Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text Entity Text
Lens' Entity Text
entityName, Text
"is not there."]
    else Cosmic Location -> (Maybe Entity -> Maybe Entity) -> m ()
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State Robot) sig m, Has (State GameState) sig m) =>
Cosmic Location -> (Maybe Entity -> Maybe Entity) -> m ()
updateEntityAt Cosmic Location
loc ((Maybe Entity -> Maybe Entity) -> m ())
-> (Maybe Entity -> Maybe Entity) -> m ()
forall a b. (a -> b) -> a -> b
$ Maybe Entity -> Maybe Entity -> Maybe Entity
forall a b. a -> b -> a
const Maybe Entity
down

applyRobotUpdates ::
  (Has (State GameState) sig m, Has (State Robot) sig m) =>
  [RobotUpdate] ->
  m ()
applyRobotUpdates :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m) =>
[RobotUpdate] -> m ()
applyRobotUpdates =
  (RobotUpdate -> m ()) -> [RobotUpdate] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ \case
    AddEntity Int
c Entity
e -> (Inventory -> Identity Inventory) -> Robot -> Identity Robot
Lens' Robot Inventory
robotInventory ((Inventory -> Identity Inventory) -> Robot -> Identity Robot)
-> (Inventory -> Inventory) -> m ()
forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= Int -> Entity -> Inventory -> Inventory
E.insertCount Int
c Entity
e
    LearnEntity Entity
e -> (Inventory -> Identity Inventory) -> Robot -> Identity Robot
Lens' Robot Inventory
robotInventory ((Inventory -> Identity Inventory) -> Robot -> Identity Robot)
-> (Inventory -> Inventory) -> m ()
forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= Int -> Entity -> Inventory -> Inventory
E.insertCount Int
0 Entity
e

-- | Construct a "seed robot" from entity, time range and position,
--   and add it to the world.  It has low priority and will be covered
--   by placed entities.
addSeedBot ::
  Has (State GameState) sig m =>
  Entity ->
  (Integer, Integer) ->
  Integer ->
  Integer ->
  Cosmic Location ->
  TimeSpec ->
  m ()
addSeedBot :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
Entity
-> (Integer, Integer)
-> Integer
-> Integer
-> Cosmic Location
-> TimeSpec
-> m ()
addSeedBot Entity
e (Integer
minT, Integer
maxT) Integer
seedlingCount Integer
seedlingRadius Cosmic Location
loc TimeSpec
ts =
  StateC Robots Identity () -> m ()
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) b.
Has (State GameState) sig m =>
StateC Robots Identity b -> m b
zoomRobots
    (StateC Robots Identity () -> m ())
-> (TRobot -> StateC Robots Identity ()) -> TRobot -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CESK -> TRobot -> StateC Robots Identity ()
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State Robots) sig m =>
CESK -> TRobot -> m ()
addTRobot (TSyntax -> CESK
initMachine TSyntax
seedProg)
    (TRobot -> m ()) -> TRobot -> m ()
forall a b. (a -> b) -> a -> b
$ Maybe Int
-> Text
-> Document Syntax
-> Maybe (Cosmic Location)
-> V2 Int32
-> Display
-> Maybe TSyntax
-> [Entity]
-> [(Int, Entity)]
-> Bool
-> Bool
-> WalkabilityExceptions Text
-> TimeSpec
-> TRobot
mkRobot
      Maybe Int
forall a. Maybe a
Nothing
      Text
"seed"
      (Text -> Document Syntax
Markdown.fromText (Text -> Document Syntax) -> Text -> Document Syntax
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unwords [Text
"A growing", Entity
e Entity -> Getting Text Entity Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text Entity Text
Lens' Entity Text
entityName, Text
"seed."])
      (Cosmic Location -> Maybe (Cosmic Location)
forall a. a -> Maybe a
Just Cosmic Location
loc)
      V2 Int32
forall a. Num a => V2 a
forall (f :: * -> *) a. (Additive f, Num a) => f a
zero
      ( Char -> Display
defaultEntityDisplay Char
'.'
          Display -> (Display -> Display) -> Display
forall a b. a -> (a -> b) -> b
& (Attribute -> Identity Attribute) -> Display -> Identity Display
Lens' Display Attribute
displayAttr ((Attribute -> Identity Attribute) -> Display -> Identity Display)
-> Attribute -> Display -> Display
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Entity
e Entity -> Getting Attribute Entity Attribute -> Attribute
forall s a. s -> Getting a s a -> a
^. (Display -> Const Attribute Display)
-> Entity -> Const Attribute Entity
Lens' Entity Display
entityDisplay ((Display -> Const Attribute Display)
 -> Entity -> Const Attribute Entity)
-> ((Attribute -> Const Attribute Attribute)
    -> Display -> Const Attribute Display)
-> Getting Attribute Entity Attribute
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Attribute -> Const Attribute Attribute)
-> Display -> Const Attribute Display
Lens' Display Attribute
displayAttr)
          Display -> (Display -> Display) -> Display
forall a b. a -> (a -> b) -> b
& (Int -> Identity Int) -> Display -> Identity Display
Lens' Display Int
displayPriority ((Int -> Identity Int) -> Display -> Identity Display)
-> Int -> Display -> Display
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Int
0
          Display -> (Display -> Display) -> Display
forall a b. a -> (a -> b) -> b
& (ChildInheritance -> Identity ChildInheritance)
-> Display -> Identity Display
Lens' Display ChildInheritance
childInheritance ((ChildInheritance -> Identity ChildInheritance)
 -> Display -> Identity Display)
-> ChildInheritance -> Display -> Display
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ChildInheritance
Invisible
      )
      Maybe TSyntax
forall a. Maybe a
Nothing
      []
      [(Int
1, Entity
e)]
      Bool
True
      Bool
False
      WalkabilityExceptions Text
forall a. Monoid a => Inclusions a
emptyExceptions
      TimeSpec
ts
 where
  seedProg :: TSyntax
seedProg =
    Integer -> Integer -> Integer -> Integer -> Text -> TSyntax
seedProgram
      Integer
minT
      (Integer
maxT Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
minT)
      Integer
seedlingCount
      Integer
seedlingRadius
      (Entity
e Entity -> Getting Text Entity Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text Entity Text
Lens' Entity Text
entityName)

-- | A system program for a "seed robot", to regrow a growable entity
--   after it is harvested.
--
-- NOTE: Seedling propagation delay (spreadable growth)
-- re-uses the growth timing parameters.
seedProgram ::
  -- | min time
  Integer ->
  -- | rand time
  Integer ->
  -- | seedling count
  Integer ->
  -- | seedling radius
  Integer ->
  -- | entity to place
  EntityName ->
  TSyntax
seedProgram :: Integer -> Integer -> Integer -> Integer -> Text -> TSyntax
seedProgram Integer
minTime Integer
randTime Integer
seedlingCount Integer
seedlingRadius Text
thing =
  [tmQ|
    def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end;

    try {
      r <- random (1 + $int:randTime);
      wait (r + $int:minTime);
      appear "|" (inl ());
      r <- random (1 + $int:randTime);
      wait (r + $int:minTime);
      place $str:thing;

      doN $int:seedlingCount (
        _robo <- build {
          propagationDelay <- random (1 + $int:randTime);
          wait (propagationDelay + $int:minTime);

          totalDist <- random (1 + $int:seedlingRadius);
          horizontalDist <- random (1 + totalDist);
          let verticalDist = totalDist - horizontalDist in

          shouldReverse <- random 2;
          if (shouldReverse == 0) {
            turn back;
          } {};
          stride horizontalDist;
          turn left;
          shouldReverse2 <- random 2;
          if (shouldReverse2 == 0) {
            turn back;
          } {};
          stride verticalDist;

          create $str:thing;
          try {
            sow $str:thing;
          } {};

          selfdestruct
        };
      );
    } {};
    selfdestruct
  |]

------------------------------------------------------------
-- Some utility functions
------------------------------------------------------------

verbGrabbingCmd :: GrabbingCmd -> Text
verbGrabbingCmd :: GrabbingCmd -> Text
verbGrabbingCmd = \case
  GrabbingCmd
Harvest' -> Text
"harvest"
  GrabbingCmd
Grab' -> Text
"grab"
  GrabbingCmd
Swap' -> Text
"swap"
  GrabbingCmd
Push' -> Text
"push"