{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}

-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Utilities for implementing robot commands.
module Swarm.Game.Step.Util where

import Control.Carrier.State.Lazy
import Control.Effect.Error
import Control.Effect.Lens
import Control.Monad (forM_, guard, when)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)
import Control.Monad.Trans.State.Strict qualified as TS
import Data.Array (bounds, (!))
import Data.IntMap qualified as IM
import Data.Set qualified as S
import Data.Text (Text)
import Data.Text qualified as T
import Linear (zero)
import Swarm.Game.Device
import Swarm.Game.Entity hiding (empty, lookup, singleton, union)
import Swarm.Game.Exception
import Swarm.Game.Location
import Swarm.Game.Robot
import Swarm.Game.Scenario.Topography.Modify qualified as WM
import Swarm.Game.Scenario.Topography.Structure.Recognition.Tracking qualified as SRT
import Swarm.Game.State
import Swarm.Game.State.Landscape (recognizerAutomatons)
import Swarm.Game.State.Robot
import Swarm.Game.State.Substate
import Swarm.Game.Step.Path.Cache
import Swarm.Game.Step.Path.Type
import Swarm.Game.Step.Path.Walkability
import Swarm.Game.Step.RobotStepState
import Swarm.Game.Universe
import Swarm.Game.World qualified as W
import Swarm.Game.World.Coords
import Swarm.Language.Capability
import Swarm.Language.Requirements.Type qualified as R
import Swarm.Language.Syntax
import Swarm.Language.Syntax.Direction (Direction)
import Swarm.ResourceLoading (NameGenerator (..))
import Swarm.Util hiding (both)
import System.Random (UniformRange, uniformR)
import Prelude hiding (lookup)

deriveHeading :: HasRobotStepState sig m => Direction -> m Heading
deriveHeading :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Direction -> m Heading
deriveHeading Direction
d = do
  Maybe Heading
orient <- Getting (Maybe Heading) Robot (Maybe Heading) -> m (Maybe Heading)
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getting (Maybe Heading) Robot (Maybe Heading)
Lens' Robot (Maybe Heading)
robotOrientation
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Direction -> Bool
isCardinal Direction
d) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Capability -> Term -> m ()
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State Robot) sig m, Has (State GameState) sig m,
 Has (Throw Exn) sig m) =>
Capability -> Term -> m ()
hasCapabilityFor Capability
COrient (Term -> m ()) -> Term -> m ()
forall a b. (a -> b) -> a -> b
$ Direction -> Term
forall ty. Direction -> Term' ty
TDir Direction
d
  Heading -> m Heading
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Heading -> m Heading) -> Heading -> m Heading
forall a b. (a -> b) -> a -> b
$ Direction -> Heading -> Heading
applyTurn Direction
d (Heading -> Heading) -> Heading -> Heading
forall a b. (a -> b) -> a -> b
$ Maybe Heading
orient Maybe Heading -> Heading -> Heading
forall a. Maybe a -> a -> a
? Heading
forall a. Num a => V2 a
forall (f :: * -> *) a. (Additive f, Num a) => f a
zero

lookInDirection :: HasRobotStepState sig m => Direction -> m (Cosmic Location, Maybe Entity)
lookInDirection :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Direction -> m (Cosmic Location, Maybe Entity)
lookInDirection Direction
d = do
  Heading
newHeading <- Direction -> m Heading
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Direction -> m Heading
deriveHeading Direction
d
  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
  let nextLoc :: Cosmic Location
nextLoc = Cosmic Location
loc Cosmic Location -> Heading -> Cosmic Location
`offsetBy` Heading
newHeading
  (Cosmic Location
nextLoc,) (Maybe Entity -> (Cosmic Location, Maybe Entity))
-> m (Maybe Entity) -> m (Cosmic Location, Maybe Entity)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cosmic Location -> m (Maybe Entity)
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
Cosmic Location -> m (Maybe Entity)
entityAt Cosmic Location
nextLoc

adaptGameState ::
  Has (State GameState) sig m =>
  TS.State GameState b ->
  m b
adaptGameState :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *) b.
Has (State GameState) sig m =>
State GameState b -> m b
adaptGameState State GameState b
f = do
  (b
newRecognizer, GameState
newGS) <- State GameState b -> GameState -> (b, GameState)
forall s a. State s a -> s -> (a, s)
TS.runState State GameState b
f (GameState -> (b, GameState)) -> m GameState -> m (b, GameState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m GameState
forall s (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
m s
get
  GameState -> m ()
forall s (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
s -> m ()
put GameState
newGS
  b -> m b
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return b
newRecognizer

-- | Modify the entity (if any) at a given location.
updateEntityAt ::
  (Has (State Robot) sig m, Has (State GameState) sig m) =>
  Cosmic Location ->
  (Maybe Entity -> Maybe Entity) ->
  m ()
updateEntityAt :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State Robot) sig m, Has (State GameState) sig m) =>
Cosmic Location -> (Maybe Entity -> Maybe Entity) -> m ()
updateEntityAt cLoc :: Cosmic Location
cLoc@(Cosmic SubworldName
subworldName Location
loc) Maybe Entity -> Maybe Entity
upd = do
  Maybe (CellUpdate Entity)
someChange <-
    SubworldName
-> StateC (World Int Entity) Identity (CellUpdate Entity)
-> m (Maybe (CellUpdate Entity))
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) b.
Has (State GameState) sig m =>
SubworldName -> StateC (World Int Entity) Identity b -> m (Maybe b)
zoomWorld SubworldName
subworldName (StateC (World Int Entity) Identity (CellUpdate Entity)
 -> m (Maybe (CellUpdate Entity)))
-> StateC (World Int Entity) Identity (CellUpdate Entity)
-> m (Maybe (CellUpdate Entity))
forall a b. (a -> b) -> a -> b
$
      forall t (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State (World t Entity)) sig m, IArray UArray t) =>
Coords -> (Maybe Entity -> Maybe Entity) -> m (CellUpdate Entity)
W.updateM @Int (Location -> Coords
locToCoords Location
loc) Maybe Entity -> Maybe Entity
upd

  Maybe (CellModification Entity)
-> (CellModification Entity -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (CellUpdate Entity -> Maybe (CellModification Entity)
forall e. CellUpdate e -> Maybe (CellModification e)
WM.getModification (CellUpdate Entity -> Maybe (CellModification Entity))
-> Maybe (CellUpdate Entity) -> Maybe (CellModification Entity)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe (CellUpdate Entity)
someChange) ((CellModification Entity -> m ()) -> m ())
-> (CellModification Entity -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \CellModification Entity
modType -> do
    TickNumber
currentTick <- 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
    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
    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
$ Int -> TickNumber -> Cosmic Location -> StateC Robots Identity ()
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State Robots) sig m =>
Int -> TickNumber -> Cosmic Location -> m ()
wakeWatchingRobots Int
myID TickNumber
currentTick Cosmic Location
cLoc

    RecognizerAutomatons RecognizableStructureContent Entity
structureRecognizer <- Getting
  (RecognizerAutomatons RecognizableStructureContent Entity)
  GameState
  (RecognizerAutomatons RecognizableStructureContent Entity)
-> m (RecognizerAutomatons RecognizableStructureContent Entity)
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use (Getting
   (RecognizerAutomatons RecognizableStructureContent Entity)
   GameState
   (RecognizerAutomatons RecognizableStructureContent Entity)
 -> m (RecognizerAutomatons RecognizableStructureContent Entity))
-> Getting
     (RecognizerAutomatons RecognizableStructureContent Entity)
     GameState
     (RecognizerAutomatons RecognizableStructureContent Entity)
-> m (RecognizerAutomatons RecognizableStructureContent Entity)
forall a b. (a -> b) -> a -> b
$ (Landscape
 -> Const
      (RecognizerAutomatons RecognizableStructureContent Entity)
      Landscape)
-> GameState
-> Const
     (RecognizerAutomatons RecognizableStructureContent Entity)
     GameState
Lens' GameState Landscape
landscape ((Landscape
  -> Const
       (RecognizerAutomatons RecognizableStructureContent Entity)
       Landscape)
 -> GameState
 -> Const
      (RecognizerAutomatons RecognizableStructureContent Entity)
      GameState)
-> ((RecognizerAutomatons RecognizableStructureContent Entity
     -> Const
          (RecognizerAutomatons RecognizableStructureContent Entity)
          (RecognizerAutomatons RecognizableStructureContent Entity))
    -> Landscape
    -> Const
         (RecognizerAutomatons RecognizableStructureContent Entity)
         Landscape)
-> Getting
     (RecognizerAutomatons RecognizableStructureContent Entity)
     GameState
     (RecognizerAutomatons RecognizableStructureContent Entity)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RecognizerAutomatons RecognizableStructureContent Entity
 -> Const
      (RecognizerAutomatons RecognizableStructureContent Entity)
      (RecognizerAutomatons RecognizableStructureContent Entity))
-> Landscape
-> Const
     (RecognizerAutomatons RecognizableStructureContent Entity)
     Landscape
Lens'
  Landscape
  (RecognizerAutomatons RecognizableStructureContent Entity)
recognizerAutomatons
    RecognitionState RecognizableStructureContent Entity
oldRecognition <- Getting
  (RecognitionState RecognizableStructureContent Entity)
  GameState
  (RecognitionState RecognizableStructureContent Entity)
-> m (RecognitionState RecognizableStructureContent Entity)
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use (Getting
   (RecognitionState RecognizableStructureContent Entity)
   GameState
   (RecognitionState RecognizableStructureContent Entity)
 -> m (RecognitionState RecognizableStructureContent Entity))
-> Getting
     (RecognitionState RecognizableStructureContent Entity)
     GameState
     (RecognitionState RecognizableStructureContent Entity)
-> m (RecognitionState RecognizableStructureContent Entity)
forall a b. (a -> b) -> a -> b
$ (Discovery
 -> Const
      (RecognitionState RecognizableStructureContent Entity) Discovery)
-> GameState
-> Const
     (RecognitionState RecognizableStructureContent Entity) GameState
Lens' GameState Discovery
discovery ((Discovery
  -> Const
       (RecognitionState RecognizableStructureContent Entity) Discovery)
 -> GameState
 -> Const
      (RecognitionState RecognizableStructureContent Entity) GameState)
-> ((RecognitionState RecognizableStructureContent Entity
     -> Const
          (RecognitionState RecognizableStructureContent Entity)
          (RecognitionState RecognizableStructureContent Entity))
    -> Discovery
    -> Const
         (RecognitionState RecognizableStructureContent Entity) Discovery)
-> Getting
     (RecognitionState RecognizableStructureContent Entity)
     GameState
     (RecognitionState RecognizableStructureContent Entity)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RecognitionState RecognizableStructureContent Entity
 -> Const
      (RecognitionState RecognizableStructureContent Entity)
      (RecognitionState RecognizableStructureContent Entity))
-> Discovery
-> Const
     (RecognitionState RecognizableStructureContent Entity) Discovery
Lens'
  Discovery (RecognitionState RecognizableStructureContent Entity)
structureRecognition
    RecognitionState RecognizableStructureContent Entity
newRecognition <- State
  GameState (RecognitionState RecognizableStructureContent Entity)
-> m (RecognitionState RecognizableStructureContent Entity)
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) b.
Has (State GameState) sig m =>
State GameState b -> m b
adaptGameState (State
   GameState (RecognitionState RecognizableStructureContent Entity)
 -> m (RecognitionState RecognizableStructureContent Entity))
-> State
     GameState (RecognitionState RecognizableStructureContent Entity)
-> m (RecognitionState RecognizableStructureContent Entity)
forall a b. (a -> b) -> a -> b
$ GenericEntLocator (StateT GameState Identity) Entity
-> CellModification Entity
-> Cosmic Location
-> RecognizerAutomatons RecognizableStructureContent Entity
-> RecognitionState RecognizableStructureContent Entity
-> State
     GameState (RecognitionState RecognizableStructureContent Entity)
forall (s :: * -> *) a b.
(Monad s, Hashable a, Eq b) =>
GenericEntLocator s a
-> CellModification a
-> Cosmic Location
-> RecognizerAutomatons b a
-> RecognitionState b a
-> s (RecognitionState b a)
SRT.entityModified GenericEntLocator (StateT GameState Identity) Entity
mtlEntityAt CellModification Entity
modType Cosmic Location
cLoc RecognizerAutomatons RecognizableStructureContent Entity
structureRecognizer RecognitionState RecognizableStructureContent Entity
oldRecognition
    (Discovery -> Identity Discovery)
-> GameState -> Identity GameState
Lens' GameState Discovery
discovery ((Discovery -> Identity Discovery)
 -> GameState -> Identity GameState)
-> ((RecognitionState RecognizableStructureContent Entity
     -> Identity (RecognitionState RecognizableStructureContent Entity))
    -> Discovery -> Identity Discovery)
-> (RecognitionState RecognizableStructureContent Entity
    -> Identity (RecognitionState RecognizableStructureContent Entity))
-> GameState
-> Identity GameState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RecognitionState RecognizableStructureContent Entity
 -> Identity (RecognitionState RecognizableStructureContent Entity))
-> Discovery -> Identity Discovery
Lens'
  Discovery (RecognitionState RecognizableStructureContent Entity)
structureRecognition ((RecognitionState RecognizableStructureContent Entity
  -> Identity (RecognitionState RecognizableStructureContent Entity))
 -> GameState -> Identity GameState)
-> RecognitionState RecognizableStructureContent Entity -> m ()
forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= RecognitionState RecognizableStructureContent Entity
newRecognition

    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
    ((Int, PathfindingCache) -> m ())
-> [(Int, PathfindingCache)] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Cosmic Location
-> CellModification Entity -> (Int, PathfindingCache) -> m ()
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
Cosmic Location
-> CellModification Entity -> (Int, PathfindingCache) -> m ()
revalidatePathCache Cosmic Location
cLoc CellModification Entity
modType) ([(Int, PathfindingCache)] -> m ())
-> [(Int, PathfindingCache)] -> m ()
forall a b. (a -> b) -> a -> b
$ IntMap PathfindingCache -> [(Int, PathfindingCache)]
forall a. IntMap a -> [(Int, a)]
IM.toList IntMap PathfindingCache
pcr

-- * Capabilities

-- | Exempts the robot from various command constraints
-- when it is either a system robot or playing in creative mode
isPrivilegedBot :: (Has (State GameState) sig m, Has (State Robot) sig m) => m Bool
isPrivilegedBot :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m) =>
m Bool
isPrivilegedBot = Bool -> Bool -> Bool
(||) (Bool -> Bool -> Bool) -> m Bool -> m (Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 m (Bool -> Bool) -> m Bool -> m Bool
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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

-- | Test whether the current robot has a given capability (either
--   because it has a device which gives it that capability, or it is a
--   system robot, or we are in creative mode).
hasCapability :: (Has (State Robot) sig m, Has (State GameState) sig m) => Capability -> m Bool
hasCapability :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State Robot) sig m, Has (State GameState) sig m) =>
Capability -> m Bool
hasCapability Capability
cap = do
  Bool
isPrivileged <- m Bool
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m) =>
m Bool
isPrivilegedBot
  MultiEntityCapabilities Entity EntityName
caps <- Getting
  (MultiEntityCapabilities Entity EntityName)
  Robot
  (MultiEntityCapabilities Entity EntityName)
-> m (MultiEntityCapabilities Entity EntityName)
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getting
  (MultiEntityCapabilities Entity EntityName)
  Robot
  (MultiEntityCapabilities Entity EntityName)
Getter Robot (MultiEntityCapabilities Entity EntityName)
robotCapabilities
  Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
isPrivileged Bool -> Bool -> Bool
|| Capability
cap Capability -> Set Capability -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` MultiEntityCapabilities Entity EntityName -> Set Capability
forall e. Capabilities e -> Set Capability
getCapabilitySet MultiEntityCapabilities Entity EntityName
caps)

-- | Ensure that either a robot has a given capability, OR we are in creative
--   mode.
hasCapabilityFor ::
  (Has (State Robot) sig m, Has (State GameState) sig m, Has (Throw Exn) sig m) => Capability -> Term -> m ()
hasCapabilityFor :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State Robot) sig m, Has (State GameState) sig m,
 Has (Throw Exn) sig m) =>
Capability -> Term -> m ()
hasCapabilityFor Capability
cap Term
term = do
  Bool
h <- Capability -> m Bool
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State Robot) sig m, Has (State GameState) sig m) =>
Capability -> m Bool
hasCapability Capability
cap
  Bool
h Bool -> Exn -> m ()
forall e (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw e) sig m =>
Bool -> e -> m ()
`holdsOr` IncapableFix -> Requirements -> Term -> Exn
Incapable IncapableFix
FixByEquip (Capability -> Requirements
R.singletonCap Capability
cap) Term
term

-- * Exceptions

holdsOrFail' :: (Has (Throw Exn) sig m) => Const -> Bool -> [Text] -> m ()
holdsOrFail' :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Const -> Bool -> [EntityName] -> m ()
holdsOrFail' Const
c Bool
a [EntityName]
ts = Bool
a Bool -> Exn -> m ()
forall e (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw e) sig m =>
Bool -> e -> m ()
`holdsOr` Const -> [EntityName] -> Exn
cmdExn Const
c [EntityName]
ts

isJustOrFail' :: (Has (Throw Exn) sig m) => Const -> Maybe a -> [Text] -> m a
isJustOrFail' :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Const -> Maybe a -> [EntityName] -> m a
isJustOrFail' Const
c Maybe a
a [EntityName]
ts = Maybe a
a Maybe a -> Exn -> m a
forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
Maybe a -> e -> m a
`isJustOr` Const -> [EntityName] -> Exn
cmdExn Const
c [EntityName]
ts

-- | Create an exception about a command failing.
cmdExn :: Const -> [Text] -> Exn
cmdExn :: Const -> [EntityName] -> Exn
cmdExn Const
c [EntityName]
parts = Const -> EntityName -> Maybe GameplayAchievement -> Exn
CmdFailed Const
c ([EntityName] -> EntityName
T.unwords [EntityName]
parts) Maybe GameplayAchievement
forall a. Maybe a
Nothing

-- * Some utility functions

-- | Set a flag telling the UI that the world needs to be redrawn.
flagRedraw :: (Has (State GameState) sig m) => m ()
flagRedraw :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
m ()
flagRedraw = (Bool -> Identity Bool) -> GameState -> Identity GameState
Lens' GameState Bool
needsRedraw ((Bool -> Identity Bool) -> GameState -> Identity GameState)
-> Bool -> m ()
forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= Bool
True

-- * Randomness

-- | Generate a uniformly random number using the random generator in
--   the game state.
uniform :: (Has (State GameState) sig m, UniformRange a) => (a, a) -> m a
uniform :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(Has (State GameState) sig m, UniformRange a) =>
(a, a) -> m a
uniform (a, a)
bnds = do
  StdGen
rand <- Getting StdGen GameState StdGen -> m StdGen
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use (Getting StdGen GameState StdGen -> m StdGen)
-> Getting StdGen GameState StdGen -> m StdGen
forall a b. (a -> b) -> a -> b
$ (Randomness -> Const StdGen Randomness)
-> GameState -> Const StdGen GameState
Lens' GameState Randomness
randomness ((Randomness -> Const StdGen Randomness)
 -> GameState -> Const StdGen GameState)
-> ((StdGen -> Const StdGen StdGen)
    -> Randomness -> Const StdGen Randomness)
-> Getting StdGen GameState StdGen
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StdGen -> Const StdGen StdGen)
-> Randomness -> Const StdGen Randomness
Lens' Randomness StdGen
randGen
  let (a
n, StdGen
g) = (a, a) -> StdGen -> (a, StdGen)
forall a g. (UniformRange a, RandomGen g) => (a, a) -> g -> (a, g)
uniformR (a, a)
bnds StdGen
rand
  (Randomness -> Identity Randomness)
-> GameState -> Identity GameState
Lens' GameState Randomness
randomness ((Randomness -> Identity Randomness)
 -> GameState -> Identity GameState)
-> ((StdGen -> Identity StdGen)
    -> Randomness -> Identity Randomness)
-> (StdGen -> Identity StdGen)
-> GameState
-> Identity GameState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StdGen -> Identity StdGen) -> Randomness -> Identity Randomness
Lens' Randomness StdGen
randGen ((StdGen -> Identity StdGen) -> GameState -> Identity GameState)
-> StdGen -> m ()
forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= StdGen
g
  a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
n

-- | Given a weighting function and a list of values, choose one of
--   the values randomly (using the random generator in the game
--   state), with the probability of each being proportional to its
--   weight.  Return @Nothing@ if the list is empty.
weightedChoice :: Has (State GameState) sig m => (a -> Integer) -> [a] -> m (Maybe a)
weightedChoice :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (State GameState) sig m =>
(a -> Integer) -> [a] -> m (Maybe a)
weightedChoice a -> Integer
weight [a]
as = do
  Integer
r <- (Integer, Integer) -> m Integer
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(Has (State GameState) sig m, UniformRange a) =>
(a, a) -> m a
uniform (Integer
0, Integer
total Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1)
  Maybe a -> m (Maybe a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> m (Maybe a)) -> Maybe a -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ Integer -> [a] -> Maybe a
go Integer
r [a]
as
 where
  total :: Integer
total = [Integer] -> Integer
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((a -> Integer) -> [a] -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map a -> Integer
weight [a]
as)

  go :: Integer -> [a] -> Maybe a
go Integer
_ [] = Maybe a
forall a. Maybe a
Nothing
  go !Integer
k (a
x : [a]
xs)
    | Integer
k Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
w = a -> Maybe a
forall a. a -> Maybe a
Just a
x
    | Bool
otherwise = Integer -> [a] -> Maybe a
go (Integer
k Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
w) [a]
xs
   where
    w :: Integer
w = a -> Integer
weight a
x

-- | Generate a random robot name in the form @adjective_name@.
randomName :: Has (State GameState) sig m => m Text
randomName :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
m EntityName
randomName = do
  NameGenerator Array Int EntityName
adjs Array Int EntityName
names <- Getting NameGenerator GameState NameGenerator -> m NameGenerator
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use (Getting NameGenerator GameState NameGenerator -> m NameGenerator)
-> Getting NameGenerator GameState NameGenerator -> m NameGenerator
forall a b. (a -> b) -> a -> b
$ (Robots -> Const NameGenerator Robots)
-> GameState -> Const NameGenerator GameState
Lens' GameState Robots
robotInfo ((Robots -> Const NameGenerator Robots)
 -> GameState -> Const NameGenerator GameState)
-> ((NameGenerator -> Const NameGenerator NameGenerator)
    -> Robots -> Const NameGenerator Robots)
-> Getting NameGenerator GameState NameGenerator
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RobotNaming -> Const NameGenerator RobotNaming)
-> Robots -> Const NameGenerator Robots
Lens' Robots RobotNaming
robotNaming ((RobotNaming -> Const NameGenerator RobotNaming)
 -> Robots -> Const NameGenerator Robots)
-> ((NameGenerator -> Const NameGenerator NameGenerator)
    -> RobotNaming -> Const NameGenerator RobotNaming)
-> (NameGenerator -> Const NameGenerator NameGenerator)
-> Robots
-> Const NameGenerator Robots
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NameGenerator -> Const NameGenerator NameGenerator)
-> RobotNaming -> Const NameGenerator RobotNaming
Getter RobotNaming NameGenerator
nameGenerator
  Int
i <- (Int, Int) -> m Int
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(Has (State GameState) sig m, UniformRange a) =>
(a, a) -> m a
uniform (Array Int EntityName -> (Int, Int)
forall i e. Array i e -> (i, i)
bounds Array Int EntityName
adjs)
  Int
j <- (Int, Int) -> m Int
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(Has (State GameState) sig m, UniformRange a) =>
(a, a) -> m a
uniform (Array Int EntityName -> (Int, Int)
forall i e. Array i e -> (i, i)
bounds Array Int EntityName
names)
  EntityName -> m EntityName
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (EntityName -> m EntityName) -> EntityName -> m EntityName
forall a b. (a -> b) -> a -> b
$ [EntityName] -> EntityName
T.concat [Array Int EntityName
adjs Array Int EntityName -> Int -> EntityName
forall i e. Ix i => Array i e -> i -> e
! Int
i, EntityName
"_", Array Int EntityName
names Array Int EntityName -> Int -> EntityName
forall i e. Ix i => Array i e -> i -> e
! Int
j]

-- * Moving

-- | Raw check whether moving to the given location causes any kind of
--   failure, with no special checks for system robots (see also
--   'checkMoveFailure').
checkMoveFailureUnprivileged ::
  HasRobotStepState sig m =>
  Cosmic Location ->
  m (Maybe MoveFailureMode)
checkMoveFailureUnprivileged :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Cosmic Location -> m (Maybe MoveFailureMode)
checkMoveFailureUnprivileged Cosmic Location
nextLoc = do
  Maybe Entity
me <- Cosmic Location -> m (Maybe Entity)
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
Cosmic Location -> m (Maybe Entity)
entityAt Cosmic Location
nextLoc
  WalkabilityContext
wc <- Getting WalkabilityContext Robot WalkabilityContext
-> m WalkabilityContext
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getting WalkabilityContext Robot WalkabilityContext
Getter Robot WalkabilityContext
walkabilityContext
  Maybe MoveFailureMode -> m (Maybe MoveFailureMode)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe MoveFailureMode -> m (Maybe MoveFailureMode))
-> Maybe MoveFailureMode -> m (Maybe MoveFailureMode)
forall a b. (a -> b) -> a -> b
$ WalkabilityContext -> Maybe Entity -> Maybe MoveFailureMode
checkUnwalkable WalkabilityContext
wc Maybe Entity
me

-- | Check whether moving to the given location causes any kind of
--   failure.  Note that system robots have unrestricted movement and
--   never fail, but non-system robots have restricted movement even
--   in creative mode.
checkMoveFailure :: HasRobotStepState sig m => Cosmic Location -> m (Maybe MoveFailureMode)
checkMoveFailure :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Cosmic Location -> m (Maybe MoveFailureMode)
checkMoveFailure Cosmic Location
nextLoc = do
  Bool
systemRob <- 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
  MaybeT m MoveFailureMode -> m (Maybe MoveFailureMode)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT m MoveFailureMode -> m (Maybe MoveFailureMode))
-> MaybeT m MoveFailureMode -> m (Maybe MoveFailureMode)
forall a b. (a -> b) -> a -> b
$ do
    Bool -> MaybeT m ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> MaybeT m ()) -> Bool -> MaybeT m ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not Bool
systemRob
    Maybe MoveFailureMode
maybeMoveFailure <- m (Maybe MoveFailureMode) -> MaybeT m (Maybe MoveFailureMode)
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Maybe MoveFailureMode) -> MaybeT m (Maybe MoveFailureMode))
-> m (Maybe MoveFailureMode) -> MaybeT m (Maybe MoveFailureMode)
forall a b. (a -> b) -> a -> b
$ Cosmic Location -> m (Maybe MoveFailureMode)
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Cosmic Location -> m (Maybe MoveFailureMode)
checkMoveFailureUnprivileged Cosmic Location
nextLoc
    Maybe MoveFailureMode -> MaybeT m MoveFailureMode
forall (m :: * -> *) b. Applicative m => Maybe b -> MaybeT m b
hoistMaybe Maybe MoveFailureMode
maybeMoveFailure