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

-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Facilities for stepping the robot CESK machines, /i.e./ the actual
-- interpreter for the Swarm language.
--
-- ** Note on the IO:
--
-- The only reason we need @IO@ is so that robots can run programs
-- loaded from files, via the 'Swarm.Language.Syntax.Run' command.
-- This could be avoided by using a hypothetical @import@ command instead and parsing
-- the required files at the time of declaration.
-- See <https://github.com/swarm-game/swarm/issues/495>.
module Swarm.Game.Step where

import Control.Applicative (Applicative (..))
import Control.Arrow ((&&&))
import Control.Carrier.Error.Either (ErrorC, runError)
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 (foldM, forM, forM_, guard, msum, unless, when, zipWithM)
import Data.Bifunctor (second)
import Data.Bool (bool)
import Data.Char (chr, ord)
import Data.Either (partitionEithers, rights)
import Data.Foldable (asum, for_, traverse_)
import Data.Foldable.Extra (findM, firstJustM)
import Data.Function (on)
import Data.Functor (void)
import Data.Int (Int32)
import Data.IntMap qualified as IM
import Data.IntSet qualified as IS
import Data.List (find, sortOn)
import Data.List qualified as L
import Data.List.NonEmpty qualified as NE
import Data.Map qualified as M
import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, listToMaybe, mapMaybe)
import Data.Ord (Down (Down))
import Data.Sequence ((><))
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 (V2 (..), perp, zero)
import Prettyprinter (pretty)
import Swarm.Game.Achievement.Attainment
import Swarm.Game.Achievement.Definitions
import Swarm.Game.CESK
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.Failure
import Swarm.Game.Location
import Swarm.Game.Recipe
import Swarm.Game.ResourceLoading (getDataFileNameSafe)
import Swarm.Game.Robot
import Swarm.Game.Scenario.Objective qualified as OB
import Swarm.Game.Scenario.Objective.WinCheck qualified as WC
import Swarm.Game.Scenario.Topography.Navigation.Portal (Navigation (..), destination, reorientation)
import Swarm.Game.Scenario.Topography.Navigation.Util
import Swarm.Game.Scenario.Topography.Navigation.Waypoint (WaypointName (..))
import Swarm.Game.State
import Swarm.Game.Step.Combustion qualified as Combustion
import Swarm.Game.Step.Pathfinding
import Swarm.Game.Step.Util
import Swarm.Game.Universe
import Swarm.Game.Value
import Swarm.Game.World qualified as W
import Swarm.Language.Capability
import Swarm.Language.Context hiding (delete)
import Swarm.Language.Key (parseKeyComboFull)
import Swarm.Language.Parse (runParser)
import Swarm.Language.Pipeline
import Swarm.Language.Pipeline.QQ (tmQ)
import Swarm.Language.Pretty (BulletList (BulletList, bulletListItems), prettyText)
import Swarm.Language.Requirement qualified as R
import Swarm.Language.Syntax
import Swarm.Language.Text.Markdown qualified as Markdown
import Swarm.Language.Typed (Typed (..))
import Swarm.Language.Value
import Swarm.Log
import Swarm.Util hiding (both)
import Swarm.Util.Effect (throwToMaybe)
import Swarm.Util.WindowedCounter qualified as WC
import System.Clock (TimeSpec)
import Witch (From (from), into)
import Prelude hiding (Applicative (..), lookup)

-- | The main function to do one game tick.
--
--   Note that the game may be in 'RobotStep' mode and not finish
--   the tick. Use the return value to check whether a full tick happened.
gameTick :: (Has (State GameState) sig m, Has (Lift IO) sig m) => m Bool
gameTick :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (Lift IO) sig m) =>
m Bool
gameTick = do
  forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
m ()
wakeUpRobotsDoneSleeping
  IntSet
active <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter GameState IntSet
activeRobots
  RID
focusedRob <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter GameState RID
focusedRobotID

  Bool
ticked <-
    forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use (Lens' GameState TemporalState
temporal forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' TemporalState Step
gameStep) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Step
WorldTick -> do
        forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (Lift IO) sig m) =>
IntSet -> m ()
runRobotIDs IntSet
active
        Lens' GameState TemporalState
temporal forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' TemporalState TickNumber
ticks forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= RID -> TickNumber -> TickNumber
addTicks RID
1
        forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
      RobotStep SingleStep
ss -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (Lift IO) sig m) =>
SingleStep -> RID -> IntSet -> m Bool
singleStep SingleStep
ss RID
focusedRob IntSet
active

  -- See if the base is finished with a computation, and if so, record
  -- the result in the game state so it can be displayed by the REPL;
  -- also save the current store into the robotContext so we can
  -- restore it the next time we start a computation.
  Maybe Robot
mr <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use (Lens' GameState (IntMap Robot)
robotMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at RID
0)
  case Maybe Robot
mr of
    Just Robot
r -> do
      REPLStatus
res <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use forall a b. (a -> b) -> a -> b
$ Lens' GameState GameControls
gameControls forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' GameControls REPLStatus
replStatus
      case REPLStatus
res of
        REPLWorking (Typed Maybe Value
Nothing Polytype
ty Requirements
req) -> case Robot -> Maybe (Value, Store)
getResult Robot
r of
          Just (Value
v, Store
s) -> do
            Lens' GameState GameControls
gameControls forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' GameControls REPLStatus
replStatus forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= Typed (Maybe Value) -> REPLStatus
REPLWorking (forall v. v -> Polytype -> Requirements -> Typed v
Typed (forall a. a -> Maybe a
Just Value
v) Polytype
ty Requirements
req)
            Traversal' GameState Robot
baseRobot forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Robot RobotContext
robotContext forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' RobotContext Store
defStore forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= Store
s
          Maybe (Value, Store)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        REPLStatus
_otherREPLStatus -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Maybe Robot
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  -- Possibly update the view center.
  forall s (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
(s -> s) -> m ()
modify GameState -> GameState
recalcViewCenter

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ticked forall a b. (a -> b) -> a -> b
$ do
    -- On new tick see if the winning condition for the current objective is met.
    WinCondition
wc <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' GameState WinCondition
winCondition
    case WinCondition
wc of
      WinConditions WinStatus
winState ObjectiveCompletion
oc -> do
        GameState
g <- forall s (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
m s
get @GameState
        EntityMap
em <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use forall a b. (a -> b) -> a -> b
$ Lens' GameState Landscape
landscape forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Landscape EntityMap
entityMap
        forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (Lift IO) sig m) =>
EntityMap -> GameState -> WinStatus -> ObjectiveCompletion -> m ()
hypotheticalWinCheck EntityMap
em GameState
g WinStatus
winState ObjectiveCompletion
oc
      WinCondition
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  forall (m :: * -> *) a. Monad m => a -> m a
return Bool
ticked

-- | Finish a game tick in progress and set the game to 'WorldTick' mode afterwards.
--
-- Use this function if you need to unpause the game.
finishGameTick :: (Has (State GameState) sig m, Has (Lift IO) sig m) => m ()
finishGameTick :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (Lift IO) sig m) =>
m ()
finishGameTick =
  forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use (Lens' GameState TemporalState
temporal forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' TemporalState Step
gameStep) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Step
WorldTick -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    RobotStep SingleStep
SBefore -> Lens' GameState TemporalState
temporal forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' TemporalState Step
gameStep forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= Step
WorldTick
    RobotStep SingleStep
_ -> forall (f :: * -> *) a. Functor f => f a -> f ()
void forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (Lift IO) sig m) =>
m Bool
gameTick forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (Lift IO) sig m) =>
m ()
finishGameTick

-- Insert the robot back to robot map.
-- Will selfdestruct or put the robot to sleep if it has that set.
insertBackRobot :: Has (State GameState) sig m => RID -> Robot -> m ()
insertBackRobot :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
RID -> Robot -> m ()
insertBackRobot RID
rn Robot
rob = do
  TickNumber
time <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use forall a b. (a -> b) -> a -> b
$ Lens' GameState TemporalState
temporal forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' TemporalState TickNumber
ticks
  if Robot
rob forall s a. s -> Getting a s a -> a
^. Lens' Robot Bool
selfDestruct
    then forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
RID -> m ()
deleteRobot RID
rn
    else do
      Lens' GameState (IntMap Robot)
robotMap forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= forall a. RID -> a -> IntMap a -> IntMap a
IM.insert RID
rn Robot
rob
      case Robot -> Maybe TickNumber
waitingUntil Robot
rob of
        Just TickNumber
wakeUpTime
          -- if w=2 t=1 then we do not needlessly put robot to waiting queue
          | TickNumber
wakeUpTime forall a. Ord a => a -> a -> Bool
<= RID -> TickNumber -> TickNumber
addTicks RID
2 TickNumber
time -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
          | Bool
otherwise -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
RID -> TickNumber -> m ()
sleepUntil RID
rn TickNumber
wakeUpTime
        Maybe TickNumber
Nothing ->
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Robot -> Bool
isActive Robot
rob) (forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
RID -> m ()
sleepForever RID
rn)

-- Run a set of robots - this is used to run robots before/after the focused one.
runRobotIDs :: (Has (State GameState) sig m, Has (Lift IO) sig m) => IS.IntSet -> m ()
runRobotIDs :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (Lift IO) sig m) =>
IntSet -> m ()
runRobotIDs IntSet
robotNames = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (IntSet -> [RID]
IS.toList IntSet
robotNames) forall a b. (a -> b) -> a -> b
$ \RID
rn -> do
  Maybe Robot
mr <- forall s a b (f :: * -> *) (sig :: (* -> *) -> * -> *).
Has (State s) sig f =>
Getting a s a -> (a -> b) -> f b
uses Lens' GameState (IntMap Robot)
robotMap (forall a. RID -> IntMap a -> Maybe a
IM.lookup RID
rn)
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Robot
mr (forall {sig :: (* -> *) -> * -> *} {m :: * -> *}.
(Algebra sig m, Member (State GameState) sig,
 Member (Lift IO) sig) =>
RID -> Robot -> m ()
stepOneRobot RID
rn)
 where
  stepOneRobot :: RID -> Robot -> m ()
stepOneRobot RID
rn Robot
rob = forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (Lift IO) sig m) =>
Robot -> m Robot
tickRobot Robot
rob forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
RID -> Robot -> m ()
insertBackRobot RID
rn

-- This is a helper function to do one robot step or run robots before/after.
singleStep :: (Has (State GameState) sig m, Has (Lift IO) sig m) => SingleStep -> RID -> IS.IntSet -> m Bool
singleStep :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (Lift IO) sig m) =>
SingleStep -> RID -> IntSet -> m Bool
singleStep SingleStep
ss RID
focRID IntSet
robotSet = do
  let (IntSet
preFoc, Bool
focusedActive, IntSet
postFoc) = RID -> IntSet -> (IntSet, Bool, IntSet)
IS.splitMember RID
focRID IntSet
robotSet
  case SingleStep
ss of
    ----------------------------------------------------------------------------
    -- run robots from the beginning until focused robot
    SingleStep
SBefore -> do
      forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (Lift IO) sig m) =>
IntSet -> m ()
runRobotIDs IntSet
preFoc
      Lens' GameState TemporalState
temporal forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' TemporalState Step
gameStep forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= SingleStep -> Step
RobotStep (RID -> SingleStep
SSingle RID
focRID)
      -- also set ticks of focused robot
      RID
steps <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use forall a b. (a -> b) -> a -> b
$ Lens' GameState TemporalState
temporal forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' TemporalState RID
robotStepsPerTick
      Lens' GameState (IntMap Robot)
robotMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix RID
focRID forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Robot ActivityCounts
activityCounts forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' ActivityCounts RID
tickStepBudget forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= RID
steps
      -- continue to focused robot if there were no previous robots
      -- DO NOT SKIP THE ROBOT SETUP above
      if IntSet -> Bool
IS.null IntSet
preFoc
        then forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (Lift IO) sig m) =>
SingleStep -> RID -> IntSet -> m Bool
singleStep (RID -> SingleStep
SSingle RID
focRID) RID
focRID IntSet
robotSet
        else forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    ----------------------------------------------------------------------------
    -- run single step of the focused robot (may skip if inactive)
    SSingle RID
rid | Bool -> Bool
not Bool
focusedActive -> do
      forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (Lift IO) sig m) =>
SingleStep -> RID -> IntSet -> m Bool
singleStep (RID -> SingleStep
SAfter RID
rid) RID
rid IntSet
postFoc -- skip inactive focused robot
    SSingle RID
rid -> do
      Maybe Robot
mOldR <- forall s a b (f :: * -> *) (sig :: (* -> *) -> * -> *).
Has (State s) sig f =>
Getting a s a -> (a -> b) -> f b
uses Lens' GameState (IntMap Robot)
robotMap (forall a. RID -> IntMap a -> Maybe a
IM.lookup RID
focRID)
      case Maybe Robot
mOldR of
        Maybe Robot
Nothing | RID
rid forall a. Eq a => a -> a -> Bool
== RID
focRID -> do
          forall {sig :: (* -> *) -> * -> *} {m :: * -> *}.
(Algebra sig m, Member (State GameState) sig) =>
Text -> m ()
debugLog Text
"The debugged robot does not exist! Exiting single step mode."
          forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (Lift IO) sig m) =>
IntSet -> m ()
runRobotIDs IntSet
postFoc
          Lens' GameState TemporalState
temporal forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' TemporalState Step
gameStep forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= Step
WorldTick
          Lens' GameState TemporalState
temporal forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' TemporalState TickNumber
ticks forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= RID -> TickNumber -> TickNumber
addTicks RID
1
          forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        Maybe Robot
Nothing | Bool
otherwise -> do
          forall {sig :: (* -> *) -> * -> *} {m :: * -> *}.
(Algebra sig m, Member (State GameState) sig) =>
Text -> m ()
debugLog Text
"The previously debugged robot does not exist!"
          forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (Lift IO) sig m) =>
SingleStep -> RID -> IntSet -> m Bool
singleStep SingleStep
SBefore RID
focRID IntSet
postFoc
        Just Robot
oldR -> do
          -- if focus changed we need to finish the previous robot
          Robot
newR <- (if RID
rid forall a. Eq a => a -> a -> Bool
== RID
focRID then forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (Lift IO) sig m) =>
Robot -> m Robot
stepRobot else forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (Lift IO) sig m) =>
Robot -> m Robot
tickRobotRec) Robot
oldR
          forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
RID -> Robot -> m ()
insertBackRobot RID
focRID Robot
newR
          if RID
rid forall a. Eq a => a -> a -> Bool
== RID
focRID
            then do
              forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Robot
newR forall s a. s -> Getting a s a -> a
^. Lens' Robot ActivityCounts
activityCounts forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' ActivityCounts RID
tickStepBudget forall a. Eq a => a -> a -> Bool
== RID
0) forall a b. (a -> b) -> a -> b
$
                Lens' GameState TemporalState
temporal forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' TemporalState Step
gameStep forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= SingleStep -> Step
RobotStep (RID -> SingleStep
SAfter RID
focRID)
              forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
            else do
              -- continue to newly focused
              forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (Lift IO) sig m) =>
SingleStep -> RID -> IntSet -> m Bool
singleStep SingleStep
SBefore RID
focRID IntSet
postFoc
    ----------------------------------------------------------------------------
    -- run robots after the focused robot
    SAfter RID
rid | RID
focRID forall a. Ord a => a -> a -> Bool
<= RID
rid -> do
      -- This state takes care of two possibilities:
      -- 1. normal - rid == focRID and we finish the tick
      -- 2. changed focus and the newly focused robot has previously run
      --    so we just finish the tick the same way
      forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (Lift IO) sig m) =>
IntSet -> m ()
runRobotIDs IntSet
postFoc
      Lens' GameState TemporalState
temporal forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' TemporalState Step
gameStep forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= SingleStep -> Step
RobotStep SingleStep
SBefore
      Lens' GameState TemporalState
temporal forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' TemporalState TickNumber
ticks forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= RID -> TickNumber -> TickNumber
addTicks RID
1
      forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    SAfter RID
rid | Bool
otherwise -> do
      -- go to single step if new robot is focused
      let (IntSet
_pre, IntSet
postRID) = RID -> IntSet -> (IntSet, IntSet)
IS.split RID
rid IntSet
robotSet
      forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (Lift IO) sig m) =>
SingleStep -> RID -> IntSet -> m Bool
singleStep SingleStep
SBefore RID
focRID IntSet
postRID
 where
  h :: Robot
h = CESK -> TimeSpec -> Robot
hypotheticalRobot (Value -> Store -> Cont -> CESK
Out Value
VUnit Store
emptyStore []) TimeSpec
0
  debugLog :: Text -> m ()
debugLog Text
txt = do
    LogEntry
m <- forall s (m :: * -> *) a. Functor m => s -> StateC s m a -> m a
evalState @Robot Robot
h forall a b. (a -> b) -> a -> b
$ forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m) =>
RobotLogSource -> Severity -> Text -> m LogEntry
createLogEntry RobotLogSource
RobotError Severity
Debug Text
txt
    forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
LogEntry -> m ()
emitMessage LogEntry
m

-- | An accumulator for folding over the incomplete
-- objectives to evaluate for their completion
data CompletionsWithExceptions = CompletionsWithExceptions
  { CompletionsWithExceptions -> [Text]
exceptions :: [Text]
  , CompletionsWithExceptions -> ObjectiveCompletion
completions :: ObjectiveCompletion
  , CompletionsWithExceptions -> [Objective]
completionAnnouncementQueue :: [OB.Objective]
  -- ^ Upon completion, an objective is enqueued.
  -- It is dequeued when displayed on the UI.
  }

-- | Execute the win condition check *hypothetically*: i.e. in a
-- fresh CESK machine, using a copy of the current game state.
--
-- The win check is performed only on "active" goals; that is,
-- the goals that are currently unmet and have had all of their
-- prerequisites satisfied.
-- Note that it may be possible, while traversing through the
-- goal list, for one goal to be met earlier in the list that
-- happens to be a prerequisite later in the traversal. This
-- is why:
-- 1) We must not pre-filter the goals to be traversed based
--    on satisfied prerequisites (i.e. we cannot use the
--    "getActiveObjectives" function).
-- 2) The traversal order must be "reverse topological" order, so
--    that prerequisites are evaluated before dependent goals.
-- 3) The iteration needs to be a "fold", so that state is updated
--    after each element.
hypotheticalWinCheck ::
  (Has (State GameState) sig m, Has (Lift IO) sig m) =>
  EntityMap ->
  GameState ->
  WinStatus ->
  ObjectiveCompletion ->
  m ()
hypotheticalWinCheck :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (Lift IO) sig m) =>
EntityMap -> GameState -> WinStatus -> ObjectiveCompletion -> m ()
hypotheticalWinCheck EntityMap
em GameState
g WinStatus
ws ObjectiveCompletion
oc = do
  -- We can fully and accurately evaluate the new state of the objectives DAG
  -- in a single pass, so long as we visit it in reverse topological order.
  --
  -- N.B. The "reverse" is essential due to the re-population of the
  -- "incomplete" goal list by cons-ing.
  CompletionsWithExceptions
finalAccumulator <-
    forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM forall {m :: * -> *} {sig :: (* -> *) -> * -> *}.
(Member (Lift IO) sig, Algebra sig m) =>
CompletionsWithExceptions
-> Objective -> m CompletionsWithExceptions
foldFunc CompletionsWithExceptions
initialAccumulator forall a b. (a -> b) -> a -> b
$
      forall a. [a] -> [a]
reverse [Objective]
incompleteGoals

  let newWinState :: WinStatus
newWinState = case WinStatus
ws of
        WinStatus
Ongoing -> ObjectiveCompletion -> WinStatus
getNextWinState forall a b. (a -> b) -> a -> b
$ CompletionsWithExceptions -> ObjectiveCompletion
completions CompletionsWithExceptions
finalAccumulator
        WinStatus
_ -> WinStatus
ws

  Lens' GameState WinCondition
winCondition forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= WinStatus -> ObjectiveCompletion -> WinCondition
WinConditions WinStatus
newWinState (CompletionsWithExceptions -> ObjectiveCompletion
completions CompletionsWithExceptions
finalAccumulator)

  case WinStatus
newWinState of
    Unwinnable Bool
_ -> do
      forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (Lift IO) sig m) =>
GameplayAchievement -> m ()
grantAchievement GameplayAchievement
LoseScenario
    WinStatus
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

  Lens' GameState Messages
messageInfo forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Messages (Seq Announcement)
announcementQueue forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= (forall a. Seq a -> Seq a -> Seq a
>< forall a. [a] -> Seq a
Seq.fromList (forall a b. (a -> b) -> [a] -> [b]
map Objective -> Announcement
ObjectiveCompleted forall a b. (a -> b) -> a -> b
$ CompletionsWithExceptions -> [Objective]
completionAnnouncementQueue CompletionsWithExceptions
finalAccumulator))

  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall {sig :: (* -> *) -> * -> *} {m :: * -> *}.
(Algebra sig m, Member (State GameState) sig) =>
Text -> m ()
handleException forall a b. (a -> b) -> a -> b
$ CompletionsWithExceptions -> [Text]
exceptions CompletionsWithExceptions
finalAccumulator
 where
  getNextWinState :: ObjectiveCompletion -> WinStatus
getNextWinState ObjectiveCompletion
completedObjs
    | ObjectiveCompletion -> Bool
WC.didWin ObjectiveCompletion
completedObjs = Bool -> WinStatus
Won Bool
False
    | ObjectiveCompletion -> Bool
WC.didLose ObjectiveCompletion
completedObjs = Bool -> WinStatus
Unwinnable Bool
False
    | Bool
otherwise = WinStatus
Ongoing

  (ObjectiveCompletion
withoutIncomplete, [Objective]
incompleteGoals) = ObjectiveCompletion -> (ObjectiveCompletion, [Objective])
OB.extractIncomplete ObjectiveCompletion
oc
  initialAccumulator :: CompletionsWithExceptions
initialAccumulator = [Text]
-> ObjectiveCompletion -> [Objective] -> CompletionsWithExceptions
CompletionsWithExceptions [] ObjectiveCompletion
withoutIncomplete []

  -- All of the "incomplete" goals have been emptied from the initial accumulator, and
  -- these are what we iterate over with the fold.
  -- Each iteration, we either place the goal back into the "incomplete" bucket, or
  -- we determine that it has been met or impossible and place it into the "completed"
  -- or "unwinnable" bucket, respectively.
  foldFunc :: CompletionsWithExceptions
-> Objective -> m CompletionsWithExceptions
foldFunc (CompletionsWithExceptions [Text]
exnTexts ObjectiveCompletion
currentCompletions [Objective]
announcements) Objective
obj = do
    Either Exn Value
v <-
      if ObjectiveCompletion -> Objective -> Bool
WC.isPrereqsSatisfied ObjectiveCompletion
currentCompletions Objective
obj
        then forall e (m :: * -> *) a. ThrowC e m a -> m (Either e a)
runThrow @Exn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. Functor m => s -> StateC s m a -> m a
evalState @GameState GameState
g forall a b. (a -> b) -> a -> b
$ forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Lift IO) sig m, Has (Throw Exn) sig m,
 Has (State GameState) sig m) =>
ProcessedTerm -> m Value
evalPT forall a b. (a -> b) -> a -> b
$ Objective
obj forall s a. s -> Getting a s a -> a
^. Lens' Objective ProcessedTerm
OB.objectiveCondition
        else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Bool -> Value
VBool Bool
False
    let simplified :: Either Text Bool
simplified = Either Exn Value -> Either Text Bool
simplifyResult forall a b. (a -> b) -> a -> b
$ Value -> Value
stripVResult forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Exn Value
v
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Either Text Bool
simplified of
      Left Text
exnText ->
        [Text]
-> ObjectiveCompletion -> [Objective] -> CompletionsWithExceptions
CompletionsWithExceptions
          (Text
exnText forall a. a -> [a] -> [a]
: [Text]
exnTexts)
          -- Push back the incomplete goal that had been popped for inspection
          (Objective -> ObjectiveCompletion -> ObjectiveCompletion
OB.addIncomplete Objective
obj ObjectiveCompletion
currentCompletions)
          [Objective]
announcements
      Right Bool
boolResult ->
        [Text]
-> ObjectiveCompletion -> [Objective] -> CompletionsWithExceptions
CompletionsWithExceptions
          [Text]
exnTexts
          -- Either restore the goal to the incomplete list from which it was popped
          -- or move it to the complete (or unwinnable) bucket.
          (Objective -> ObjectiveCompletion -> ObjectiveCompletion
modifyCompletions Objective
obj ObjectiveCompletion
currentCompletions)
          ([Objective] -> [Objective]
modifyAnnouncements [Objective]
announcements)
       where
        (Objective -> ObjectiveCompletion -> ObjectiveCompletion
modifyCompletions, [Objective] -> [Objective]
modifyAnnouncements)
          | Bool
boolResult = (Objective -> ObjectiveCompletion -> ObjectiveCompletion
OB.addCompleted, (Objective
obj forall a. a -> [a] -> [a]
:))
          | ObjectiveCompletion -> Objective -> Bool
WC.isUnwinnable ObjectiveCompletion
currentCompletions Objective
obj = (Objective -> ObjectiveCompletion -> ObjectiveCompletion
OB.addUnwinnable, forall a. a -> a
id)
          | Bool
otherwise = (Objective -> ObjectiveCompletion -> ObjectiveCompletion
OB.addIncomplete, forall a. a -> a
id)

  simplifyResult :: Either Exn Value -> Either Text Bool
simplifyResult = \case
    Left Exn
exn -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ EntityMap -> Exn -> Text
formatExn EntityMap
em Exn
exn
    Right (VBool Bool
x) -> forall a b. b -> Either a b
Right Bool
x
    Right Value
val ->
      forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
        [Text] -> Text
T.unwords
          [ Text
"Non boolean value:"
          , Value -> Text
prettyValue Value
val
          , Text
"real:"
          , String -> Text
T.pack (forall a. Show a => a -> String
show Value
val)
          ]

  -- Log exceptions in the message queue so we can check for them in tests
  handleException :: Text -> m ()
handleException Text
exnText = do
    LogEntry
m <- forall s (m :: * -> *) a. Functor m => s -> StateC s m a -> m a
evalState @Robot Robot
h forall a b. (a -> b) -> a -> b
$ forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m) =>
RobotLogSource -> Severity -> Text -> m LogEntry
createLogEntry RobotLogSource
RobotError Severity
Critical Text
exnText
    forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
LogEntry -> m ()
emitMessage LogEntry
m
   where
    h :: Robot
h = CESK -> TimeSpec -> Robot
hypotheticalRobot (Value -> Store -> Cont -> CESK
Out Value
VUnit Store
emptyStore []) TimeSpec
0

evalPT ::
  (Has (Lift IO) sig m, Has (Throw Exn) sig m, Has (State GameState) sig m) =>
  ProcessedTerm ->
  m Value
evalPT :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Lift IO) sig m, Has (Throw Exn) sig m,
 Has (State GameState) sig m) =>
ProcessedTerm -> m Value
evalPT ProcessedTerm
t = forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Lift IO) sig m, Has (Throw Exn) sig m,
 Has (State GameState) sig m) =>
CESK -> m Value
evaluateCESK (ProcessedTerm -> Env -> Store -> CESK
initMachine ProcessedTerm
t forall t. Ctx t
empty Store
emptyStore)

-- | Create a special robot to check some hypothetical, for example the win condition.
--
-- Use ID (-1) so it won't conflict with any robots currently in the robot map.
hypotheticalRobot :: CESK -> TimeSpec -> Robot
hypotheticalRobot :: CESK -> TimeSpec -> Robot
hypotheticalRobot CESK
c =
  forall (phase :: RobotPhase).
RobotID phase
-> Maybe RID
-> Text
-> Document Syntax
-> RobotLocation phase
-> Heading
-> Display
-> CESK
-> [Entity]
-> [(RID, Entity)]
-> Bool
-> Bool
-> Set Text
-> TimeSpec
-> RobotR phase
mkRobot
    (-RID
1)
    forall a. Maybe a
Nothing
    Text
"hypothesis"
    forall a. Monoid a => a
mempty
    Cosmic Location
defaultCosmicLocation
    forall (f :: * -> *) a. (Additive f, Num a) => f a
zero
    Display
defaultRobotDisplay
    CESK
c
    []
    []
    Bool
True
    Bool
False
    forall a. Monoid a => a
mempty

evaluateCESK ::
  (Has (Lift IO) sig m, Has (Throw Exn) sig m, Has (State GameState) sig m) =>
  CESK ->
  m Value
evaluateCESK :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Lift IO) sig m, Has (Throw Exn) sig m,
 Has (State GameState) sig m) =>
CESK -> m Value
evaluateCESK CESK
cesk = do
  TimeSpec
createdAt <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Lift IO) sig m =>
m TimeSpec
getNow
  let r :: Robot
r = CESK -> TimeSpec -> Robot
hypotheticalRobot CESK
cesk TimeSpec
createdAt
  forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
Robot -> m ()
addRobot Robot
r -- Add the special robot to the robot map, so it can look itself up if needed
  forall s (m :: * -> *) a. Functor m => s -> StateC s m a -> m a
evalState Robot
r forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Lift IO) sig m, Has (Throw Exn) sig m,
 Has (State GameState) sig m, Has (State Robot) sig m) =>
CESK -> m Value
runCESK forall a b. (a -> b) -> a -> b
$ CESK
cesk

runCESK ::
  ( Has (Lift IO) sig m
  , Has (Throw Exn) sig m
  , Has (State GameState) sig m
  , Has (State Robot) sig m
  ) =>
  CESK ->
  m Value
runCESK :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Lift IO) sig m, Has (Throw Exn) sig m,
 Has (State GameState) sig m, Has (State Robot) sig m) =>
CESK -> m Value
runCESK (Up Exn
exn Store
_ []) = forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError Exn
exn
runCESK CESK
cesk = case CESK -> Maybe (Value, Store)
finalValue CESK
cesk of
  Just (Value
v, Store
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return Value
v
  Maybe (Value, Store)
Nothing -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m,
 Has (Lift IO) sig m) =>
CESK -> m CESK
stepCESK CESK
cesk forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Lift IO) sig m, Has (Throw Exn) sig m,
 Has (State GameState) sig m, Has (State Robot) sig m) =>
CESK -> m Value
runCESK

------------------------------------------------------------
-- 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
  RID
rid <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot RID
robotID
  Text
rn <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot Text
robotName
  TickNumber
time <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use forall a b. (a -> b) -> a -> b
$ Lens' GameState TemporalState
temporal forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' TemporalState TickNumber
ticks
  Cosmic Location
loc <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot (Cosmic Location)
robotLocation
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ TickNumber -> LogSource -> Severity -> Text -> Text -> LogEntry
LogEntry TickNumber
time (RobotLogSource -> RID -> Cosmic Location -> LogSource
RobotLog RobotLogSource
source RID
rid Cosmic Location
loc) Severity
sev Text
rn Text
msg

-- | 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 <- 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
  Lens' Robot (Seq LogEntry)
robotLog forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= (forall a. Seq a -> a -> Seq a
Seq.|> LogEntry
m)
  forall (m :: * -> *) a. Monad m => a -> m a
return LogEntry
m

-- | Print a showable value via the robot's log.
--
-- Useful for debugging.
traceLogShow :: (Has (State GameState) sig m, Has (State Robot) sig m, Show a) => a -> m ()
traceLogShow :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(Has (State GameState) sig m, Has (State Robot) sig m, Show a) =>
a -> m ()
traceLogShow = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m) =>
RobotLogSource -> Severity -> Text -> m LogEntry
traceLog RobotLogSource
Logged Severity
Info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall source target. From source target => source -> target
from forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show

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

-- | 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 forall s a. s -> Getting a s a -> a
^. Lens' Robot Bool
robotHeavy = forall a. a -> Maybe a
Just Capability
CMoveheavy
constCapsFor Const
Backup Robot
r
  | Robot
r forall s a. s -> Getting a s a -> a
^. Lens' Robot Bool
robotHeavy = forall a. a -> Maybe a
Just Capability
CMoveheavy
constCapsFor Const
Stride Robot
r
  | Robot
r forall s a. s -> Getting a s a -> a
^. Lens' Robot Bool
robotHeavy = forall a. a -> Maybe a
Just Capability
CMoveheavy
constCapsFor Const
c Robot
_ = Const -> Maybe Capability
constCaps Const
c

-- | 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).
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) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe Capability
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just Capability
cap -> do
      Bool
isPrivileged <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m) =>
m Bool
isPrivilegedBot
      Set Capability
robotCaps <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot (Set Capability)
robotCapabilities
      let hasCaps :: Bool
hasCaps = Capability
cap forall a. Ord a => a -> Set a -> Bool
`S.member` Set Capability
robotCaps
      (Bool
isPrivileged Bool -> Bool -> Bool
|| Bool
hasCaps)
        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) (forall ty. Const -> Term' ty
TConst Const
c)

-- | 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) forall a b. (a -> b) -> a -> b
$ 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 = 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 <- 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exn -> Store -> Cont -> CESK
Up Exn
exn Store
s Cont
k
    Right CESK
a -> forall (m :: * -> *) a. Monad m => a -> m a
return CESK
a

------------------------------------------------------------
-- Stepping robots
------------------------------------------------------------

-- | Run a robot for one tick, which may consist of up to
--   'robotStepsPerTick' CESK machine steps and at most one tangible
--   command execution, whichever comes first.
tickRobot :: (Has (State GameState) sig m, Has (Lift IO) sig m) => Robot -> m Robot
tickRobot :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (Lift IO) sig m) =>
Robot -> m Robot
tickRobot Robot
r = do
  RID
steps <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use forall a b. (a -> b) -> a -> b
$ Lens' GameState TemporalState
temporal forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' TemporalState RID
robotStepsPerTick
  forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (Lift IO) sig m) =>
Robot -> m Robot
tickRobotRec (Robot
r forall a b. a -> (a -> b) -> b
& Lens' Robot ActivityCounts
activityCounts forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' ActivityCounts RID
tickStepBudget forall s t a b. ASetter s t a b -> b -> s -> t
.~ RID
steps)

-- | Recursive helper function for 'tickRobot', which checks if the
--   robot is actively running and still has steps left, and if so
--   runs it for one step, then calls itself recursively to continue
--   stepping the robot.
tickRobotRec :: (Has (State GameState) sig m, Has (Lift IO) sig m) => Robot -> m Robot
tickRobotRec :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (Lift IO) sig m) =>
Robot -> m Robot
tickRobotRec Robot
r = do
  TickNumber
time <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use forall a b. (a -> b) -> a -> b
$ Lens' GameState TemporalState
temporal forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' TemporalState TickNumber
ticks
  case TickNumber -> Robot -> Bool
wantsToStep TickNumber
time Robot
r Bool -> Bool -> Bool
&& (Robot
r forall s a. s -> Getting a s a -> a
^. Lens' Robot Bool
runningAtomic Bool -> Bool -> Bool
|| Robot
r forall s a. s -> Getting a s a -> a
^. Lens' Robot ActivityCounts
activityCounts forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' ActivityCounts RID
tickStepBudget forall a. Ord a => a -> a -> Bool
> RID
0) of
    Bool
True -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (Lift IO) sig m) =>
Robot -> m Robot
stepRobot Robot
r forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (Lift IO) sig m) =>
Robot -> m Robot
tickRobotRec
    Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return Robot
r

-- | Single-step a robot by decrementing its 'tickStepBudget' counter and
--   running its CESK machine for one step.
stepRobot :: (Has (State GameState) sig m, Has (Lift IO) sig m) => Robot -> m Robot
stepRobot :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (Lift IO) sig m) =>
Robot -> m Robot
stepRobot Robot
r = do
  (Robot
r', CESK
cesk') <- forall s (m :: * -> *) a. s -> StateC s m a -> m (s, a)
runState (Robot
r forall a b. a -> (a -> b) -> b
& Lens' Robot ActivityCounts
activityCounts forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' ActivityCounts RID
tickStepBudget forall a s t. Num a => ASetter s t a a -> a -> s -> t
-~ RID
1) (forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m,
 Has (Lift IO) sig m) =>
CESK -> m CESK
stepCESK (Robot
r forall s a. s -> Getting a s a -> a
^. Lens' Robot CESK
machine))
  -- sendIO $ appendFile "out.txt" (prettyString cesk' ++ "\n")
  TickNumber
t <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use forall a b. (a -> b) -> a -> b
$ Lens' GameState TemporalState
temporal forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' TemporalState TickNumber
ticks

  Bool
isCreative <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' GameState Bool
creativeMode
  let shouldTrackActivity :: Bool
shouldTrackActivity = Bool
isCreative Bool -> Bool -> Bool
|| Bool -> Bool
not (Robot
r' forall s a. s -> Getting a s a -> a
^. Lens' Robot Bool
systemRobot)

  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
    forall a. Bool -> (a -> a) -> a -> a
applyWhen Bool
shouldTrackActivity (TickNumber -> Robot -> Robot
maintainActivityWindow TickNumber
t) forall a b. (a -> b) -> a -> b
$
      Robot
r'
        forall a b. a -> (a -> b) -> b
& Lens' Robot CESK
machine forall s t a b. ASetter s t a b -> b -> s -> t
.~ CESK
cesk'
        forall a b. a -> (a -> b) -> b
& Lens' Robot ActivityCounts
activityCounts forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' ActivityCounts RID
lifetimeStepCount forall a s t. Num a => ASetter s t a a -> a -> s -> t
+~ RID
1
 where
  maintainActivityWindow :: TickNumber -> Robot -> Robot
maintainActivityWindow TickNumber
t Robot
bot =
    Robot
bot forall a b. a -> (a -> b) -> b
& (Lens' Robot ActivityCounts
activityCounts forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' ActivityCounts (WindowedCounter TickNumber)
activityWindow forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a.
(Ord a, Offsettable a) =>
a -> WindowedCounter a -> WindowedCounter a
WC.insert TickNumber
t)

-- | replace some entity in the world with another entity
updateWorld ::
  (Has (State GameState) sig m, Has (Throw Exn) sig m) =>
  Const ->
  WorldUpdate Entity ->
  m ()
updateWorld :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (Throw Exn) sig m) =>
Const -> WorldUpdate Entity -> m ()
updateWorld Const
c (ReplaceEntity Cosmic Location
loc Entity
eThen Maybe Entity
down) = do
  MultiWorld RID Entity
w <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use forall a b. (a -> b) -> a -> b
$ Lens' GameState Landscape
landscape forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Landscape (MultiWorld RID Entity)
multiWorld
  let eNow :: Maybe Entity
eNow = forall t e. Cosmic Coords -> MultiWorld t e -> Maybe e
W.lookupCosmicEntity (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Location -> Coords
W.locToCoords Cosmic Location
loc) MultiWorld RID 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 forall a. a -> Maybe a
Just Entity
eThen forall a. Eq a => a -> a -> Bool
/= Maybe Entity
eNow
    then forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Const -> [Text] -> Exn
cmdExn Const
c [Text
"The", Entity
eThen forall s a. s -> Getting a s a -> a
^. Lens' Entity Text
entityName, Text
"is not there."]
    else forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
Cosmic Location -> (Maybe Entity -> Maybe Entity) -> m ()
updateEntityAt Cosmic Location
loc forall a b. (a -> b) -> a -> b
$ 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 =
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ \case
    AddEntity RID
c Entity
e -> Lens' Robot Inventory
robotInventory forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= RID -> Entity -> Inventory -> Inventory
E.insertCount RID
c Entity
e
    LearnEntity Entity
e -> Lens' Robot Inventory
robotInventory forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= RID -> Entity -> Inventory -> Inventory
E.insertCount RID
0 Entity
e

data SKpair = SKpair Store Cont

-- | Performs some side-effectful computation
-- for an "FImmediate" Frame.
-- Aborts processing the continuation stack
-- if an error is encountered.
--
-- Compare to "withExceptions".
processImmediateFrame ::
  (Has (State GameState) sig m, Has (State Robot) sig m, Has (Lift IO) sig m) =>
  Value ->
  SKpair ->
  -- | the unreliable computation
  ErrorC Exn m () ->
  m CESK
processImmediateFrame :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m,
 Has (Lift IO) sig m) =>
Value -> SKpair -> ErrorC Exn m () -> m CESK
processImmediateFrame Value
v (SKpair Store
s Cont
k) ErrorC Exn m ()
unreliableComputation = do
  Either Exn ()
wc <- forall exc (m :: * -> *) a. ErrorC exc m a -> m (Either exc a)
runError ErrorC Exn m ()
unreliableComputation
  case Either Exn ()
wc of
    Left Exn
exn -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exn -> Store -> Cont -> CESK
Up Exn
exn Store
s Cont
k
    Right () -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m,
 Has (Lift IO) sig m) =>
CESK -> m CESK
stepCESK forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
v Store
s Cont
k

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
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (Throw Exn) sig m) =>
Const -> WorldUpdate Entity -> m ()
updateWorld Const
cmd) [WorldUpdate Entity]
wf
  forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m) =>
[RobotUpdate] -> m ()
applyRobotUpdates [RobotUpdate]
rf
  forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
m ()
flagRedraw

-- | The main CESK machine workhorse.  Given a robot, look at its CESK
--   machine state and figure out a single next step.
stepCESK :: (Has (State GameState) sig m, Has (State Robot) sig m, Has (Lift IO) sig m) => CESK -> m CESK
stepCESK :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m,
 Has (Lift IO) sig m) =>
CESK -> m CESK
stepCESK CESK
cesk = case CESK
cesk of
  ------------------------------------------------------------
  -- Evaluation

  -- We wake up robots whose wake-up time has been reached. If it hasn't yet
  -- then stepCESK is a no-op.
  Waiting TickNumber
wakeupTime CESK
cesk' -> do
    TickNumber
time <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use forall a b. (a -> b) -> a -> b
$ Lens' GameState TemporalState
temporal forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' TemporalState TickNumber
ticks
    if TickNumber
wakeupTime forall a. Ord a => a -> a -> Bool
<= TickNumber
time
      then forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m,
 Has (Lift IO) sig m) =>
CESK -> m CESK
stepCESK CESK
cesk'
      else forall (m :: * -> *) a. Monad m => a -> m a
return CESK
cesk
  Out Value
v Store
s (FImmediate Const
cmd [WorldUpdate Entity]
wf [RobotUpdate]
rf : Cont
k) ->
    forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m,
 Has (Lift IO) sig m) =>
Value -> SKpair -> ErrorC Exn m () -> m CESK
processImmediateFrame Value
v (Store -> Cont -> SKpair
SKpair Store
s Cont
k) forall a b. (a -> b) -> a -> b
$
      forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Const -> [WorldUpdate Entity] -> [RobotUpdate] -> m ()
updateWorldAndRobots Const
cmd [WorldUpdate Entity]
wf [RobotUpdate]
rf
  -- Now some straightforward cases.  These all immediately turn
  -- into values.
  In Term
TUnit Env
_ Store
s Cont
k -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s Cont
k
  In (TDir Direction
d) Env
_ Store
s Cont
k -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Direction -> Value
VDir Direction
d) Store
s Cont
k
  In (TInt Integer
n) Env
_ Store
s Cont
k -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Integer -> Value
VInt Integer
n) Store
s Cont
k
  In (TText Text
str) Env
_ Store
s Cont
k -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Text -> Value
VText Text
str) Store
s Cont
k
  In (TBool Bool
b) Env
_ Store
s Cont
k -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Bool -> Value
VBool Bool
b) Store
s Cont
k
  -- There should not be any antiquoted variables left at this point.
  In (TAntiText Text
v) Env
_ Store
s Cont
k ->
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exn -> Store -> Cont -> CESK
Up (Text -> Exn
Fatal (Text -> Text -> Text
T.append Text
"Antiquoted variable found at runtime: $str:" Text
v)) Store
s Cont
k
  In (TAntiInt Text
v) Env
_ Store
s Cont
k ->
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exn -> Store -> Cont -> CESK
Up (Text -> Exn
Fatal (Text -> Text -> Text
T.append Text
"Antiquoted variable found at runtime: $int:" Text
v)) Store
s Cont
k
  -- Require and requireDevice just turn into no-ops.
  In (TRequireDevice {}) Env
e Store
s Cont
k -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Term -> Env -> Store -> Cont -> CESK
In (forall ty. Const -> Term' ty
TConst Const
Noop) Env
e Store
s Cont
k
  In (TRequire {}) Env
e Store
s Cont
k -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Term -> Env -> Store -> Cont -> CESK
In (forall ty. Const -> Term' ty
TConst Const
Noop) Env
e Store
s Cont
k
  In (TRequirements Text
x Term
t) Env
e Store
s Cont
k -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Text -> Term -> Env -> Value
VRequirements Text
x Term
t Env
e) Store
s Cont
k
  -- Type ascriptions are ignored
  In (TAnnotate Term
v Polytype
_) Env
e Store
s Cont
k -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Term -> Env -> Store -> Cont -> CESK
In Term
v Env
e Store
s Cont
k
  -- Normally it's not possible to have a TRobot value in surface
  -- syntax, but the salvage command generates a program that needs to
  -- refer directly to the salvaging robot.
  In (TRobot RID
rid) Env
_ Store
s Cont
k -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (RID -> Value
VRobot RID
rid) Store
s Cont
k
  -- Function constants of arity 0 are evaluated immediately
  -- (e.g. parent, self).  Any other constant is turned into a VCApp,
  -- which is waiting for arguments and/or an FExec frame.
  In (TConst Const
c) Env
_ Store
s Cont
k
    | Const -> RID
arity Const
c forall a. Eq a => a -> a -> Bool
== RID
0 Bool -> Bool -> Bool
&& Bool -> Bool
not (Const -> Bool
isCmd Const
c) -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m,
 Has (Lift IO) sig m) =>
Const -> [Value] -> Store -> Cont -> m CESK
evalConst Const
c [] Store
s Cont
k
    | Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Const -> [Value] -> Value
VCApp Const
c []) Store
s Cont
k
  -- To evaluate a variable, just look it up in the context.
  In (TVar Text
x) Env
e Store
s Cont
k -> forall (m :: * -> *).
Monad m =>
Store -> Cont -> ThrowC Exn m CESK -> m CESK
withExceptions Store
s Cont
k forall a b. (a -> b) -> a -> b
$ do
    Value
v <-
      forall t. Text -> Ctx t -> Maybe t
lookup Text
x Env
e
        forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
Maybe a -> e -> m a
`isJustOr` Text -> Exn
Fatal ([Text] -> Text
T.unwords [Text
"Undefined variable", Text
x, Text
"encountered while running the interpreter."])
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
v Store
s Cont
k

  -- To evaluate a pair, start evaluating the first component.
  In (TPair Term
t1 Term
t2) Env
e Store
s Cont
k -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Term -> Env -> Store -> Cont -> CESK
In Term
t1 Env
e Store
s (Term -> Env -> Frame
FSnd Term
t2 Env
e forall a. a -> [a] -> [a]
: Cont
k)
  -- Once that's done, evaluate the second component.
  Out Value
v1 Store
s (FSnd Term
t2 Env
e : Cont
k) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Term -> Env -> Store -> Cont -> CESK
In Term
t2 Env
e Store
s (Value -> Frame
FFst Value
v1 forall a. a -> [a] -> [a]
: Cont
k)
  -- Finally, put the results together into a pair value.
  Out Value
v2 Store
s (FFst Value
v1 : Cont
k) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Value -> Value -> Value
VPair Value
v1 Value
v2) Store
s Cont
k
  -- Lambdas immediately turn into closures.
  In (TLam Text
x Maybe Type
_ Term
t) Env
e Store
s Cont
k -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Text -> Term -> Env -> Value
VClo Text
x Term
t Env
e) Store
s Cont
k
  -- To evaluate an application, start by focusing on the left-hand
  -- side and saving the argument for later.
  In (TApp Term
t1 Term
t2) Env
e Store
s Cont
k -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Term -> Env -> Store -> Cont -> CESK
In Term
t1 Env
e Store
s (Term -> Env -> Frame
FArg Term
t2 Env
e forall a. a -> [a] -> [a]
: Cont
k)
  -- Once that's done, switch to evaluating the argument.
  Out Value
v1 Store
s (FArg Term
t2 Env
e : Cont
k) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Term -> Env -> Store -> Cont -> CESK
In Term
t2 Env
e Store
s (Value -> Frame
FApp Value
v1 forall a. a -> [a] -> [a]
: Cont
k)
  -- We can evaluate an application of a closure in the usual way.
  Out Value
v2 Store
s (FApp (VClo Text
x Term
t Env
e) : Cont
k) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Term -> Env -> Store -> Cont -> CESK
In Term
t (forall t. Text -> t -> Ctx t -> Ctx t
addBinding Text
x Value
v2 Env
e) Store
s Cont
k
  -- We can also evaluate an application of a constant by collecting
  -- arguments, eventually dispatching to evalConst for function
  -- constants.
  Out Value
v2 Store
s (FApp (VCApp Const
c [Value]
args) : Cont
k)
    | Bool -> Bool
not (Const -> Bool
isCmd Const
c)
        Bool -> Bool -> Bool
&& Const -> RID
arity Const
c forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> RID
length [Value]
args forall a. Num a => a -> a -> a
+ RID
1 ->
        forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m,
 Has (Lift IO) sig m) =>
Const -> [Value] -> Store -> Cont -> m CESK
evalConst Const
c (forall a. [a] -> [a]
reverse (Value
v2 forall a. a -> [a] -> [a]
: [Value]
args)) Store
s Cont
k
    | Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Const -> [Value] -> Value
VCApp Const
c (Value
v2 forall a. a -> [a] -> [a]
: [Value]
args)) Store
s Cont
k
  Out Value
_ Store
s (FApp Value
_ : Cont
_) -> forall {m :: * -> *}. Monad m => Store -> Text -> m CESK
badMachineState Store
s Text
"FApp of non-function"
  -- Start evaluating a record.  If it's empty, we're done.  Otherwise, focus
  -- on the first field and record the rest in a FRcd frame.
  In (TRcd Map Text (Maybe Term)
m) Env
e Store
s Cont
k -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case forall k a. Map k a -> [(k, a)]
M.assocs Map Text (Maybe Term)
m of
    [] -> Value -> Store -> Cont -> CESK
Out (Map Text Value -> Value
VRcd forall k a. Map k a
M.empty) Store
s Cont
k
    ((Text
x, Maybe Term
t) : [(Text, Maybe Term)]
fs) -> Term -> Env -> Store -> Cont -> CESK
In (forall a. a -> Maybe a -> a
fromMaybe (forall ty. Text -> Term' ty
TVar Text
x) Maybe Term
t) Env
e Store
s (Env -> [(Text, Value)] -> Text -> [(Text, Maybe Term)] -> Frame
FRcd Env
e [] Text
x [(Text, Maybe Term)]
fs forall a. a -> [a] -> [a]
: Cont
k)
  -- When we finish evaluating the last field, return a record value.
  Out Value
v Store
s (FRcd Env
_ [(Text, Value)]
done Text
x [] : Cont
k) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Map Text Value -> Value
VRcd (forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ((Text
x, Value
v) forall a. a -> [a] -> [a]
: [(Text, Value)]
done))) Store
s Cont
k
  -- Otherwise, save the value of the field just evaluated and move on
  -- to focus on evaluating the next one.
  Out Value
v Store
s (FRcd Env
e [(Text, Value)]
done Text
x ((Text
y, Maybe Term
t) : [(Text, Maybe Term)]
rest) : Cont
k) ->
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Term -> Env -> Store -> Cont -> CESK
In (forall a. a -> Maybe a -> a
fromMaybe (forall ty. Text -> Term' ty
TVar Text
y) Maybe Term
t) Env
e Store
s (Env -> [(Text, Value)] -> Text -> [(Text, Maybe Term)] -> Frame
FRcd Env
e ((Text
x, Value
v) forall a. a -> [a] -> [a]
: [(Text, Value)]
done) Text
y [(Text, Maybe Term)]
rest forall a. a -> [a] -> [a]
: Cont
k)
  -- Evaluate a record projection: evaluate the record and remember we
  -- need to do the projection later.
  In (TProj Term
t Text
x) Env
e Store
s Cont
k -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Term -> Env -> Store -> Cont -> CESK
In Term
t Env
e Store
s (Text -> Frame
FProj Text
x forall a. a -> [a] -> [a]
: Cont
k)
  -- Do a record projection
  Out Value
v Store
s (FProj Text
x : Cont
k) -> case Value
v of
    VRcd Map Text Value
m -> case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
x Map Text Value
m of
      Maybe Value
Nothing -> forall {m :: * -> *}. Monad m => Store -> Text -> m CESK
badMachineState Store
s forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unwords [Text
"Record projection for variable", Text
x, Text
"that does not exist"]
      Just Value
xv -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
xv Store
s Cont
k
    Value
_ -> forall {m :: * -> *}. Monad m => Store -> Text -> m CESK
badMachineState Store
s Text
"FProj frame with non-record value"
  -- To evaluate non-recursive let expressions, we start by focusing on the
  -- let-bound expression.
  In (TLet Bool
False Text
x Maybe Polytype
_ Term
t1 Term
t2) Env
e Store
s Cont
k -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Term -> Env -> Store -> Cont -> CESK
In Term
t1 Env
e Store
s (Text -> Term -> Env -> Frame
FLet Text
x Term
t2 Env
e forall a. a -> [a] -> [a]
: Cont
k)
  -- To evaluate recursive let expressions, we evaluate the memoized
  -- delay of the let-bound expression.  Every free occurrence of x
  -- in the let-bound expression and the body has already been
  -- rewritten by elaboration to 'force x'.
  In (TLet Bool
True Text
x Maybe Polytype
_ Term
t1 Term
t2) Env
e Store
s Cont
k ->
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Term -> Env -> Store -> Cont -> CESK
In (DelayType -> Term -> Term
TDelay (Maybe Text -> DelayType
MemoizedDelay forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Text
x) Term
t1) Env
e Store
s (Text -> Term -> Env -> Frame
FLet Text
x Term
t2 Env
e forall a. a -> [a] -> [a]
: Cont
k)
  -- Once we've finished with the let-binding, we switch to evaluating
  -- the body in a suitably extended environment.
  Out Value
v1 Store
s (FLet Text
x Term
t2 Env
e : Cont
k) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Term -> Env -> Store -> Cont -> CESK
In Term
t2 (forall t. Text -> t -> Ctx t -> Ctx t
addBinding Text
x Value
v1 Env
e) Store
s Cont
k
  -- Definitions immediately turn into VDef values, awaiting execution.
  In tm :: Term
tm@(TDef Bool
r Text
x Maybe Polytype
_ Term
t) Env
e Store
s Cont
k -> forall (m :: * -> *).
Monad m =>
Store -> Cont -> ThrowC Exn m CESK -> m CESK
withExceptions Store
s Cont
k forall a b. (a -> b) -> a -> b
$ do
    forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State Robot) sig m, Has (State GameState) sig m,
 Has (Throw Exn) sig m) =>
Capability -> Term -> m ()
hasCapabilityFor Capability
CEnv Term
tm
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Bool -> Text -> Term -> Env -> Value
VDef Bool
r Text
x Term
t Env
e) Store
s Cont
k

  -- Bind expressions don't evaluate: just package it up as a value
  -- until such time as it is to be executed.
  In (TBind Maybe Text
mx Term
t1 Term
t2) Env
e Store
s Cont
k -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Maybe Text -> Term -> Term -> Env -> Value
VBind Maybe Text
mx Term
t1 Term
t2 Env
e) Store
s Cont
k
  -- Simple (non-memoized) delay expressions immediately turn into
  -- VDelay values, awaiting application of 'Force'.
  In (TDelay DelayType
SimpleDelay Term
t) Env
e Store
s Cont
k -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Term -> Env -> Value
VDelay Term
t Env
e) Store
s Cont
k
  -- For memoized delay expressions, we allocate a new cell in the store and
  -- return a reference to it.
  In (TDelay (MemoizedDelay Maybe Text
x) Term
t) Env
e Store
s Cont
k -> do
    -- Note that if the delay expression is recursive, we add a
    -- binding to the environment that wil be used to evaluate the
    -- body, binding the variable to a reference to the memory cell we
    -- just allocated for the body expression itself.  As a fun aside,
    -- notice how Haskell's recursion and laziness play a starring
    -- role: @loc@ is both an output from @allocate@ and used as part
    -- of an input! =D
    let (RID
loc, Store
s') = Env -> Term -> Store -> (RID, Store)
allocate (forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (forall t. Text -> t -> Ctx t -> Ctx t
`addBinding` RID -> Value
VRef RID
loc) Maybe Text
x Env
e) Term
t Store
s
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (RID -> Value
VRef RID
loc) Store
s' Cont
k
  -- If we see an update frame, it means we're supposed to set the value
  -- of a particular cell to the value we just finished computing.
  Out Value
v Store
s (FUpdate RID
loc : Cont
k) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
v (RID -> MemCell -> Store -> Store
setStore RID
loc (Value -> MemCell
V Value
v) Store
s) Cont
k
  ------------------------------------------------------------
  -- Execution

  -- Executing a 'requirements' command generates an appropriate log message
  -- listing the requirements of the given expression.
  Out (VRequirements Text
src Term
t Env
_) Store
s (Frame
FExec : Cont
k) -> do
    ReqCtx
currentContext <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use forall a b. (a -> b) -> a -> b
$ Lens' Robot RobotContext
robotContext forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' RobotContext ReqCtx
defReqs
    EntityMap
em <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use forall a b. (a -> b) -> a -> b
$ Lens' GameState Landscape
landscape forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Landscape EntityMap
entityMap
    let (R.Requirements Set Capability
caps Set Text
devs Map Text RID
inv, ReqCtx
_) = ReqCtx -> Term -> (Requirements, ReqCtx)
R.requirements ReqCtx
currentContext Term
t

        devicesForCaps, requiredDevices :: Set (Set Text)
        -- possible devices to provide each required capability
        devicesForCaps :: Set (Set Text)
devicesForCaps = forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map (forall a. Ord a => [a] -> Set a
S.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall s a. s -> Getting a s a -> a
^. Lens' Entity Text
entityName) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Capability -> EntityMap -> [Entity]
`deviceForCap` EntityMap
em)) Set Capability
caps
        -- outright required devices
        requiredDevices :: Set (Set Text)
requiredDevices = forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map forall a. a -> Set a
S.singleton Set Text
devs

        deviceSets :: Set (Set Text)
        deviceSets :: Set (Set Text)
deviceSets =
          -- Union together all required device sets, and remove any
          -- device sets which are a superset of another set.  For
          -- example, if (grabber OR fast grabber OR harvester) is
          -- required but (grabber OR fast grabber) is also required
          -- then we might as well remove the first set, since
          -- satisfying the second device set will automatically
          -- satisfy the first.
          forall a. Ord a => Set (Set a) -> Set (Set a)
removeSupersets forall a b. (a -> b) -> a -> b
$ Set (Set Text)
devicesForCaps forall a. Ord a => Set a -> Set a -> Set a
`S.union` Set (Set Text)
requiredDevices

        reqLog :: Text
reqLog =
          forall a. PrettyPrec a => a -> Text
prettyText forall a b. (a -> b) -> a -> b
$
            forall i. (forall a. Doc a) -> [i] -> BulletList i
BulletList
              (forall a ann. Pretty a => a -> Doc ann
pretty forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unwords [Text
"Requirements for", Text -> Text
bquote Text
src forall a. Semigroup a => a -> a -> a
<> Text
":"])
              ( forall a. (a -> Bool) -> [a] -> [a]
filter
                  (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i. BulletList i -> [i]
bulletListItems)
                  [ forall i. (forall a. Doc a) -> [i] -> BulletList i
BulletList
                      Doc a
"Equipment:"
                      (Text -> [Text] -> Text
T.intercalate Text
" OR " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
S.toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Set a -> [a]
S.toList Set (Set Text)
deviceSets)
                  , forall i. (forall a. Doc a) -> [i] -> BulletList i
BulletList
                      Doc a
"Inventory:"
                      ((\(Text
e, RID
n) -> Text
e forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> Text -> Text
parens (forall a. Show a => a -> Text
showT RID
n)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Map k a -> [(k, a)]
M.assocs Map Text RID
inv)
                  ]
              )

    LogEntry
_ <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m) =>
RobotLogSource -> Severity -> Text -> m LogEntry
traceLog RobotLogSource
Logged Severity
Info Text
reqLog
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s Cont
k

  -- To execute a definition, we immediately turn the body into a
  -- delayed value, so it will not even be evaluated until it is
  -- called.  We memoize both recursive and non-recursive definitions,
  -- since the point of a definition is that it may be used many times.
  Out (VDef Bool
r Text
x Term
t Env
e) Store
s (Frame
FExec : Cont
k) ->
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Term -> Env -> Store -> Cont -> CESK
In (DelayType -> Term -> Term
TDelay (Maybe Text -> DelayType
MemoizedDelay forall a b. (a -> b) -> a -> b
$ forall a. a -> a -> Bool -> a
bool forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just Text
x) Bool
r) Term
t) Env
e Store
s (Text -> Frame
FDef Text
x forall a. a -> [a] -> [a]
: Cont
k)
  -- Once we have finished evaluating the (memoized, delayed) body of
  -- a definition, we return a special VResult value, which packages
  -- up the return value from the @def@ command itself (@unit@)
  -- together with the resulting environment (the variable bound to
  -- the delayed value).
  Out Value
v Store
s (FDef Text
x : Cont
k) ->
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Value -> Env -> Value
VResult Value
VUnit (forall t. Text -> t -> Ctx t
singleton Text
x Value
v)) Store
s Cont
k
  -- To execute a constant application, delegate to the 'evalConst'
  -- function.  Set tickStepBudget to 0 if the command is supposed to take
  -- a tick, so the robot won't take any more steps this tick.
  Out (VCApp Const
c [Value]
args) Store
s (Frame
FExec : Cont
k) -> do
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Const -> Bool
isTangible Const
c) forall a b. (a -> b) -> a -> b
$ Lens' Robot ActivityCounts
activityCounts forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' ActivityCounts RID
tickStepBudget forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= RID
0
    forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m,
 Has (Lift IO) sig m) =>
Const -> [Value] -> Store -> Cont -> m CESK
evalConst Const
c (forall a. [a] -> [a]
reverse [Value]
args) Store
s Cont
k

  -- Reset the runningAtomic flag when we encounter an FFinishAtomic frame.
  Out Value
v Store
s (Frame
FFinishAtomic : Cont
k) -> do
    Lens' Robot Bool
runningAtomic forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= Bool
False
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
v Store
s Cont
k

  -- Machinery for implementing the 'Swarm.Language.Syntax.MeetAll' command.
  -- First case: done meeting everyone.
  Out Value
b Store
s (FMeetAll Value
_ [] : Cont
k) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
b Store
s Cont
k
  -- More still to meet: apply the function to the current value b and
  -- then the next robot id.  This will result in a command which we
  -- execute, discard any generated environment, and then pass the
  -- result to continue meeting the rest of the robots.
  Out Value
b Store
s (FMeetAll Value
f (RID
rid : [RID]
rids) : Cont
k) ->
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
b Store
s (Value -> Frame
FApp Value
f forall a. a -> [a] -> [a]
: Term -> Env -> Frame
FArg (forall ty. RID -> Term' ty
TRobot RID
rid) forall t. Ctx t
empty forall a. a -> [a] -> [a]
: Frame
FExec forall a. a -> [a] -> [a]
: Frame
FDiscardEnv forall a. a -> [a] -> [a]
: Value -> [RID] -> Frame
FMeetAll Value
f [RID]
rids forall a. a -> [a] -> [a]
: Cont
k)
  -- To execute a bind expression, evaluate and execute the first
  -- command, and remember the second for execution later.
  Out (VBind Maybe Text
mx Term
c1 Term
c2 Env
e) Store
s (Frame
FExec : Cont
k) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Term -> Env -> Store -> Cont -> CESK
In Term
c1 Env
e Store
s (Frame
FExec forall a. a -> [a] -> [a]
: Maybe Text -> Term -> Env -> Frame
FBind Maybe Text
mx Term
c2 Env
e forall a. a -> [a] -> [a]
: Cont
k)
  -- If first command completes with a value along with an environment
  -- resulting from definition commands and/or binds, switch to
  -- evaluating the second command of the bind.  Extend the
  -- environment with both the environment resulting from the first
  -- command, as well as a binding for the result (if the bind was of
  -- the form @x <- c1; c2@).  Remember that we must execute the
  -- second command once it has been evaluated, then union any
  -- resulting definition environment with the definition environment
  -- from the first command.
  Out (VResult Value
v Env
ve) Store
s (FBind Maybe Text
mx Term
t2 Env
e : Cont
k) -> do
    let ve' :: Env
ve' = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (forall t. Text -> t -> Ctx t -> Ctx t
`addBinding` Value
v) Maybe Text
mx Env
ve
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Term -> Env -> Store -> Cont -> CESK
In Term
t2 (Env
e forall t. Ctx t -> Ctx t -> Ctx t
`union` Env
ve') Store
s (Frame
FExec forall a. a -> [a] -> [a]
: Env -> Cont -> Cont
fUnionEnv Env
ve' Cont
k)
  -- If the first command completes with a simple value and there is no binder,
  -- then we just continue without worrying about the environment.
  Out Value
_ Store
s (FBind Maybe Text
Nothing Term
t2 Env
e : Cont
k) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Term -> Env -> Store -> Cont -> CESK
In Term
t2 Env
e Store
s (Frame
FExec forall a. a -> [a] -> [a]
: Cont
k)
  -- If the first command completes with a simple value and there is a binder,
  -- we promote it to the returned environment as well.
  Out Value
v Store
s (FBind (Just Text
x) Term
t2 Env
e : Cont
k) -> do
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Term -> Env -> Store -> Cont -> CESK
In Term
t2 (forall t. Text -> t -> Ctx t -> Ctx t
addBinding Text
x Value
v Env
e) Store
s (Frame
FExec forall a. a -> [a] -> [a]
: Env -> Cont -> Cont
fUnionEnv (forall t. Text -> t -> Ctx t
singleton Text
x Value
v) Cont
k)
  -- If a command completes with a value and definition environment,
  -- and the next continuation frame contains a previous environment
  -- to union with, then pass the unioned environments along in
  -- another VResult.

  Out (VResult Value
v Env
e2) Store
s (FUnionEnv Env
e1 : Cont
k) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Value -> Env -> Value
VResult Value
v (Env
e1 forall t. Ctx t -> Ctx t -> Ctx t
`union` Env
e2)) Store
s Cont
k
  -- Or, if a command completes with no environment, but there is a
  -- previous environment to union with, just use that environment.
  Out Value
v Store
s (FUnionEnv Env
e : Cont
k) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Value -> Env -> Value
VResult Value
v Env
e) Store
s Cont
k
  -- If there's an explicit DiscardEnv frame, throw away any returned environment.
  Out (VResult Value
v Env
_) Store
s (Frame
FDiscardEnv : Cont
k) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
v Store
s Cont
k
  Out Value
v Store
s (Frame
FDiscardEnv : Cont
k) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
v Store
s Cont
k
  -- If the top of the continuation stack contains a 'FLoadEnv' frame,
  -- it means we are supposed to load up the resulting definition
  -- environment, store, and type and capability contexts into the robot's
  -- top-level environment and contexts, so they will be available to
  -- future programs.
  Out (VResult Value
v Env
e) Store
s (FLoadEnv TCtx
ctx ReqCtx
rctx : Cont
k) -> do
    Lens' Robot RobotContext
robotContext forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' RobotContext Env
defVals forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= (forall t. Ctx t -> Ctx t -> Ctx t
`union` Env
e)
    Lens' Robot RobotContext
robotContext forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' RobotContext TCtx
defTypes forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= (forall t. Ctx t -> Ctx t -> Ctx t
`union` TCtx
ctx)
    Lens' Robot RobotContext
robotContext forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' RobotContext ReqCtx
defReqs forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= (forall t. Ctx t -> Ctx t -> Ctx t
`union` ReqCtx
rctx)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
v Store
s Cont
k
  Out Value
v Store
s (FLoadEnv {} : Cont
k) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
v Store
s Cont
k
  -- Any other type of value wiwth an FExec frame is an error (should
  -- never happen).
  Out Value
_ Store
s (Frame
FExec : Cont
_) -> forall {m :: * -> *}. Monad m => Store -> Text -> m CESK
badMachineState Store
s Text
"FExec frame with non-executable value"
  -- If we see a VResult in any other context, simply discard it.  For
  -- example, this is what happens when there are binders (i.e. a "do
  -- block") nested inside another block instead of at the top level.
  -- It used to be that (1) only 'def' could generate a VResult, and
  -- (2) 'def' was guaranteed to only occur at the top level, hence
  -- any VResult would be caught by a FLoadEnv frame, and seeing a
  -- VResult anywhere else was an error.  But
  -- https://github.com/swarm-game/swarm/commit/b62d27e566565aa9a3ff351d91b23d2589b068dc
  -- made top-level binders export a variable binding, also via the
  -- VResult mechanism, and unlike 'def', binders do not have to occur
  -- at the top level only.  This led to
  -- https://github.com/swarm-game/swarm/issues/327 , which was fixed
  -- by changing this case from an error to simply ignoring the
  -- VResult wrapper.
  Out (VResult Value
v Env
_) Store
s Cont
k -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
v Store
s Cont
k
  ------------------------------------------------------------
  -- Exception handling
  ------------------------------------------------------------

  -- First, if we were running a try block but evaluation completed normally,
  -- just ignore the try block and continue.
  Out Value
v Store
s (FTry {} : Cont
k) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
v Store
s Cont
k
  Up Exn
exn Store
s [] -> do
    -- Here, an exception has risen all the way to the top level without being
    -- handled.
    case Exn
exn of
      CmdFailed Const
_ Text
_ (Just GameplayAchievement
a) -> do
        forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (Lift IO) sig m) =>
GameplayAchievement -> m ()
grantAchievement GameplayAchievement
a
      Exn
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

    -- If an exception rises all the way to the top level without being
    -- handled, turn it into an error message.

    -- HOWEVER, we have to make sure to check that the robot has the
    -- 'log' capability which is required to collect and view logs.
    --
    -- Notice how we call resetBlackholes on the store, so that any
    -- cells which were in the middle of being evaluated will be reset.
    let s' :: Store
s' = Store -> Store
resetBlackholes Store
s
    Bool
h <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State Robot) sig m, Has (State GameState) sig m) =>
Capability -> m Bool
hasCapability Capability
CLog
    EntityMap
em <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use forall a b. (a -> b) -> a -> b
$ Lens' GameState Landscape
landscape forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Landscape EntityMap
entityMap
    if Bool
h
      then do
        forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m) =>
RobotLogSource -> Severity -> Text -> m LogEntry
traceLog RobotLogSource
RobotError Severity
Error (EntityMap -> Exn -> Text
formatExn EntityMap
em Exn
exn)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s []
      else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s' []
  -- Fatal errors, capability errors, and infinite loop errors can't
  -- be caught; just throw away the continuation stack.
  Up exn :: Exn
exn@Fatal {} Store
s Cont
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exn -> Store -> Cont -> CESK
Up Exn
exn Store
s []
  Up exn :: Exn
exn@Incapable {} Store
s Cont
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exn -> Store -> Cont -> CESK
Up Exn
exn Store
s []
  Up exn :: Exn
exn@InfiniteLoop {} Store
s Cont
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exn -> Store -> Cont -> CESK
Up Exn
exn Store
s []
  -- Otherwise, if we are raising an exception up the continuation
  -- stack and come to a Try frame, force and then execute the associated catch
  -- block.
  Up Exn
_ Store
s (FTry Value
c : Cont
k) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
c Store
s (Value -> Frame
FApp (Const -> [Value] -> Value
VCApp Const
Force []) forall a. a -> [a] -> [a]
: Frame
FExec forall a. a -> [a] -> [a]
: Cont
k)
  -- Otherwise, keep popping from the continuation stack.
  Up Exn
exn Store
s (Frame
_ : Cont
k) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exn -> Store -> Cont -> CESK
Up Exn
exn Store
s Cont
k
  -- Finally, if we're done evaluating and the continuation stack is
  -- empty, return the machine unchanged.
  done :: CESK
done@(Out Value
_ Store
_ []) -> forall (m :: * -> *) a. Monad m => a -> m a
return CESK
done
 where
  badMachineState :: Store -> Text -> m CESK
badMachineState Store
s Text
msg =
    let msg' :: Text
msg' =
          [Text] -> Text
T.unlines
            [ Text -> Text -> Text
T.append Text
"Bad machine state in stepRobot: " Text
msg
            , forall a. PrettyPrec a => a -> Text
prettyText CESK
cesk
            ]
     in forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exn -> Store -> Cont -> CESK
Up (Text -> Exn
Fatal Text
msg') Store
s []

  -- Note, the order of arguments to `union` is important in the below
  -- definition of fUnionEnv.  I wish I knew how to add an automated
  -- test for this.  But you can tell the difference in the following
  -- REPL session:
  --
  -- > x <- return 1; x <- return 2
  -- 2 : int
  -- > x
  -- 2 : int
  --
  -- If we switch the code to read 'e1 `union` e2' instead, then
  -- the first expression above still correctly evaluates to 2, but
  -- x ends up incorrectly bound to 1.

  fUnionEnv :: Env -> Cont -> Cont
fUnionEnv Env
e1 = \case
    FUnionEnv Env
e2 : Cont
k -> Env -> Frame
FUnionEnv (Env
e2 forall t. Ctx t -> Ctx t -> Ctx t
`union` Env
e1) forall a. a -> [a] -> [a]
: Cont
k
    Cont
k -> Env -> Frame
FUnionEnv Env
e1 forall a. a -> [a] -> [a]
: Cont
k

-- | Eexecute a constant, catching any exception thrown and returning
--   it via a CESK machine state.
evalConst ::
  (Has (State GameState) sig m, Has (State Robot) sig m, Has (Lift IO) sig m) => Const -> [Value] -> Store -> Cont -> m CESK
evalConst :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m,
 Has (Lift IO) sig m) =>
Const -> [Value] -> Store -> Cont -> m CESK
evalConst Const
c [Value]
vs Store
s Cont
k = do
  Either Exn CESK
res <- forall exc (m :: * -> *) a. ErrorC exc m a -> m (Either exc a)
runError forall a b. (a -> b) -> a -> b
$ forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(HasRobotStepState sig m, Has (Lift IO) sig m) =>
Const -> [Value] -> Store -> Cont -> m CESK
execConst Const
c [Value]
vs Store
s Cont
k
  case Either Exn CESK
res of
    Left Exn
exn -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exn -> Store -> Cont -> CESK
Up Exn
exn Store
s Cont
k
    Right CESK
cek' -> forall (m :: * -> *) a. Monad m => a -> m a
return CESK
cek'

-- | A system program for a "seed robot", to regrow a growable entity
--   after it is harvested.
seedProgram :: Integer -> Integer -> Text -> ProcessedTerm
seedProgram :: Integer -> Integer -> Text -> ProcessedTerm
seedProgram Integer
minTime Integer
randTime Text
thing =
  [tmQ|
    try {
      r <- random (1 + $int:randTime);
      wait (r + $int:minTime);
      appear "|";
      r <- random (1 + $int:randTime);
      wait (r + $int:minTime);
      place $str:thing;
    } {};
    selfdestruct
  |]

-- | 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) ->
  Cosmic Location ->
  TimeSpec ->
  m ()
addSeedBot :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
Entity -> (Integer, Integer) -> Cosmic Location -> TimeSpec -> m ()
addSeedBot Entity
e (Integer
minT, Integer
maxT) Cosmic Location
loc TimeSpec
ts =
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$
    forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
TRobot -> m Robot
addTRobot forall a b. (a -> b) -> a -> b
$
      forall (phase :: RobotPhase).
RobotID phase
-> Maybe RID
-> Text
-> Document Syntax
-> RobotLocation phase
-> Heading
-> Display
-> CESK
-> [Entity]
-> [(RID, Entity)]
-> Bool
-> Bool
-> Set Text
-> TimeSpec
-> RobotR phase
mkRobot
        ()
        forall a. Maybe a
Nothing
        Text
"seed"
        (Text -> Document Syntax
Markdown.fromText forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unwords [Text
"A growing", Entity
e forall s a. s -> Getting a s a -> a
^. Lens' Entity Text
entityName, Text
"seed."])
        (forall a. a -> Maybe a
Just Cosmic Location
loc)
        forall (f :: * -> *) a. (Additive f, Num a) => f a
zero
        ( Char -> Display
defaultEntityDisplay Char
'.'
            forall a b. a -> (a -> b) -> b
& Lens' Display Attribute
displayAttr forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Entity
e forall s a. s -> Getting a s a -> a
^. Lens' Entity Display
entityDisplay forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Display Attribute
displayAttr)
            forall a b. a -> (a -> b) -> b
& Lens' Display RID
displayPriority forall s t a b. ASetter s t a b -> b -> s -> t
.~ RID
0
        )
        (ProcessedTerm -> Env -> Store -> CESK
initMachine (Integer -> Integer -> Text -> ProcessedTerm
seedProgram Integer
minT (Integer
maxT forall a. Num a => a -> a -> a
- Integer
minT) (Entity
e forall s a. s -> Getting a s a -> a
^. Lens' Entity Text
entityName)) forall t. Ctx t
empty Store
emptyStore)
        []
        [(RID
1, Entity
e)]
        Bool
True
        Bool
False
        forall a. Monoid a => a
mempty
        TimeSpec
ts

-- | Interpret the execution (or evaluation) of a constant application
--   to some values.
execConst ::
  (HasRobotStepState sig m, Has (Lift IO) sig m) =>
  Const ->
  [Value] ->
  Store ->
  Cont ->
  m CESK
execConst :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(HasRobotStepState sig m, Has (Lift IO) sig m) =>
Const -> [Value] -> Store -> Cont -> m CESK
execConst Const
c [Value]
vs Store
s Cont
k = do
  -- First, ensure the robot is capable of executing/evaluating this constant.
  forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State Robot) sig m, Has (State GameState) sig m,
 Has (Throw Exn) sig m) =>
Const -> m ()
ensureCanExecute Const
c

  -- Increment command count regardless of success
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Const -> Bool
isTangible Const
c) forall a b. (a -> b) -> a -> b
$
    Lens' Robot ActivityCounts
activityCounts forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' ActivityCounts RID
tangibleCommandCount forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State s) sig m, Num a) =>
ASetter' s a -> a -> m ()
+= RID
1

  Lens' Robot ActivityCounts
activityCounts forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' ActivityCounts (Map Const RID)
commandsHistogram forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith forall a. Num a => a -> a -> a
(+) Const
c RID
1

  -- Now proceed to actually carry out the operation.
  case Const
c of
    Const
Noop -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s Cont
k
    Const
Return -> case [Value]
vs of
      [Value
v] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
v Store
s Cont
k
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Wait -> case [Value]
vs of
      [VInt Integer
d] -> do
        TickNumber
time <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use forall a b. (a -> b) -> a -> b
$ Lens' GameState TemporalState
temporal forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' TemporalState TickNumber
ticks
        forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
m ()
purgeFarAwayWatches
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ TickNumber -> CESK -> CESK
Waiting (RID -> TickNumber -> TickNumber
addTicks (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
d) TickNumber
time) (Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s Cont
k)
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Selfdestruct -> do
      forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(HasRobotStepState sig m, Has (Lift IO) sig m) =>
(Bool -> Maybe GameplayAchievement) -> m ()
destroyIfNotBase forall a b. (a -> b) -> a -> b
$ \case Bool
False -> forall a. a -> Maybe a
Just GameplayAchievement
AttemptSelfDestructBase; Bool
_ -> forall a. Maybe a
Nothing
      forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
m ()
flagRedraw
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s Cont
k
    Const
Move -> do
      Maybe Heading
orient <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot (Maybe Heading)
robotOrientation
      forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(HasRobotStepState sig m, Has (Lift IO) sig m) =>
Heading -> m CESK
moveInDirection forall a b. (a -> b) -> a -> b
$ Maybe Heading
orient forall a. Maybe a -> a -> a
? forall (f :: * -> *) a. (Additive f, Num a) => f a
zero
    Const
Backup -> do
      Maybe Heading
orient <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot (Maybe Heading)
robotOrientation
      forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(HasRobotStepState sig m, Has (Lift IO) sig m) =>
Heading -> m CESK
moveInDirection forall a b. (a -> b) -> a -> b
$ Direction -> Heading -> Heading
applyTurn (RelativeDir -> Direction
DRelative forall a b. (a -> b) -> a -> b
$ PlanarRelativeDir -> RelativeDir
DPlanar PlanarRelativeDir
DBack) forall a b. (a -> b) -> a -> b
$ Maybe Heading
orient forall a. Maybe a -> a -> a
? forall (f :: * -> *) a. (Additive f, Num a) => f a
zero
    Const
Path -> case [Value]
vs of
      [VInj Bool
hasLimit Value
limitVal, VInj Bool
findEntity Value
goalVal] -> do
        Maybe Integer
maybeLimit <-
          if Bool
hasLimit
            then case Value
limitVal of
              VInt Integer
d -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Integer
d
              Value
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
            else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        PathfindingTarget
goal <-
          if Bool
findEntity
            then case Value
goalVal of
              VText Text
eName -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> PathfindingTarget
EntityTarget Text
eName
              Value
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
            else case Value
goalVal of
              VPair (VInt Integer
x) (VInt Integer
y) ->
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
                  Location -> PathfindingTarget
LocationTarget forall a b. (a -> b) -> a -> b
$
                    Int32 -> Int32 -> Location
Location (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
x) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
y)
              Value
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
        Cosmic Location
robotLoc <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot (Cosmic Location)
robotLocation
        Maybe Direction
result <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(HasRobotStepState sig m, Has (State GameState) sig m) =>
Maybe Integer
-> Cosmic Location -> PathfindingTarget -> m (Maybe Direction)
pathCommand Maybe Integer
maybeLimit Cosmic Location
robotLoc PathfindingTarget
goal
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (forall a. Valuable a => a -> Value
asValue Maybe Direction
result) Store
s Cont
k
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Push -> do
      -- Figure out where we're going
      Cosmic Location
loc <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot (Cosmic Location)
robotLocation
      Maybe Heading
orient <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot (Maybe Heading)
robotOrientation
      let applyHeading :: Cosmic Location -> Cosmic Location
applyHeading = (Cosmic Location -> Heading -> Cosmic Location
`offsetBy` (Maybe Heading
orient forall a. Maybe a -> a -> a
? forall (f :: * -> *) a. (Additive f, Num a) => f a
zero))
          nextLoc :: Cosmic Location
nextLoc = Cosmic Location -> Cosmic Location
applyHeading Cosmic Location
loc
          placementLoc :: Cosmic Location
placementLoc = Cosmic Location -> Cosmic Location
applyHeading Cosmic Location
nextLoc

      -- If unobstructed, the robot will move even if
      -- there is nothing to push.
      Maybe Entity
maybeCurrentE <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
Cosmic Location -> m (Maybe Entity)
entityAt Cosmic Location
nextLoc
      case Maybe Entity
maybeCurrentE of
        Just Entity
e -> do
          -- Make sure there's nothing already occupying the destination
          Bool
nothingHere <- forall a. Maybe a -> Bool
isNothing forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
Cosmic Location -> m (Maybe Entity)
entityAt Cosmic Location
placementLoc
          Bool
nothingHere forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Bool -> [Text] -> m ()
`holdsOrFail` [Text
"Something is in the way!"]

          let verbed :: Text
verbed = GrabbingCmd -> Text
verbedGrabbingCmd GrabbingCmd
Push'
          -- Ensure it can be pushed.
          Bool
omni <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m) =>
m Bool
isPrivilegedBot
          (Bool
omni Bool -> Bool -> Bool
|| Entity
e Entity -> EntityProperty -> Bool
`hasProperty` EntityProperty
Portable Bool -> Bool -> Bool
&& Bool -> Bool
not (Entity
e Entity -> EntityProperty -> Bool
`hasProperty` EntityProperty
Liquid))
            forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Bool -> [Text] -> m ()
`holdsOrFail` [Text
"The", Entity
e forall s a. s -> Getting a s a -> a
^. Lens' Entity Text
entityName, Text
"here can't be", Text
verbed forall a. Semigroup a => a -> a -> a
<> Text
"."]

          -- Place the entity and remove it from previous loc
          forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
Cosmic Location -> (Maybe Entity -> Maybe Entity) -> m ()
updateEntityAt Cosmic Location
nextLoc (forall a b. a -> b -> a
const forall a. Maybe a
Nothing)
          forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
Cosmic Location -> (Maybe Entity -> Maybe Entity) -> m ()
updateEntityAt Cosmic Location
placementLoc (forall a b. a -> b -> a
const (forall a. a -> Maybe a
Just Entity
e))
        Maybe Entity
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

      forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Cosmic Location -> Cosmic Location -> m ()
updateRobotLocation Cosmic Location
loc Cosmic Location
nextLoc
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s Cont
k
    Const
Stride -> case [Value]
vs of
      [VInt Integer
d] -> do
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
d forall a. Ord a => a -> a -> Bool
> forall a b. (Integral a, Num b) => a -> b
fromIntegral RID
maxStrideRange) forall a b. (a -> b) -> a -> b
$
          forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError forall a b. (a -> b) -> a -> b
$
            Const -> Text -> Maybe GameplayAchievement -> Exn
CmdFailed
              Const
Stride
              ( [Text] -> Text
T.unwords
                  [ Text
"Can only stride up to"
                  , String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show RID
maxStrideRange
                  , Text
"units."
                  ]
              )
              forall a. Maybe a
Nothing

        -- Figure out where we're going
        Cosmic Location
loc <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot (Cosmic Location)
robotLocation
        Maybe Heading
orient <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot (Maybe Heading)
robotOrientation
        let heading :: Heading
heading = Maybe Heading
orient forall a. Maybe a -> a -> a
? forall (f :: * -> *) a. (Additive f, Num a) => f a
zero

        -- Excludes the base location.
        let locsInDirection :: [Cosmic Location]
            locsInDirection :: [Cosmic Location]
locsInDirection =
              forall a. RID -> [a] -> [a]
take (forall a. Ord a => a -> a -> a
min (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
d) RID
maxStrideRange) forall a b. (a -> b) -> a -> b
$
                forall a. RID -> [a] -> [a]
drop RID
1 forall a b. (a -> b) -> a -> b
$
                  forall a. (a -> a) -> a -> [a]
iterate (Cosmic Location -> Heading -> Cosmic Location
`offsetBy` Heading
heading) Cosmic Location
loc

        [Maybe MoveFailureDetails]
failureMaybes <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Cosmic Location -> m (Maybe MoveFailureDetails)
checkMoveFailure [Cosmic Location]
locsInDirection
        let maybeFirstFailure :: Maybe MoveFailureDetails
maybeFirstFailure = forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum [Maybe MoveFailureDetails]
failureMaybes

        forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(HasRobotStepState sig m, Has (Lift IO) sig m) =>
Maybe MoveFailureDetails -> MoveFailureHandler -> m ()
applyMoveFailureEffect Maybe MoveFailureDetails
maybeFirstFailure forall a b. (a -> b) -> a -> b
$ \case
          MoveFailureMode
PathBlocked -> RobotFailure
ThrowExn
          MoveFailureMode
PathLiquid -> RobotFailure
Destroy

        let maybeLastLoc :: Maybe (Cosmic Location)
maybeLastLoc = do
              forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null Maybe MoveFailureDetails
maybeFirstFailure
              forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [Cosmic Location]
locsInDirection

        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (Cosmic Location)
maybeLastLoc forall a b. (a -> b) -> a -> b
$ forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Cosmic Location -> Cosmic Location -> m ()
updateRobotLocation Cosmic Location
loc

        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s Cont
k
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Teleport -> case [Value]
vs of
      [VRobot RID
rid, VPair (VInt Integer
x) (VInt Integer
y)] -> do
        -- Make sure the other robot exists and is close
        Robot
target <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
RID -> m Robot
getRobotWithinTouch RID
rid
        -- either change current robot or one in robot map
        let oldLoc :: Cosmic Location
oldLoc = Robot
target forall s a. s -> Getting a s a -> a
^. Getter Robot (Cosmic Location)
robotLocation
            nextLoc :: Cosmic Location
nextLoc = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ Int32 -> Int32 -> Location
Location (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
x) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
y)) Cosmic Location
oldLoc

        forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(HasRobotStepState sig m, Has (Lift IO) sig m) =>
RID
-> (forall (sig' :: (* -> *) -> * -> *) (m' :: * -> *).
    (HasRobotStepState sig' m', Has (Lift IO) sig' m') =>
    m' ())
-> m ()
onTarget RID
rid forall a b. (a -> b) -> a -> b
$ do
          forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(HasRobotStepState sig m, Has (Lift IO) sig m) =>
Cosmic Location -> MoveFailureHandler -> m ()
checkMoveAhead Cosmic Location
nextLoc forall a b. (a -> b) -> a -> b
$ \case
            MoveFailureMode
PathBlocked -> RobotFailure
Destroy
            MoveFailureMode
PathLiquid -> RobotFailure
Destroy
          forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Cosmic Location -> Cosmic Location -> m ()
updateRobotLocation Cosmic Location
oldLoc Cosmic Location
nextLoc

        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s Cont
k
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Grab -> forall a. Valuable a => a -> CESK
mkReturn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(HasRobotStepState sig m, Has (Lift IO) sig m) =>
GrabbingCmd -> m Entity
doGrab GrabbingCmd
Grab'
    Const
Harvest -> forall a. Valuable a => a -> CESK
mkReturn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(HasRobotStepState sig m, Has (Lift IO) sig m) =>
GrabbingCmd -> m Entity
doGrab GrabbingCmd
Harvest'
    Const
Ignite -> case [Value]
vs of
      [VDir Direction
d] -> do
        forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(HasRobotStepState sig m, Has (Lift IO) sig m) =>
Const -> Direction -> m ()
Combustion.igniteCommand Const
c Direction
d
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s Cont
k
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Swap -> case [Value]
vs of
      [VText Text
name] -> do
        Cosmic Location
loc <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot (Cosmic Location)
robotLocation
        -- Make sure the robot has the thing in its inventory
        Entity
e <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Text -> m Entity
hasInInventoryOrFail Text
name
        -- Grab
        Entity
newE <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(HasRobotStepState sig m, Has (Lift IO) sig m) =>
GrabbingCmd -> m Entity
doGrab GrabbingCmd
Swap'

        -- Place the entity and remove it from the inventory
        forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
Cosmic Location -> (Maybe Entity -> Maybe Entity) -> m ()
updateEntityAt Cosmic Location
loc (forall a b. a -> b -> a
const (forall a. a -> Maybe a
Just Entity
e))
        Lens' Robot Inventory
robotInventory forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= Entity -> Inventory -> Inventory
delete Entity
e

        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Entity
e forall a. Eq a => a -> a -> Bool
== Entity
newE) forall a b. (a -> b) -> a -> b
$
          forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (Lift IO) sig m) =>
GameplayAchievement -> m ()
grantAchievement GameplayAchievement
SwapSame

        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Valuable a => a -> CESK
mkReturn Entity
newE
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Turn -> case [Value]
vs of
      [VDir Direction
d] -> do
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Direction -> Bool
isCardinal Direction
d) forall a b. (a -> b) -> a -> b
$ forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State Robot) sig m, Has (State GameState) sig m,
 Has (Throw Exn) sig m) =>
Capability -> Term -> m ()
hasCapabilityFor Capability
COrient (forall ty. Direction -> Term' ty
TDir Direction
d)
        Lens' Robot (Maybe Heading)
robotOrientation forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= Direction -> Heading -> Heading
applyTurn Direction
d
        forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
m ()
flagRedraw

        Inventory
inst <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot Inventory
equippedDevices
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Direction
d forall a. Eq a => a -> a -> Bool
== RelativeDir -> Direction
DRelative RelativeDir
DDown Bool -> Bool -> Bool
&& Text -> Inventory -> RID
countByName Text
"compass" Inventory
inst forall a. Eq a => a -> a -> Bool
== RID
0) forall a b. (a -> b) -> a -> b
$ do
          forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (Lift IO) sig m) =>
GameplayAchievement -> m ()
grantAchievement GameplayAchievement
GetDisoriented

        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s Cont
k
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Place -> case [Value]
vs of
      [VText Text
name] -> do
        Cosmic Location
loc <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot (Cosmic Location)
robotLocation

        -- Make sure there's nothing already here
        Bool
nothingHere <- forall a. Maybe a -> Bool
isNothing forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
Cosmic Location -> m (Maybe Entity)
entityAt Cosmic Location
loc
        Bool
nothingHere forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Bool -> [Text] -> m ()
`holdsOrFail` [Text
"There is already an entity here."]

        -- Make sure the robot has the thing in its inventory
        Entity
e <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Text -> m Entity
hasInInventoryOrFail Text
name

        -- Place the entity and remove it from the inventory
        forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
Cosmic Location -> (Maybe Entity -> Maybe Entity) -> m ()
updateEntityAt Cosmic Location
loc (forall a b. a -> b -> a
const (forall a. a -> Maybe a
Just Entity
e))
        Lens' Robot Inventory
robotInventory forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= Entity -> Inventory -> Inventory
delete Entity
e

        forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
m ()
flagRedraw
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s Cont
k
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Ping -> case [Value]
vs of
      [VRobot RID
otherID] -> do
        Maybe Robot
maybeOtherRobot <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
RID -> m (Maybe Robot)
robotWithID RID
otherID
        Robot
selfRobot <- forall s (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
m s
get
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (forall a. Valuable a => a -> Value
asValue forall a b. (a -> b) -> a -> b
$ Robot -> Maybe Robot -> Maybe Heading
displacementVector Robot
selfRobot Maybe Robot
maybeOtherRobot) Store
s Cont
k
       where
        displacementVector :: Robot -> Maybe Robot -> Maybe (V2 Int32)
        displacementVector :: Robot -> Maybe Robot -> Maybe Heading
displacementVector Robot
selfRobot Maybe Robot
maybeOtherRobot = do
          Robot
otherRobot <- Maybe Robot
maybeOtherRobot
          let dist :: DistanceMeasure Double
dist = (forall a b.
(a -> a -> b) -> Cosmic a -> Cosmic a -> DistanceMeasure b
cosmoMeasure Location -> Location -> Double
euclidean forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall r a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Reader r) sig m =>
Getting a r a -> m a
view Getter Robot (Cosmic Location)
robotLocation) Robot
selfRobot Robot
otherRobot
              (Double
_minRange, Double
maxRange) = Maybe Robot -> Maybe Robot -> (Double, Double)
getRadioRange (forall a. a -> Maybe a
Just Robot
selfRobot) (forall a. a -> Maybe a
Just Robot
otherRobot)
          Double
d <- forall b. DistanceMeasure b -> Maybe b
getFiniteDistance DistanceMeasure Double
dist
          forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Double
d forall a. Ord a => a -> a -> Bool
<= Double
maxRange
          Robot -> Cosmic Location -> Maybe Heading
orientationBasedRelativePosition Robot
selfRobot forall a b. (a -> b) -> a -> b
$ forall r a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Reader r) sig m =>
Getting a r a -> m a
view Getter Robot (Cosmic Location)
robotLocation Robot
otherRobot
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Give -> case [Value]
vs of
      [VRobot RID
otherID, VText Text
itemName] -> do
        -- Make sure the other robot exists and is close
        Robot
_other <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
RID -> m Robot
getRobotWithinTouch RID
otherID

        Entity
item <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Text -> Text -> m Entity
ensureItem Text
itemName Text
"give"

        -- Giving something to ourself should be a no-op.  We need
        -- this as a special case since it will not work to modify
        -- ourselves in the robotMap --- after performing a tick we
        -- return a modified Robot which gets put back in the
        -- robotMap, overwriting any changes to this robot made
        -- directly in the robotMap during the tick.
        RID
myID <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot RID
robotID
        RID
focusedID <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter GameState RID
focusedRobotID
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RID
otherID forall a. Eq a => a -> a -> Bool
/= RID
myID) forall a b. (a -> b) -> a -> b
$ do
          -- Make the exchange
          Lens' GameState (IntMap Robot)
robotMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at RID
otherID forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Robot Inventory
robotInventory forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= Entity -> Inventory -> Inventory
insert Entity
item
          Lens' Robot Inventory
robotInventory forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= Entity -> Inventory -> Inventory
delete Entity
item

          -- Flag the UI for a redraw if we are currently showing either robot's inventory
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RID
focusedID forall a. Eq a => a -> a -> Bool
== RID
myID Bool -> Bool -> Bool
|| RID
focusedID forall a. Eq a => a -> a -> Bool
== RID
otherID) forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
m ()
flagRedraw

        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s Cont
k
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Equip -> case [Value]
vs of
      [VText Text
itemName] -> do
        Entity
item <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Text -> Text -> m Entity
ensureItem Text
itemName Text
"equip"
        RID
myID <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot RID
robotID
        RID
focusedID <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter GameState RID
focusedRobotID
        -- Don't do anything if the robot already has the device.
        Bool
already <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use (Lens' Robot Inventory
equippedDevices forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to (Inventory -> Entity -> Bool
`E.contains` Entity
item))
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
already forall a b. (a -> b) -> a -> b
$ do
          Lens' Robot Inventory
equippedDevices forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= Entity -> Inventory -> Inventory
insert Entity
item
          Lens' Robot Inventory
robotInventory forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= Entity -> Inventory -> Inventory
delete Entity
item

          -- Flag the UI for a redraw if we are currently showing our inventory
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RID
focusedID forall a. Eq a => a -> a -> Bool
== RID
myID) forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
m ()
flagRedraw

        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s Cont
k
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Unequip -> case [Value]
vs of
      [VText Text
itemName] -> do
        Entity
item <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Text -> m Entity
ensureEquipped Text
itemName
        RID
myID <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot RID
robotID
        RID
focusedID <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter GameState RID
focusedRobotID
        Lens' Robot Inventory
equippedDevices forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= Entity -> Inventory -> Inventory
delete Entity
item
        Lens' Robot Inventory
robotInventory forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= Entity -> Inventory -> Inventory
insert Entity
item
        -- Flag the UI for a redraw if we are currently showing our inventory
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RID
focusedID forall a. Eq a => a -> a -> Bool
== RID
myID) forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
m ()
flagRedraw
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s Cont
k
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Make -> case [Value]
vs of
      [VText Text
name] -> do
        Inventory
inv <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot Inventory
robotInventory
        Inventory
ins <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot Inventory
equippedDevices
        EntityMap
em <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use forall a b. (a -> b) -> a -> b
$ Lens' GameState Landscape
landscape forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Landscape EntityMap
entityMap
        Entity
e <-
          Text -> EntityMap -> Maybe Entity
lookupEntityName Text
name EntityMap
em
            forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Maybe a -> [Text] -> m a
`isJustOrFail` [Text
"I've never heard of", Text -> Text
indefiniteQ Text
name forall a. Semigroup a => a -> a -> a
<> Text
"."]

        IntMap [Recipe Entity]
outRs <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use forall a b. (a -> b) -> a -> b
$ Lens' GameState Recipes
recipesInfo forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Recipes (IntMap [Recipe Entity])
recipesOut

        Bool
creative <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' GameState Bool
creativeMode
        let create :: [Text] -> [Text]
create [Text]
l = [Text]
l forall a. Semigroup a => a -> a -> a
<> [Text
"You can use 'create \"" forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
"\"' instead." | Bool
creative]

        -- Only consider recipes where the number of things we are trying to make
        -- is greater in the outputs than in the inputs.  This prevents us from doing
        -- silly things like making copper pipes when the user says "make furnace".
        let recipes :: [Recipe Entity]
recipes = forall a. (a -> Bool) -> [a] -> [a]
filter Recipe Entity -> Bool
increase (IntMap [Recipe Entity] -> Entity -> [Recipe Entity]
recipesFor IntMap [Recipe Entity]
outRs Entity
e)
            increase :: Recipe Entity -> Bool
increase Recipe Entity
r = forall {b} {t :: * -> *}. (Num b, Foldable t) => t (b, Entity) -> b
countIn (Recipe Entity
r forall s a. s -> Getting a s a -> a
^. forall e. Lens' (Recipe e) (IngredientList e)
recipeOutputs) forall a. Ord a => a -> a -> Bool
> forall {b} {t :: * -> *}. (Num b, Foldable t) => t (b, Entity) -> b
countIn (Recipe Entity
r forall s a. s -> Getting a s a -> a
^. forall e. Lens' (Recipe e) (IngredientList e)
recipeInputs)
            countIn :: t (b, Entity) -> b
countIn t (b, Entity)
xs = forall b a. b -> (a -> b) -> Maybe a -> b
maybe b
0 forall a b. (a, b) -> a
fst (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((forall a. Eq a => a -> a -> Bool
== Entity
e) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) t (b, Entity)
xs)
        Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Recipe Entity]
recipes)
          forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Bool -> [Text] -> m ()
`holdsOrFail` [Text] -> [Text]
create [Text
"There is no known recipe for making", Text -> Text
indefinite Text
name forall a. Semigroup a => a -> a -> a
<> Text
"."]

        let displayMissingCount :: a -> MissingType -> target
displayMissingCount a
mc = \case
              MissingType
MissingInput -> forall source target. From source target => source -> target
from (forall a. Show a => a -> String
show a
mc)
              MissingType
MissingCatalyst -> target
"not equipped"
            displayMissingIngredient :: MissingIngredient -> Text
displayMissingIngredient (MissingIngredient MissingType
mk RID
mc Entity
me) =
              Text
"  - " forall a. Semigroup a => a -> a -> a
<> Entity
me forall s a. s -> Getting a s a -> a
^. Lens' Entity Text
entityName forall a. Semigroup a => a -> a -> a
<> Text
" (" forall a. Semigroup a => a -> a -> a
<> forall {target} {a}.
(From String target, Show a, IsString target) =>
a -> MissingType -> target
displayMissingCount RID
mc MissingType
mk forall a. Semigroup a => a -> a -> a
<> Text
")"
            displayMissingIngredients :: [[MissingIngredient]] -> [Text]
displayMissingIngredients [[MissingIngredient]]
xs = forall a. [a] -> [[a]] -> [a]
L.intercalate [Text
"OR"] (forall a b. (a -> b) -> [a] -> [b]
map MissingIngredient -> Text
displayMissingIngredient forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[MissingIngredient]]
xs)

        -- Try recipes and make a weighted random choice among the
        -- ones we have ingredients for.
        let ([[MissingIngredient]]
badRecipes, [(Inventory, [(RID, Entity)], Recipe Entity)]
goodRecipes) = forall a b. [Either a b] -> ([a], [b])
partitionEithers forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map ((Inventory, Inventory)
-> Recipe Entity
-> Either
     [MissingIngredient] (Inventory, [(RID, Entity)], Recipe Entity)
make (Inventory
inv, Inventory
ins)) forall a b. (a -> b) -> a -> b
$ [Recipe Entity]
recipes
        Maybe (Inventory, [(RID, Entity)], Recipe Entity)
chosenRecipe <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (State GameState) sig m =>
(a -> Integer) -> [a] -> m (Maybe a)
weightedChoice (forall s a. s -> Getting a s a -> a
^. forall s t a b. Field3 s t a b => Lens s t a b
_3 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Lens' (Recipe e) Integer
recipeWeight) [(Inventory, [(RID, Entity)], Recipe Entity)]
goodRecipes
        (Inventory
invTaken, [(RID, Entity)]
changeInv, Recipe Entity
recipe) <-
          Maybe (Inventory, [(RID, Entity)], Recipe Entity)
chosenRecipe
            forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Maybe a -> [Text] -> m a
`isJustOrFail` [Text] -> [Text]
create
              [ Text
"You don't have the ingredients to make"
              , Text -> Text
indefinite Text
name forall a. Semigroup a => a -> a -> a
<> Text
"."
              , Text
"Missing:\n" forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.unlines ([[MissingIngredient]] -> [Text]
displayMissingIngredients [[MissingIngredient]]
badRecipes)
              ]

        -- take recipe inputs from inventory and add outputs after recipeTime
        Lens' Robot Inventory
robotInventory forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= Inventory
invTaken
        forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Entity -> m ()
updateDiscoveredEntities forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) (Recipe Entity
recipe forall s a. s -> Getting a s a -> a
^. forall e. Lens' (Recipe e) (IngredientList e)
recipeOutputs)
        forall (sig :: (* -> *) -> * -> *) (m :: * -> *) e.
HasRobotStepState sig m =>
Recipe e
-> Value -> [WorldUpdate Entity] -> [RobotUpdate] -> m CESK
finishCookingRecipe Recipe Entity
recipe Value
VUnit [] (forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry RID -> Entity -> RobotUpdate
AddEntity) [(RID, Entity)]
changeInv)
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Has -> case [Value]
vs of
      [VText Text
name] -> do
        Inventory
inv <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot Inventory
robotInventory
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Bool -> Value
VBool ((forall a. Ord a => a -> a -> Bool
> RID
0) forall a b. (a -> b) -> a -> b
$ Text -> Inventory -> RID
countByName Text
name Inventory
inv)) Store
s Cont
k
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Equipped -> case [Value]
vs of
      [VText Text
name] -> do
        Inventory
inv <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot Inventory
equippedDevices
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Bool -> Value
VBool ((forall a. Ord a => a -> a -> Bool
> RID
0) forall a b. (a -> b) -> a -> b
$ Text -> Inventory -> RID
countByName Text
name Inventory
inv)) Store
s Cont
k
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Count -> case [Value]
vs of
      [VText Text
name] -> do
        Inventory
inv <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot Inventory
robotInventory
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Integer -> Value
VInt (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Text -> Inventory -> RID
countByName Text
name Inventory
inv)) Store
s Cont
k
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Scout -> case [Value]
vs of
      [VDir Direction
d] -> do
        IntMap Robot
rMap <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' GameState (IntMap Robot)
robotMap
        Cosmic Location
myLoc <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot (Cosmic Location)
robotLocation
        Heading
heading <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Direction -> m Heading
deriveHeading Direction
d
        Map SubworldName (Map Location IntSet)
botsByLocs <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' GameState (Map SubworldName (Map Location IntSet))
robotsByLocation
        RID
selfRid <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot RID
robotID

        -- Includes the base location, so we exclude the base robot later.
        let locsInDirection :: [Cosmic Location]
            locsInDirection :: [Cosmic Location]
locsInDirection = forall a. RID -> [a] -> [a]
take RID
maxScoutRange forall a b. (a -> b) -> a -> b
$ forall a. (a -> a) -> a -> [a]
iterate (Cosmic Location -> Heading -> Cosmic Location
`offsetBy` Heading
heading) Cosmic Location
myLoc

        let hasOpaqueEntity :: Cosmic Location -> m Bool
hasOpaqueEntity =
              forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Entity -> EntityProperty -> Bool
`hasProperty` EntityProperty
E.Opaque)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
Cosmic Location -> m (Maybe Entity)
entityAt

        let hasVisibleBot :: Cosmic Location -> Bool
            hasVisibleBot :: Cosmic Location -> Bool
hasVisibleBot = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any RID -> Bool
botIsVisible forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntSet -> [RID]
IS.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntSet -> IntSet
excludeSelf forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cosmic Location -> IntSet
botsHere
             where
              excludeSelf :: IntSet -> IntSet
excludeSelf = (IntSet -> IntSet -> IntSet
`IS.difference` RID -> IntSet
IS.singleton RID
selfRid)
              botsHere :: Cosmic Location -> IntSet
botsHere (Cosmic SubworldName
swName Location
loc) =
                forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault forall a. Monoid a => a
mempty Location
loc forall a b. (a -> b) -> a -> b
$
                  forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault forall a. Monoid a => a
mempty SubworldName
swName Map SubworldName (Map Location IntSet)
botsByLocs
              botIsVisible :: RID -> Bool
botIsVisible = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False Robot -> Bool
canSee forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. RID -> IntMap a -> Maybe a
`IM.lookup` IntMap Robot
rMap)
              canSee :: Robot -> Bool
canSee = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall s a. s -> Getting a s a -> a
^. Lens' Robot Display
robotDisplay forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Display Bool
invisible)

        -- A robot on the same cell as an opaque entity is considered hidden.
        -- Returns (Just Bool) if the result is conclusively visible or opaque,
        -- or Nothing if we don't have a conclusive answer yet.
        let isConclusivelyVisible :: Bool -> Cosmic Location -> Maybe Bool
            isConclusivelyVisible :: Bool -> Cosmic Location -> Maybe Bool
isConclusivelyVisible Bool
isOpaque Cosmic Location
loc
              | Bool
isOpaque = forall a. a -> Maybe a
Just Bool
False
              | Cosmic Location -> Bool
hasVisibleBot Cosmic Location
loc = forall a. a -> Maybe a
Just Bool
True
              | Bool
otherwise = forall a. Maybe a
Nothing

        let isConclusivelyVisibleM :: Cosmic Location -> m (Maybe Bool)
isConclusivelyVisibleM Cosmic Location
loc = do
              Bool
opaque <- Cosmic Location -> m Bool
hasOpaqueEntity Cosmic Location
loc
              forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool -> Cosmic Location -> Maybe Bool
isConclusivelyVisible Bool
opaque Cosmic Location
loc

        -- This ensures that we only evaluate locations until
        -- a conclusive result is obtained, so we don't always
        -- have to inspect the maximum range of the command.
        Maybe Bool
result <- forall (f :: * -> *) (m :: * -> *) a b.
(Foldable f, Monad m) =>
(a -> m (Maybe b)) -> f a -> m (Maybe b)
firstJustM Cosmic Location -> m (Maybe Bool)
isConclusivelyVisibleM [Cosmic Location]
locsInDirection
        let foundBot :: Bool
foundBot = forall a. a -> Maybe a -> a
fromMaybe Bool
False Maybe Bool
result
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Bool -> Value
VBool Bool
foundBot) Store
s Cont
k
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Whereami -> do
      Cosmic Location
loc <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot (Cosmic Location)
robotLocation
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (forall a. Valuable a => a -> Value
asValue forall a b. (a -> b) -> a -> b
$ Cosmic Location
loc forall s a. s -> Getting a s a -> a
^. forall a1 a2. Lens (Cosmic a1) (Cosmic a2) a1 a2
planar) Store
s Cont
k
    Const
Waypoint -> case [Value]
vs of
      [VText Text
name, VInt Integer
idx] -> do
        Navigation (Map SubworldName) Location
lm <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use forall a b. (a -> b) -> a -> b
$ Lens' GameState Landscape
landscape forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Landscape (Navigation (Map SubworldName) Location)
worldNavigation
        Cosmic SubworldName
swName Location
_ <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot (Cosmic Location)
robotLocation
        case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Text -> WaypointName
WaypointName Text
name) forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault forall a. Monoid a => a
mempty SubworldName
swName forall a b. (a -> b) -> a -> b
$ forall (additionalDimension :: * -> *) portalExitLoc.
Navigation additionalDimension portalExitLoc
-> additionalDimension (Map WaypointName (NonEmpty Location))
waypoints Navigation (Map SubworldName) Location
lm of
          Maybe (NonEmpty Location)
Nothing -> forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Const -> Text -> Maybe GameplayAchievement -> Exn
CmdFailed Const
Waypoint ([Text] -> Text
T.unwords [Text
"No waypoint named", Text
name]) forall a. Maybe a
Nothing
          Just NonEmpty Location
wps -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (forall a. Valuable a => a -> Value
asValue (forall a. NonEmpty a -> RID
NE.length NonEmpty Location
wps, forall b a. Integral b => NonEmpty a -> b -> a
indexWrapNonEmpty NonEmpty Location
wps Integer
idx)) Store
s Cont
k
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Detect -> case [Value]
vs of
      [VText Text
name, VRect Integer
x1 Integer
y1 Integer
x2 Integer
y2] -> do
        Cosmic Location
loc <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot (Cosmic Location)
robotLocation
        let locs :: [Heading]
locs = Integer -> Integer -> Integer -> Integer -> [Heading]
rectCells Integer
x1 Integer
y1 Integer
x2 Integer
y2
        -- sort offsets by (Manhattan) distance so that we return the closest occurrence
        let sortedOffsets :: [Heading]
sortedOffsets = forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (\(V2 Int32
x Int32
y) -> forall a. Num a => a -> a
abs Int32
x forall a. Num a => a -> a -> a
+ forall a. Num a => a -> a
abs Int32
y) [Heading]
locs
        let f :: Heading -> m Bool
f = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False forall a b. (a -> b) -> a -> b
$ Text -> Entity -> Bool
isEntityNamed Text
name) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
Cosmic Location -> m (Maybe Entity)
entityAt forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cosmic Location -> Heading -> Cosmic Location
offsetBy Cosmic Location
loc
        Maybe Heading
firstOne <- forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Monad m) =>
(a -> m Bool) -> f a -> m (Maybe a)
findM Heading -> m Bool
f [Heading]
sortedOffsets
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (forall a. Valuable a => a -> Value
asValue Maybe Heading
firstOne) Store
s Cont
k
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Resonate -> case [Value]
vs of
      [VText Text
name, VRect Integer
x1 Integer
y1 Integer
x2 Integer
y2] -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(HasRobotStepState sig m, Has (Lift IO) sig m) =>
(Maybe Entity -> Bool)
-> Integer -> Integer -> Integer -> Integer -> m CESK
doResonate (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False forall a b. (a -> b) -> a -> b
$ Text -> Entity -> Bool
isEntityNamed Text
name) Integer
x1 Integer
y1 Integer
x2 Integer
y2
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Density -> case [Value]
vs of
      [VRect Integer
x1 Integer
y1 Integer
x2 Integer
y2] -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(HasRobotStepState sig m, Has (Lift IO) sig m) =>
(Maybe Entity -> Bool)
-> Integer -> Integer -> Integer -> Integer -> m CESK
doResonate forall a. Maybe a -> Bool
isJust Integer
x1 Integer
y1 Integer
x2 Integer
y2
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Sniff -> case [Value]
vs of
      [VText Text
name] -> do
        Maybe (Int32, Heading)
firstFound <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Text -> m (Maybe (Int32, Heading))
findNearest Text
name
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (forall a. Valuable a => a -> Value
asValue forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe (-Int32
1) forall a b. (a, b) -> a
fst Maybe (Int32, Heading)
firstFound) Store
s Cont
k
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Watch -> case [Value]
vs of
      [VDir Direction
d] -> do
        (Cosmic Location
loc, Maybe Entity
_me) <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Direction -> m (Cosmic Location, Maybe Entity)
lookInDirection Direction
d
        forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Cosmic Location -> m ()
addWatchedLocation Cosmic Location
loc
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s Cont
k
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Surveil -> case [Value]
vs of
      [VPair (VInt Integer
x) (VInt Integer
y)] -> do
        Cosmic SubworldName
swName Location
_ <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot (Cosmic Location)
robotLocation
        let loc :: Cosmic Location
loc = forall a. SubworldName -> a -> Cosmic a
Cosmic SubworldName
swName forall a b. (a -> b) -> a -> b
$ Int32 -> Int32 -> Location
Location (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
x) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
y)
        forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Cosmic Location -> m ()
addWatchedLocation Cosmic Location
loc
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s Cont
k
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Chirp -> case [Value]
vs of
      [VText Text
name] -> do
        Maybe (Int32, Heading)
firstFound <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Text -> m (Maybe (Int32, Heading))
findNearest Text
name
        Maybe Heading
mh <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot (Maybe Heading)
robotOrientation
        Inventory
inst <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot Inventory
equippedDevices
        let processDirection :: AbsoluteDir -> Maybe Direction
processDirection AbsoluteDir
entityDir =
              if Text -> Inventory -> RID
countByName Text
"compass" Inventory
inst forall a. Ord a => a -> a -> Bool
>= RID
1
                then forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ AbsoluteDir -> Direction
DAbsolute AbsoluteDir
entityDir
                else case Maybe Heading
mh forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Heading -> Maybe Direction
toDirection of
                  Just (DAbsolute AbsoluteDir
robotDir) ->
                    forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. RelativeDir -> Direction
DRelative forall b c a. (b -> c) -> (a -> b) -> a -> c
. PlanarRelativeDir -> RelativeDir
DPlanar forall a b. (a -> b) -> a -> b
$ AbsoluteDir
entityDir AbsoluteDir -> AbsoluteDir -> PlanarRelativeDir
`relativeTo` AbsoluteDir
robotDir
                  Maybe Direction
_ -> forall a. Maybe a
Nothing -- This may happen if the robot is facing "down"
            val :: Value
val = Direction -> Value
VDir forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe (RelativeDir -> Direction
DRelative RelativeDir
DDown) forall a b. (a -> b) -> a -> b
$ do
              (Int32, Heading)
entLoc <- Maybe (Int32, Heading)
firstFound
              forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd (Int32, Heading)
entLoc forall a. Eq a => a -> a -> Bool
/= forall (f :: * -> *) a. (Additive f, Num a) => f a
zero
              AbsoluteDir -> Maybe Direction
processDirection forall b c a. (b -> c) -> (a -> b) -> a -> c
. Heading -> AbsoluteDir
nearestDirection forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ (Int32, Heading)
entLoc
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
val Store
s Cont
k
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Heading -> do
      Maybe Heading
mh <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot (Maybe Heading)
robotOrientation
      -- In general, (1) entities might not have an orientation, and
      -- (2) even if they do, orientation is a general vector, which
      -- might not correspond to a cardinal direction.  We could make
      -- 'heading' return a 'maybe dir' i.e. 'unit + dir', or return a
      -- vector of type 'int * int', but those would both be annoying
      -- for players in the vast majority of cases.  We rather choose
      -- to just return the direction 'down' in any case where we don't
      -- otherwise have anything reasonable to return.
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Direction -> Value
VDir (forall a. a -> Maybe a -> a
fromMaybe (RelativeDir -> Direction
DRelative RelativeDir
DDown) forall a b. (a -> b) -> a -> b
$ Maybe Heading
mh forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Heading -> Maybe Direction
toDirection)) Store
s Cont
k
    Const
Time -> do
      TickNumber Int64
t <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use forall a b. (a -> b) -> a -> b
$ Lens' GameState TemporalState
temporal forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' TemporalState TickNumber
ticks
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Integer -> Value
VInt forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
t) Store
s Cont
k
    Const
Drill -> case [Value]
vs of
      [VDir Direction
d] -> forall {sig :: (* -> *) -> * -> *} {m :: * -> *}.
(Algebra sig m, Member (Throw Exn) sig, Member (State Robot) sig,
 Member (State GameState) sig) =>
Direction -> m CESK
doDrill Direction
d
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Use -> case [Value]
vs of
      [VText Text
deviceName, VDir Direction
d] -> do
        Inventory
ins <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot Inventory
equippedDevices
        Entity
equippedEntity <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Text -> m Entity
ensureEquipped Text
deviceName
        let verbPhrase :: Text
verbPhrase = [Text] -> Text
T.unwords [Text
"use", Text
deviceName, Text
"on"]
        forall {sig :: (* -> *) -> * -> *} {m :: * -> *} {p}.
(Algebra sig m, Member (Throw Exn) sig, Member (State Robot) sig,
 Member (State GameState) sig, Eq p,
 Member (Reader (Recipe p)) (Reader (Recipe Entity))) =>
Inventory -> Text -> Direction -> p -> m CESK
applyDevice Inventory
ins Text
verbPhrase Direction
d Entity
equippedEntity
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Blocked -> do
      Cosmic Location
loc <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot (Cosmic Location)
robotLocation
      Maybe Heading
orient <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot (Maybe Heading)
robotOrientation
      let nextLoc :: Cosmic Location
nextLoc = Cosmic Location
loc Cosmic Location -> Heading -> Cosmic Location
`offsetBy` (Maybe Heading
orient forall a. Maybe a -> a -> a
? forall (f :: * -> *) a. (Additive f, Num a) => f a
zero)
      Maybe Entity
me <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
Cosmic Location -> m (Maybe Entity)
entityAt Cosmic Location
nextLoc
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Bool -> Value
VBool (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Entity -> EntityProperty -> Bool
`hasProperty` EntityProperty
Unwalkable) Maybe Entity
me)) Store
s Cont
k
    Const
Scan -> case [Value]
vs of
      [VDir Direction
d] -> do
        (Cosmic Location
_loc, Maybe Entity
me) <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Direction -> m (Cosmic Location, Maybe Entity)
lookInDirection Direction
d
        forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Entity
me forall a b. (a -> b) -> a -> b
$ \Entity
e -> do
          Lens' Robot Inventory
robotInventory forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= RID -> Entity -> Inventory -> Inventory
insertCount RID
0 Entity
e
          forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Entity -> m ()
updateDiscoveredEntities Entity
e
          -- Flag the world for a redraw since scanning something may
          -- change the way it is drawn (if the base is doing the
          -- scanning)
          forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
m ()
flagRedraw
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (forall a. Valuable a => a -> Value
asValue Maybe Entity
me) Store
s Cont
k
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Knows -> case [Value]
vs of
      [VText Text
name] -> do
        Inventory
inv <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot Inventory
robotInventory
        Inventory
ins <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot Inventory
equippedDevices
        let allKnown :: Inventory
allKnown = Inventory
inv Inventory -> Inventory -> Inventory
`E.union` Inventory
ins
        let knows :: Bool
knows = case Text -> Inventory -> [Entity]
E.lookupByName Text
name Inventory
allKnown of
              [] -> Bool
False
              [Entity]
_ -> Bool
True
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Bool -> Value
VBool Bool
knows) Store
s Cont
k
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Upload -> case [Value]
vs of
      [VRobot RID
otherID] -> do
        -- Make sure the other robot exists and is close
        Robot
_other <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
RID -> m Robot
getRobotWithinTouch RID
otherID

        -- Upload knowledge of everything in our inventory
        Inventory
inv <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot Inventory
robotInventory
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Inventory -> [(RID, Entity)]
elems Inventory
inv) forall a b. (a -> b) -> a -> b
$ \(RID
_, Entity
e) ->
          Lens' GameState (IntMap Robot)
robotMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at RID
otherID forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Robot Inventory
robotInventory forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= RID -> Entity -> Inventory -> Inventory
insertCount RID
0 Entity
e

        -- Upload our log
        Seq LogEntry
rlog <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot (Seq LogEntry)
robotLog
        Lens' GameState (IntMap Robot)
robotMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at RID
otherID forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Robot (Seq LogEntry)
robotLog forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(Has (State s) sig m, Semigroup a) =>
ASetter' s a -> a -> m ()
<>= Seq LogEntry
rlog

        -- Flag the world for redraw since uploading may change the
        -- base's knowledge and hence how entities are drawn (if they
        -- go from unknown to known).
        forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
m ()
flagRedraw

        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s Cont
k
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Random -> case [Value]
vs of
      [VInt Integer
hi] -> do
        Integer
n <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(Has (State GameState) sig m, UniformRange a) =>
(a, a) -> m a
uniform (Integer
0, Integer
hi forall a. Num a => a -> a -> a
- Integer
1)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Integer -> Value
VInt Integer
n) Store
s Cont
k
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Atomic -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
m CESK
goAtomic
    Const
Instant -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
m CESK
goAtomic
    Const
As -> case [Value]
vs of
      [VRobot RID
rid, Value
prog] -> do
        -- Get the named robot and current game state
        Robot
r <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
RID -> m (Maybe Robot)
robotWithID RID
rid forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Maybe a -> [Text] -> m a
`isJustOrFail` [Text
"There is no actor with ID", forall source target. From source target => source -> target
from (forall a. Show a => a -> String
show RID
rid)])
        GameState
g <- forall s (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
m s
get @GameState

        -- Execute the given program *hypothetically*: i.e. in a fresh
        -- CESK machine, using *copies* of the current store, robot
        -- and game state.  We discard the state afterwards so any
        -- modifications made by prog do not persist.  Note we also
        -- set the copied robot to be a "system" robot so it is
        -- capable of executing any commands; the As command
        -- already requires "God" capability.
        Value
v <-
          forall s (m :: * -> *) a. Functor m => s -> StateC s m a -> m a
evalState @Robot (Robot
r forall a b. a -> (a -> b) -> b
& Lens' Robot Bool
systemRobot forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
True) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. Functor m => s -> StateC s m a -> m a
evalState @GameState GameState
g forall a b. (a -> b) -> a -> b
$
            forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Lift IO) sig m, Has (Throw Exn) sig m,
 Has (State GameState) sig m, Has (State Robot) sig m) =>
CESK -> m Value
runCESK (Value -> Store -> Cont -> CESK
Out Value
prog Store
s [Value -> Frame
FApp (Const -> [Value] -> Value
VCApp Const
Force []), Frame
FExec])

        -- Return the value returned by the hypothetical command.
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
v Store
s Cont
k
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
RobotNamed -> case [Value]
vs of
      [VText Text
rname] -> do
        Robot
r <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
Text -> m (Maybe Robot)
robotWithName Text
rname forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Maybe a -> [Text] -> m a
`isJustOrFail` [Text
"There is no robot named", Text
rname])
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (forall a. Valuable a => a -> Value
asValue Robot
r) Store
s Cont
k
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
RobotNumbered -> case [Value]
vs of
      [VInt Integer
rid] -> do
        Robot
r <-
          forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
RID -> m (Maybe Robot)
robotWithID (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
rid)
            forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Maybe a -> [Text] -> m a
`isJustOrFail` [Text
"There is no robot with number", forall source target. From source target => source -> target
from (forall a. Show a => a -> String
show Integer
rid)])
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (forall a. Valuable a => a -> Value
asValue Robot
r) Store
s Cont
k
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Say -> case [Value]
vs of
      [VText Text
msg] -> do
        Bool
isPrivileged <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m) =>
m Bool
isPrivilegedBot
        Cosmic Location
loc <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot (Cosmic Location)
robotLocation

        -- current robot will be inserted into the robot set, so it needs the log
        LogEntry
m <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m) =>
RobotLogSource -> Severity -> Text -> m LogEntry
traceLog RobotLogSource
Said Severity
Info Text
msg
        forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
LogEntry -> m ()
emitMessage LogEntry
m
        let measureToLog :: Cosmic Location -> LogSource -> DistanceMeasure Int32
measureToLog Cosmic Location
robLoc = \case
              RobotLog RobotLogSource
_ RID
_ Cosmic Location
logLoc -> forall a b.
(a -> a -> b) -> Cosmic a -> Cosmic a -> DistanceMeasure b
cosmoMeasure Location -> Location -> Int32
manhattan Cosmic Location
robLoc Cosmic Location
logLoc
              LogSource
SystemLog -> forall b. b -> DistanceMeasure b
Measurable Int32
0
            addLatestClosest :: Cosmic Location -> Seq LogEntry -> Seq LogEntry
addLatestClosest Cosmic Location
rl = \case
              Seq LogEntry
Seq.Empty -> forall a. a -> Seq a
Seq.singleton LogEntry
m
              Seq LogEntry
es Seq.:|> LogEntry
e
                | LogEntry
e LogEntry -> LogEntry -> Bool
`isEarlierThan` LogEntry
m -> Seq LogEntry
es forall s a. Snoc s s a a => s -> a -> s
|> LogEntry
e forall s a. Snoc s s a a => s -> a -> s
|> LogEntry
m
                | LogEntry
e LogEntry -> LogEntry -> Bool
`isFartherThan` LogEntry
m -> Seq LogEntry
es forall s a. Snoc s s a a => s -> a -> s
|> LogEntry
m
                | Bool
otherwise -> Seq LogEntry
es forall s a. Snoc s s a a => s -> a -> s
|> LogEntry
e
             where
              isEarlierThan :: LogEntry -> LogEntry -> Bool
isEarlierThan = forall a. Ord a => a -> a -> Bool
(<) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (forall s a. s -> Getting a s a -> a
^. Lens' LogEntry TickNumber
leTime)
              isFartherThan :: LogEntry -> LogEntry -> Bool
isFartherThan = forall a. Ord a => a -> a -> Bool
(>) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Cosmic Location -> LogSource -> DistanceMeasure Int32
measureToLog Cosmic Location
rl forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Reader r) sig m =>
Getting a r a -> m a
view Lens' LogEntry LogSource
leSource)
        let addToRobotLog :: (Has (State GameState) sgn m) => Robot -> m ()
            addToRobotLog :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
Robot -> m ()
addToRobotLog Robot
r = do
              Maybe (RID, Cosmic Location)
maybeRidLoc <- forall s (m :: * -> *) a. Functor m => s -> StateC s m a -> m a
evalState Robot
r forall a b. (a -> b) -> a -> b
$ do
                Bool
hasLog <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State Robot) sig m, Has (State GameState) sig m) =>
Capability -> m Bool
hasCapability Capability
CLog
                Bool
hasListen <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State Robot) sig m, Has (State GameState) sig m) =>
Capability -> m Bool
hasCapability Capability
CListen
                Cosmic Location
loc' <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot (Cosmic Location)
robotLocation
                RID
rid <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot RID
robotID
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ do
                  forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Bool
hasLog Bool -> Bool -> Bool
&& Bool
hasListen
                  forall a. a -> Maybe a
Just (RID
rid, Cosmic Location
loc')
              forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (RID, Cosmic Location)
maybeRidLoc forall a b. (a -> b) -> a -> b
$ \(RID
rid, Cosmic Location
loc') ->
                Lens' GameState (IntMap Robot)
robotMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at RID
rid forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Robot (Seq LogEntry)
robotLog forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= Cosmic Location -> Seq LogEntry -> Seq LogEntry
addLatestClosest Cosmic Location
loc'
        [Robot]
robotsAround <-
          if Bool
isPrivileged
            then forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use forall a b. (a -> b) -> a -> b
$ Lens' GameState (IntMap Robot)
robotMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to forall a. IntMap a -> [a]
IM.elems
            else forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (State s) sig m =>
(s -> a) -> m a
gets forall a b. (a -> b) -> a -> b
$ Cosmic Location -> Int32 -> GameState -> [Robot]
robotsInArea Cosmic Location
loc forall i. Num i => i
hearingDistance
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
Robot -> m ()
addToRobotLog [Robot]
robotsAround
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s Cont
k
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Listen -> do
      GameState
gs <- forall s (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
m s
get @GameState
      Cosmic Location
loc <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot (Cosmic Location)
robotLocation
      RID
rid <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot RID
robotID
      Bool
isPrivileged <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m) =>
m Bool
isPrivilegedBot
      Seq LogEntry
mq <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use forall a b. (a -> b) -> a -> b
$ Lens' GameState Messages
messageInfo forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Messages (Seq LogEntry)
messageQueue
      let isClose :: LogEntry -> Bool
isClose LogEntry
e = Bool
isPrivileged Bool -> Bool -> Bool
|| Cosmic Location -> LogEntry -> Bool
messageIsFromNearby Cosmic Location
loc LogEntry
e
          notMine :: LogEntry -> Bool
notMine LogEntry
e = case LogEntry
e forall s a. s -> Getting a s a -> a
^. Lens' LogEntry LogSource
leSource of
            SystemLog {} -> Bool
False
            RobotLog RobotLogSource
_ RID
lrid Cosmic Location
_ -> RID
rid forall a. Eq a => a -> a -> Bool
/= RID
lrid
          limitLast :: Seq LogEntry -> Maybe Text
limitLast = \case
            Seq LogEntry
_s Seq.:|> LogEntry
l -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ LogEntry
l forall s a. s -> Getting a s a -> a
^. Lens' LogEntry Text
leText
            Seq LogEntry
_ -> forall a. Maybe a
Nothing
          mm :: Maybe Text
mm = Seq LogEntry -> Maybe Text
limitLast forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> Seq a -> Seq a
Seq.filter (forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Bool -> Bool -> Bool
(&&) LogEntry -> Bool
notMine LogEntry -> Bool
isClose) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> Seq a -> Seq a
Seq.takeWhileR (GameState -> LogEntry -> Bool
messageIsRecent GameState
gs) Seq LogEntry
mq
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe
          (Term -> Env -> Store -> Cont -> CESK
In (forall ty. Const -> Term' ty
TConst Const
Listen) forall a. Monoid a => a
mempty Store
s (Frame
FExec forall a. a -> [a] -> [a]
: Cont
k)) -- continue listening
          (\Text
m -> Value -> Store -> Cont -> CESK
Out (Text -> Value
VText Text
m) Store
s Cont
k) -- return found message
          Maybe Text
mm
    Const
Log -> case [Value]
vs of
      [VText Text
msg] -> do
        forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m) =>
RobotLogSource -> Severity -> Text -> m LogEntry
traceLog RobotLogSource
Logged Severity
Info Text
msg
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s Cont
k
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
View -> case [Value]
vs of
      [VRobot RID
rid] -> do
        -- Only the base can actually change the view in the UI.  Other robots can
        -- execute this command but it does nothing (at least for now).
        RID
rn <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot RID
robotID
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RID
rn forall a. Eq a => a -> a -> Bool
== RID
0) forall a b. (a -> b) -> a -> b
$
          forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
RID -> m (Maybe Robot)
robotWithID RID
rid forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            -- If the robot does not exist...
            Maybe Robot
Nothing -> do
              Bool
cr <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' GameState Bool
creativeMode
              Bool
ws <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use forall a b. (a -> b) -> a -> b
$ Lens' GameState Landscape
landscape forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Landscape Bool
worldScrollable
              case Bool
cr Bool -> Bool -> Bool
|| Bool
ws of
                -- If we are in creative mode or allowed to scroll, then we are allowed
                -- to learn that the robot doesn't exist.
                Bool
True -> forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Const -> [Text] -> Exn
cmdExn Const
c [Text
"There is no actor with ID", forall source target. From source target => source -> target
from (forall a. Show a => a -> String
show RID
rid), Text
"to view."]
                -- Otherwise, "unfocus" from any robot, which
                -- means the world view will turn to static.  The
                -- point is that there's no way to tell the difference
                -- between this situation and the situation where the
                -- robot exists but is too far away.
                Bool
False -> forall s (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
(s -> s) -> m ()
modify GameState -> GameState
unfocus

            -- If it does exist, set it as the view center.
            Just Robot
_ -> Lens' GameState ViewCenterRule
viewCenterRule forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= RID -> ViewCenterRule
VCRobot RID
rid

        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s Cont
k
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Appear -> case [Value]
vs of
      [VText Text
app] -> do
        forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
m ()
flagRedraw
        case forall target source. From source target => source -> target
into @String Text
app of
          [Char
dc] -> do
            Lens' Robot Display
robotDisplay forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Display Char
defaultChar forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= Char
dc
            Lens' Robot Display
robotDisplay forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Display (Map AbsoluteDir Char)
orientationMap forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= forall k a. Map k a
M.empty
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s Cont
k
          [Char
dc, Char
nc, Char
ec, Char
sc, Char
wc] -> do
            Lens' Robot Display
robotDisplay forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Display Char
defaultChar forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= Char
dc
            Lens' Robot Display
robotDisplay forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Display (Map AbsoluteDir Char)
orientationMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix AbsoluteDir
DNorth forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= Char
nc
            Lens' Robot Display
robotDisplay forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Display (Map AbsoluteDir Char)
orientationMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix AbsoluteDir
DEast forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= Char
ec
            Lens' Robot Display
robotDisplay forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Display (Map AbsoluteDir Char)
orientationMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix AbsoluteDir
DSouth forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= Char
sc
            Lens' Robot Display
robotDisplay forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Display (Map AbsoluteDir Char)
orientationMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix AbsoluteDir
DWest forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= Char
wc
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s Cont
k
          String
_other -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Const -> [Text] -> m a
raise Const
Appear [Text -> Text
quote Text
app, Text
"is not a valid appearance string. 'appear' must be given a string with exactly 1 or 5 characters."]
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Create -> case [Value]
vs of
      [VText Text
name] -> do
        EntityMap
em <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use forall a b. (a -> b) -> a -> b
$ Lens' GameState Landscape
landscape forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Landscape EntityMap
entityMap
        Entity
e <-
          Text -> EntityMap -> Maybe Entity
lookupEntityName Text
name EntityMap
em
            forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Maybe a -> [Text] -> m a
`isJustOrFail` [Text
"I've never heard of", Text -> Text
indefiniteQ Text
name forall a. Semigroup a => a -> a -> a
<> Text
"."]

        Lens' Robot Inventory
robotInventory forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= Entity -> Inventory -> Inventory
insert Entity
e
        forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Entity -> m ()
updateDiscoveredEntities Entity
e

        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s Cont
k
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Halt -> case [Value]
vs of
      [VRobot RID
targetID] -> do
        RID
myID <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot RID
robotID
        case RID
myID forall a. Eq a => a -> a -> Bool
== RID
targetID of
          -- To halt ourselves, just return a cancelled CESK machine.
          -- It will be reinstalled as our current machine; then,
          -- based on the fact that our CESK machine is done we will
          -- be put to sleep and the REPL will be reset if we are the
          -- base robot.
          Bool
True -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ CESK -> CESK
cancel forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s Cont
k
          Bool
False -> do
            -- Make sure the other robot exists and is close enough.
            Robot
target <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
RID -> m Robot
getRobotWithinTouch RID
targetID
            -- Make sure either we are privileged, OR the target robot
            -- is NOT.  In other words unprivileged bots should not be
            -- able to halt privileged ones.
            Bool
omni <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m) =>
m Bool
isPrivilegedBot
            case Bool
omni Bool -> Bool -> Bool
|| Bool -> Bool
not (Robot
target forall s a. s -> Getting a s a -> a
^. Lens' Robot Bool
systemRobot) of
              Bool
True -> do
                -- Cancel its CESK machine, and put it to sleep.
                Lens' GameState (IntMap Robot)
robotMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at RID
targetID forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Robot CESK
machine forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= CESK -> CESK
cancel
                forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
RID -> m ()
sleepForever RID
targetID
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s Cont
k
              Bool
False -> forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Const -> [Text] -> Exn
cmdExn Const
c [Text
"You are not authorized to halt that robot."]
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Ishere -> case [Value]
vs of
      [VText Text
name] -> do
        Cosmic Location
loc <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot (Cosmic Location)
robotLocation
        Maybe Entity
me <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
Cosmic Location -> m (Maybe Entity)
entityAt Cosmic Location
loc
        let here :: Bool
here = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Text -> Entity -> Bool
isEntityNamed Text
name) Maybe Entity
me
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Bool -> Value
VBool Bool
here) Store
s Cont
k
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Isempty -> do
      Cosmic Location
loc <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot (Cosmic Location)
robotLocation
      Maybe Entity
me <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
Cosmic Location -> m (Maybe Entity)
entityAt Cosmic Location
loc
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Bool -> Value
VBool (forall a. Maybe a -> Bool
isNothing Maybe Entity
me)) Store
s Cont
k
    Const
Self -> do
      RID
rid <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot RID
robotID
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (RID -> Value
VRobot RID
rid) Store
s Cont
k
    Const
Parent -> do
      Maybe RID
mp <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot (Maybe RID)
robotParentID
      RID
rid <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot RID
robotID
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (RID -> Value
VRobot (forall a. a -> Maybe a -> a
fromMaybe RID
rid Maybe RID
mp)) Store
s Cont
k
    Const
Base -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (RID -> Value
VRobot RID
0) Store
s Cont
k
    Const
Meet -> do
      Cosmic Location
loc <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot (Cosmic Location)
robotLocation
      RID
rid <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot RID
robotID
      GameState
g <- forall s (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
m s
get @GameState
      let neighbor :: Maybe Robot
neighbor =
            forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((forall a. Eq a => a -> a -> Bool
/= RID
rid) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall s a. s -> Getting a s a -> a
^. Getter Robot RID
robotID)) -- pick one other than ourself
              forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn ((Location -> Location -> Int32
manhattan forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall r a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Reader r) sig m =>
Getting a r a -> m a
view forall a1 a2. Lens (Cosmic a1) (Cosmic a2) a1 a2
planar) Cosmic Location
loc forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall s a. s -> Getting a s a -> a
^. Getter Robot (Cosmic Location)
robotLocation)) -- prefer closer
              forall a b. (a -> b) -> a -> b
$ Cosmic Location -> Int32 -> GameState -> [Robot]
robotsInArea Cosmic Location
loc Int32
1 GameState
g -- all robots within Manhattan distance 1
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (forall a. Valuable a => a -> Value
asValue Maybe Robot
neighbor) Store
s Cont
k
    Const
MeetAll -> case [Value]
vs of
      [Value
f, Value
b] -> do
        Cosmic Location
loc <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot (Cosmic Location)
robotLocation
        RID
rid <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot RID
robotID
        GameState
g <- forall s (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
m s
get @GameState
        let neighborIDs :: [RID]
neighborIDs = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= RID
rid) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall s a. s -> Getting a s a -> a
^. Getter Robot RID
robotID) forall a b. (a -> b) -> a -> b
$ Cosmic Location -> Int32 -> GameState -> [Robot]
robotsInArea Cosmic Location
loc Int32
1 GameState
g
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
b Store
s (Value -> [RID] -> Frame
FMeetAll Value
f [RID]
neighborIDs forall a. a -> [a] -> [a]
: Cont
k)
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Whoami -> case [Value]
vs of
      [] -> do
        Text
name <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot Text
robotName
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Text -> Value
VText Text
name) Store
s Cont
k
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Setname -> case [Value]
vs of
      [VText Text
name] -> do
        Lens' Robot Text
robotName forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= Text
name
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s Cont
k
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Force -> case [Value]
vs of
      [VDelay Term
t Env
e] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Term -> Env -> Store -> Cont -> CESK
In Term
t Env
e Store
s Cont
k
      [VRef RID
loc] ->
        -- To force a VRef, we look up the location in the store.
        case RID -> Store -> Maybe MemCell
lookupStore RID
loc Store
s of
          -- If there's no cell at that location, it's a bug!  It
          -- shouldn't be possible to get a VRef to a non-existent
          -- location, since the only way VRefs get created is at the
          -- time we allocate a new cell.
          Maybe MemCell
Nothing ->
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
              Exn -> Store -> Cont -> CESK
Up (Text -> Exn
Fatal forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text
T.append Text
"Reference to unknown memory cell " (forall source target. From source target => source -> target
from (forall a. Show a => a -> String
show RID
loc))) Store
s Cont
k
          -- If the location contains an unevaluated expression, it's
          -- time to evaluate it.  Set the cell to a 'Blackhole', push
          -- an 'FUpdate' frame so we remember to update the location
          -- to its value once we finish evaluating it, and focus on
          -- the expression.
          Just (E Term
t Env
e') -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Term -> Env -> Store -> Cont -> CESK
In Term
t Env
e' (RID -> MemCell -> Store -> Store
setStore RID
loc (Term -> Env -> MemCell
Blackhole Term
t Env
e') Store
s) (RID -> Frame
FUpdate RID
loc forall a. a -> [a] -> [a]
: Cont
k)
          -- If the location contains a Blackhole, that means we are
          -- already currently in the middle of evaluating it, i.e. it
          -- depends on itself, so throw an 'InfiniteLoop' error.
          Just Blackhole {} -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exn -> Store -> Cont -> CESK
Up Exn
InfiniteLoop Store
s Cont
k
          -- If the location already contains a value, just return it.
          Just (V Value
v) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
v Store
s Cont
k
      -- If a force is applied to any other kind of value, just ignore it.
      -- This is needed because of the way we wrap all free variables in @force@
      -- in case they come from a @def@ which are always wrapped in @delay@.
      -- But binders (i.e. @x <- ...@) are also exported to the global context.
      [Value
v] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
v Store
s Cont
k
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
If -> case [Value]
vs of
      -- Use the boolean to pick the correct branch, and apply @force@ to it.
      [VBool Bool
b, Value
thn, Value
els] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (forall a. a -> a -> Bool -> a
bool Value
els Value
thn Bool
b) Store
s (Value -> Frame
FApp (Const -> [Value] -> Value
VCApp Const
Force []) forall a. a -> [a] -> [a]
: Cont
k)
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Inl -> case [Value]
vs of
      [Value
v] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Bool -> Value -> Value
VInj Bool
False Value
v) Store
s Cont
k
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Inr -> case [Value]
vs of
      [Value
v] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Bool -> Value -> Value
VInj Bool
True Value
v) Store
s Cont
k
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Case -> case [Value]
vs of
      [VInj Bool
side Value
v, Value
kl, Value
kr] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
v Store
s (Value -> Frame
FApp (forall a. a -> a -> Bool -> a
bool Value
kl Value
kr Bool
side) forall a. a -> [a] -> [a]
: Cont
k)
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Fst -> case [Value]
vs of
      [VPair Value
v Value
_] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
v Store
s Cont
k
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Snd -> case [Value]
vs of
      [VPair Value
_ Value
v] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
v Store
s Cont
k
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Try -> case [Value]
vs of
      [Value
c1, Value
c2] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
c1 Store
s (Value -> Frame
FApp (Const -> [Value] -> Value
VCApp Const
Force []) forall a. a -> [a] -> [a]
: Frame
FExec forall a. a -> [a] -> [a]
: Value -> Frame
FTry Value
c2 forall a. a -> [a] -> [a]
: Cont
k)
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Undefined -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exn -> Store -> Cont -> CESK
Up (Text -> Exn
User Text
"undefined") Store
s Cont
k
    Const
Fail -> case [Value]
vs of
      [VText Text
msg] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exn -> Store -> Cont -> CESK
Up (Text -> Exn
User Text
msg) Store
s Cont
k
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Key -> case [Value]
vs of
      [VText Text
ktxt] -> case forall a. Parser a -> Text -> Either Text a
runParser Parser KeyCombo
parseKeyComboFull Text
ktxt of
        Right KeyCombo
kc -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (KeyCombo -> Value
VKey KeyCombo
kc) Store
s Cont
k
        Left Text
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exn -> Store -> Cont -> CESK
Up (Const -> Text -> Maybe GameplayAchievement -> Exn
CmdFailed Const
Key ([Text] -> Text
T.unwords [Text
"Unknown key", Text -> Text
quote Text
ktxt]) forall a. Maybe a
Nothing) Store
s Cont
k
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
InstallKeyHandler -> case [Value]
vs of
      [VText Text
hint, Value
handler] -> do
        Lens' GameState GameControls
gameControls forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' GameControls (Maybe (Text, Value))
inputHandler forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= forall a. a -> Maybe a
Just (Text
hint, Value
handler)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s Cont
k
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Reprogram -> case [Value]
vs of
      [VRobot RID
childRobotID, VDelay Term
cmd Env
e] -> do
        Robot
r <- forall s (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
m s
get
        Bool
isPrivileged <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m) =>
m Bool
isPrivilegedBot

        -- check if robot exists
        Robot
childRobot <-
          forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
RID -> m (Maybe Robot)
robotWithID RID
childRobotID
            forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Maybe a -> [Text] -> m a
`isJustOrFail` [Text
"There is no actor with ID", forall source target. From source target => source -> target
from (forall a. Show a => a -> String
show RID
childRobotID) forall a. Semigroup a => a -> a -> a
<> Text
"."])

        -- check that current robot is not trying to reprogram self
        RID
myID <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot RID
robotID
        (RID
childRobotID forall a. Eq a => a -> a -> Bool
/= RID
myID)
          forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Bool -> [Text] -> m ()
`holdsOrFail` [Text
"You cannot make a robot reprogram itself."]

        -- check if robot has completed executing it's current command
        (Value, Store)
_ <-
          CESK -> Maybe (Value, Store)
finalValue (Robot
childRobot forall s a. s -> Getting a s a -> a
^. Lens' Robot CESK
machine)
            forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Maybe a -> [Text] -> m a
`isJustOrFail` [Text
"You cannot reprogram a robot that is actively running a program."]

        -- check if childRobot is at the correct distance
        -- a robot can program adjacent robots
        -- privileged bots ignore distance checks
        Cosmic Location
loc <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot (Cosmic Location)
robotLocation

        Bool -> Cosmic Location -> Cosmic Location -> Bool
isNearbyOrExempt Bool
isPrivileged Cosmic Location
loc (Robot
childRobot forall s a. s -> Getting a s a -> a
^. Getter Robot (Cosmic Location)
robotLocation)
          forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Bool -> [Text] -> m ()
`holdsOrFail` [Text
"You can only reprogram an adjacent robot."]

        -- Figure out if we can supply what the target robot requires,
        -- and if so, what is needed.
        (Set Entity
toEquip, Inventory
toGive) <-
          forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Inventory
-> Inventory
-> Inventory
-> Term
-> Text
-> IncapableFix
-> m (Set Entity, Inventory)
checkRequirements
            (Robot
r forall s a. s -> Getting a s a -> a
^. Lens' Robot Inventory
robotInventory)
            (Robot
childRobot forall s a. s -> Getting a s a -> a
^. Lens' Robot Inventory
robotInventory)
            (Robot
childRobot forall s a. s -> Getting a s a -> a
^. Lens' Robot Inventory
equippedDevices)
            Term
cmd
            Text
"The target robot"
            IncapableFix
FixByObtain

        -- update other robot's CESK machine, environment and context
        -- the childRobot inherits the parent robot's environment
        -- and context which collectively mean all the variables
        -- declared in the parent robot
        Lens' GameState (IntMap Robot)
robotMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at RID
childRobotID forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Robot CESK
machine forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= Term -> Env -> Store -> Cont -> CESK
In Term
cmd Env
e Store
s [Frame
FExec]
        Lens' GameState (IntMap Robot)
robotMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at RID
childRobotID forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Robot RobotContext
robotContext forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= Robot
r forall s a. s -> Getting a s a -> a
^. Lens' Robot RobotContext
robotContext

        -- Provision the target robot with any required devices and
        -- inventory that are lacking.
        forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
RID -> Inventory -> Inventory -> m ()
provisionChild RID
childRobotID ([Entity] -> Inventory
fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
S.toList forall a b. (a -> b) -> a -> b
$ Set Entity
toEquip) Inventory
toGive

        -- Finally, re-activate the reprogrammed target robot.
        forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
RID -> m ()
activateRobot RID
childRobotID

        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s Cont
k
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Build -> case [Value]
vs of
      -- NOTE, pattern-matching on a VDelay here means we are
      -- /relying/ on the fact that 'Build' can only be given a
      -- /non-memoized/ delayed value.  If it were given a memoized
      -- delayed value we would see a VRef instead of a VDelay.  If
      -- and Try are generalized to handle any type of delayed value,
      -- but Build and Reprogram still assume they are given a VDelay
      -- and not a VRef.  In the future, if we enable memoized delays
      -- by default, or allow the user to explicitly request
      -- memoization via double braces or something similar, this will
      -- have to be generalized.  The difficulty is that we do a
      -- capability check on the delayed program at runtime, just
      -- before creating the newly built robot (see the call to
      -- 'requirements' below); but if we have a VRef instead of a
      -- VDelay, we may only be able to get a Value out of it instead
      -- of a Term as we currently do, and capability checking a Value
      -- is annoying and/or problematic.  One solution might be to
      -- annotate delayed expressions with their required capabilities
      -- at typechecking time, and carry those along so they flow to
      -- this point. Another solution would be to just bite the bullet
      -- and figure out how to do capability checking on Values (which
      -- would return the capabilities needed to *execute* them),
      -- hopefully without duplicating too much code.
      [VDelay Term
cmd Env
e] -> do
        Robot
r <- forall s (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
m s
get @Robot
        RID
pid <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot RID
robotID

        (Set Entity
toEquip, Inventory
toGive) <-
          forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Inventory
-> Inventory
-> Inventory
-> Term
-> Text
-> IncapableFix
-> m (Set Entity, Inventory)
checkRequirements (Robot
r forall s a. s -> Getting a s a -> a
^. Lens' Robot Inventory
robotInventory) Inventory
E.empty Inventory
E.empty Term
cmd Text
"You" IncapableFix
FixByObtain

        -- Pick a random display name.
        Text
displayName <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
m Text
randomName
        TimeSpec
createdAt <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Lift IO) sig m =>
m TimeSpec
getNow
        Bool
isSystemRobot <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot Bool
systemRobot

        -- Construct the new robot and add it to the world.
        RobotContext
parentCtx <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot RobotContext
robotContext
        Robot
newRobot <-
          forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
TRobot -> m Robot
addTRobot forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Lens' TRobot RobotContext
trobotContext forall s t a b. ASetter s t a b -> b -> s -> t
.~ RobotContext
parentCtx) forall a b. (a -> b) -> a -> b
$
            forall (phase :: RobotPhase).
RobotID phase
-> Maybe RID
-> Text
-> Document Syntax
-> RobotLocation phase
-> Heading
-> Display
-> CESK
-> [Entity]
-> [(RID, Entity)]
-> Bool
-> Bool
-> Set Text
-> TimeSpec
-> RobotR phase
mkRobot
              ()
              (forall a. a -> Maybe a
Just RID
pid)
              Text
displayName
              (Text -> Document Syntax
Markdown.fromText forall a b. (a -> b) -> a -> b
$ Text
"A robot built by the robot named " forall a. Semigroup a => a -> a -> a
<> (Robot
r forall s a. s -> Getting a s a -> a
^. Lens' Robot Text
robotName) forall a. Semigroup a => a -> a -> a
<> Text
".")
              (forall a. a -> Maybe a
Just (Robot
r forall s a. s -> Getting a s a -> a
^. Getter Robot (Cosmic Location)
robotLocation))
              ( ((Robot
r forall s a. s -> Getting a s a -> a
^. Lens' Robot (Maybe Heading)
robotOrientation) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Heading
dir -> forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Heading
dir forall a. Eq a => a -> a -> Bool
/= forall (f :: * -> *) a. (Additive f, Num a) => f a
zero) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Heading
dir)
                  forall a. Maybe a -> a -> a
? Heading
north
              )
              Display
defaultRobotDisplay
              (Term -> Env -> Store -> Cont -> CESK
In Term
cmd Env
e Store
s [Frame
FExec])
              []
              []
              Bool
isSystemRobot
              Bool
False
              forall a. Monoid a => a
mempty
              TimeSpec
createdAt

        -- Provision the new robot with the necessary devices and inventory.
        forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
RID -> Inventory -> Inventory -> m ()
provisionChild (Robot
newRobot forall s a. s -> Getting a s a -> a
^. Getter Robot RID
robotID) ([Entity] -> Inventory
fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
S.toList forall a b. (a -> b) -> a -> b
$ Set Entity
toEquip) Inventory
toGive

        -- Flag the world for a redraw and return the name of the newly constructed robot.
        forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
m ()
flagRedraw
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (forall a. Valuable a => a -> Value
asValue Robot
newRobot) Store
s Cont
k
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Salvage -> case [Value]
vs of
      [] -> do
        Cosmic Location
loc <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot (Cosmic Location)
robotLocation
        let okToSalvage :: Robot -> Bool
okToSalvage Robot
r = (Robot
r forall s a. s -> Getting a s a -> a
^. Getter Robot RID
robotID forall a. Eq a => a -> a -> Bool
/= RID
0) Bool -> Bool -> Bool
&& (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Robot -> Bool
isActive forall a b. (a -> b) -> a -> b
$ Robot
r)
        Maybe Robot
mtarget <- forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (State s) sig m =>
(s -> a) -> m a
gets (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find Robot -> Bool
okToSalvage forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cosmic Location -> GameState -> [Robot]
robotsAtLocation Cosmic Location
loc)
        case Maybe Robot
mtarget of
          Maybe Robot
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s Cont
k -- Nothing to salvage
          Just Robot
target -> do
            -- Copy the salvaged robot's equipped devices into its inventory, in preparation
            -- for transferring it.
            let salvageInventory :: Inventory
salvageInventory = Inventory -> Inventory -> Inventory
E.union (Robot
target forall s a. s -> Getting a s a -> a
^. Lens' Robot Inventory
robotInventory) (Robot
target forall s a. s -> Getting a s a -> a
^. Lens' Robot Inventory
equippedDevices)
            Lens' GameState (IntMap Robot)
robotMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at (Robot
target forall s a. s -> Getting a s a -> a
^. Getter Robot RID
robotID) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Robot Inventory
robotInventory forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= Inventory
salvageInventory

            let salvageItems :: [Text]
salvageItems = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(RID
n, Entity
e) -> forall a. RID -> a -> [a]
replicate RID
n (Entity
e forall s a. s -> Getting a s a -> a
^. Lens' Entity Text
entityName)) (Inventory -> [(RID, Entity)]
E.elems Inventory
salvageInventory)
                numItems :: RID
numItems = forall (t :: * -> *) a. Foldable t => t a -> RID
length [Text]
salvageItems

            -- Copy over the salvaged robot's log, if we have one
            Inventory
inst <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot Inventory
equippedDevices
            EntityMap
em <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use forall a b. (a -> b) -> a -> b
$ Lens' GameState Landscape
landscape forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Landscape EntityMap
entityMap
            Bool
isPrivileged <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m) =>
m Bool
isPrivilegedBot
            Entity
logger <-
              Text -> EntityMap -> Maybe Entity
lookupEntityName Text
"logger" EntityMap
em
                forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
Maybe a -> e -> m a
`isJustOr` Text -> Exn
Fatal Text
"While executing 'salvage': there's no such thing as a logger!?"
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
isPrivileged Bool -> Bool -> Bool
|| Inventory
inst Inventory -> Entity -> Bool
`E.contains` Entity
logger) forall a b. (a -> b) -> a -> b
$ Lens' Robot (Seq LogEntry)
robotLog forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(Has (State s) sig m, Semigroup a) =>
ASetter' s a -> a -> m ()
<>= Robot
target forall s a. s -> Getting a s a -> a
^. Lens' Robot (Seq LogEntry)
robotLog

            -- Immediately copy over any items the robot knows about
            -- but has 0 of
            let knownItems :: [Entity]
knownItems = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
== RID
0) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Inventory -> [(RID, Entity)]
elems forall a b. (a -> b) -> a -> b
$ Inventory
salvageInventory
            Lens' Robot Inventory
robotInventory forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= \Inventory
i -> forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (RID -> Entity -> Inventory -> Inventory
insertCount RID
0) Inventory
i [Entity]
knownItems

            -- Now reprogram the robot being salvaged to 'give' each
            -- item in its inventory to us, one at a time, then
            -- self-destruct at the end.  Make it a system robot so we
            -- don't have to worry about capabilities.
            Lens' GameState (IntMap Robot)
robotMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at (Robot
target forall s a. s -> Getting a s a -> a
^. Getter Robot RID
robotID) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Robot Bool
systemRobot forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= Bool
True

            RID
ourID <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use @Robot Getter Robot RID
robotID

            -- The program for the salvaged robot to run
            let giveInventory :: Term
giveInventory =
                  forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Maybe Text -> Term -> Term -> Term
TBind forall a. Maybe a
Nothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Term
giveItem) (forall ty. Const -> Term' ty
TConst Const
Selfdestruct) [Text]
salvageItems
                giveItem :: Text -> Term
giveItem Text
item = Term -> Term -> Term
TApp (Term -> Term -> Term
TApp (forall ty. Const -> Term' ty
TConst Const
Give) (forall ty. RID -> Term' ty
TRobot RID
ourID)) (forall ty. Text -> Term' ty
TText Text
item)

            -- Reprogram and activate the salvaged robot
            Lens' GameState (IntMap Robot)
robotMap
              forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at (Robot
target forall s a. s -> Getting a s a -> a
^. Getter Robot RID
robotID)
              forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
              forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Robot CESK
machine
              forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= Term -> Env -> Store -> Cont -> CESK
In Term
giveInventory forall t. Ctx t
empty Store
emptyStore [Frame
FExec]
            forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
RID -> m ()
activateRobot (Robot
target forall s a. s -> Getting a s a -> a
^. Getter Robot RID
robotID)

            -- Now wait the right amount of time for it to finish.
            TickNumber
time <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use forall a b. (a -> b) -> a -> b
$ Lens' GameState TemporalState
temporal forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' TemporalState TickNumber
ticks
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ TickNumber -> CESK -> CESK
Waiting (RID -> TickNumber -> TickNumber
addTicks (RID
numItems forall a. Num a => a -> a -> a
+ RID
1) TickNumber
time) (Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s Cont
k)
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    -- run can take both types of text inputs
    -- with and without file extension as in
    -- "./path/to/file.sw" and "./path/to/file"
    Const
Run -> case [Value]
vs of
      [VText Text
fileName] -> do
        let filePath :: String
filePath = forall target source. From source target => source -> target
into @String Text
fileName
        Maybe String
sData <- forall e (m :: * -> *) a. Functor m => ThrowC e m a -> m (Maybe a)
throwToMaybe @SystemFailure forall a b. (a -> b) -> a -> b
$ forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
AssetData -> String -> m String
getDataFileNameSafe AssetData
Script String
filePath
        Maybe String
sDataSW <- forall e (m :: * -> *) a. Functor m => ThrowC e m a -> m (Maybe a)
throwToMaybe @SystemFailure forall a b. (a -> b) -> a -> b
$ forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
AssetData -> String -> m String
getDataFileNameSafe AssetData
Script (String
filePath forall a. Semigroup a => a -> a -> a
<> String
".sw")
        [Maybe String]
mf <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Lift IO) sig m =>
IO a -> m a
sendIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO (Maybe String)
readFileMay forall a b. (a -> b) -> a -> b
$ [String
filePath, String
filePath forall a. Semigroup a => a -> a -> a
<> String
".sw"] forall a. Semigroup a => a -> a -> a
<> forall a. [Maybe a] -> [a]
catMaybes [Maybe String
sData, Maybe String
sDataSW]

        String
f <- forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum [Maybe String]
mf forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Maybe a -> [Text] -> m a
`isJustOrFail` [Text
"File not found:", Text
fileName]

        Maybe ProcessedTerm
mt <-
          Text -> Either Text (Maybe ProcessedTerm)
processTerm (forall target source. From source target => source -> target
into @Text String
f) forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) b a.
Has (Throw e) sig m =>
Either b a -> (b -> e) -> m a
`isRightOr` \Text
err ->
            Const -> [Text] -> Exn
cmdExn Const
Run [Text
"Error in", Text
fileName, Text
"\n", Text
err]

        case Maybe ProcessedTerm
mt of
          Maybe ProcessedTerm
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s Cont
k
          Just t :: ProcessedTerm
t@(ProcessedTerm TModule
_ Requirements
_ ReqCtx
reqCtx) -> do
            -- Add the reqCtx from the ProcessedTerm to the current robot's defReqs.
            -- See #827 for an explanation of (1) why this is needed, (2) why
            -- it's slightly technically incorrect, and (3) why it is still way
            -- better than what we had before.
            Lens' Robot RobotContext
robotContext forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' RobotContext ReqCtx
defReqs forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(Has (State s) sig m, Semigroup a) =>
ASetter' s a -> a -> m ()
<>= ReqCtx
reqCtx
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ProcessedTerm -> Env -> Store -> Cont -> CESK
initMachine' ProcessedTerm
t forall t. Ctx t
empty Store
s Cont
k
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Not -> case [Value]
vs of
      [VBool Bool
b] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Bool -> Value
VBool (Bool -> Bool
not Bool
b)) Store
s Cont
k
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Neg -> case [Value]
vs of
      [VInt Integer
n] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Integer -> Value
VInt (-Integer
n)) Store
s Cont
k
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Eq -> m CESK
returnEvalCmp
    Const
Neq -> m CESK
returnEvalCmp
    Const
Lt -> m CESK
returnEvalCmp
    Const
Gt -> m CESK
returnEvalCmp
    Const
Leq -> m CESK
returnEvalCmp
    Const
Geq -> m CESK
returnEvalCmp
    Const
And -> case [Value]
vs of
      [VBool Bool
a, VBool Bool
b] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Bool -> Value
VBool (Bool
a Bool -> Bool -> Bool
&& Bool
b)) Store
s Cont
k
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Or -> case [Value]
vs of
      [VBool Bool
a, VBool Bool
b] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Bool -> Value
VBool (Bool
a Bool -> Bool -> Bool
|| Bool
b)) Store
s Cont
k
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Add -> m CESK
returnEvalArith
    Const
Sub -> m CESK
returnEvalArith
    Const
Mul -> m CESK
returnEvalArith
    Const
Div -> m CESK
returnEvalArith
    Const
Exp -> m CESK
returnEvalArith
    Const
Format -> case [Value]
vs of
      [Value
v] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Text -> Value
VText (Value -> Text
prettyValue Value
v)) Store
s Cont
k
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Chars -> case [Value]
vs of
      [VText Text
t] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Integer -> Value
VInt (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Text -> RID
T.length Text
t)) Store
s Cont
k
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Split -> case [Value]
vs of
      [VInt Integer
i, VText Text
t] ->
        let p :: (Text, Text)
p = RID -> Text -> (Text, Text)
T.splitAt (forall a. Num a => Integer -> a
fromInteger Integer
i) Text
t
            t2 :: (Value, Value)
t2 = forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall (r :: * -> * -> *) a b.
Bitraversable r =>
Traversal (r a a) (r b b) a b
both Text -> Value
VText (Text, Text)
p
         in forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Value -> Value -> Value
VPair (Value, Value)
t2) Store
s Cont
k
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
Concat -> case [Value]
vs of
      [VText Text
v1, VText Text
v2] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Text -> Value
VText (Text
v1 forall a. Semigroup a => a -> a -> a
<> Text
v2)) Store
s Cont
k
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
CharAt -> case [Value]
vs of
      [VInt Integer
i, VText Text
t]
        | Integer
i forall a. Ord a => a -> a -> Bool
< Integer
0 Bool -> Bool -> Bool
|| Integer
i forall a. Ord a => a -> a -> Bool
>= forall a b. (Integral a, Num b) => a -> b
fromIntegral (Text -> RID
T.length Text
t) ->
            forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Const -> [Text] -> m a
raise Const
CharAt [Text
"Index", Value -> Text
prettyValue (Integer -> Value
VInt Integer
i), Text
"out of bounds for length", forall source target. From source target => source -> target
from @String forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show (Text -> RID
T.length Text
t)]
        | Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Integer -> Value
VInt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> RID
ord forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> RID -> Char
T.index Text
t forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Integer
i) Store
s Cont
k
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
ToChar -> case [Value]
vs of
      [VInt Integer
i]
        | Integer
i forall a. Ord a => a -> a -> Bool
< Integer
0 Bool -> Bool -> Bool
|| Integer
i forall a. Ord a => a -> a -> Bool
> forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> RID
ord (forall a. Bounded a => a
maxBound :: Char)) ->
            forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Const -> [Text] -> m a
raise Const
ToChar [Text
"Value", Value -> Text
prettyValue (Integer -> Value
VInt Integer
i), Text
"is an invalid character code"]
        | Bool
otherwise ->
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Text -> Value
VText forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text
T.singleton forall b c a. (b -> c) -> (a -> b) -> a -> c
. RID -> Char
chr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Integer
i) Store
s Cont
k
      [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
    Const
AppF ->
      let msg :: Text
msg = Text
"The operator '$' should only be a syntactic sugar and removed in elaboration:\n"
       in forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Exn
Fatal forall a b. (a -> b) -> a -> b
$ Text
msg forall a. Semigroup a => a -> a -> a
<> Text
badConstMsg
 where
  doDrill :: Direction -> m CESK
doDrill Direction
d = do
    Inventory
ins <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot Inventory
equippedDevices

    let equippedDrills :: [Entity]
equippedDrills = Capability -> Inventory -> [Entity]
extantElemsWithCapability Capability
CDrill Inventory
ins
        -- Heuristic: choose the drill with the more elaborate name.
        -- E.g. "metal drill" vs. "drill"
        preferredDrill :: Maybe Entity
preferredDrill = forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (forall a. a -> Down a
Down forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> RID
T.length forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall s a. s -> Getting a s a -> a
^. Lens' Entity Text
entityName)) [Entity]
equippedDrills

    Entity
tool <- Maybe Entity
preferredDrill forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
Maybe a -> e -> m a
`isJustOr` Text -> Exn
Fatal Text
"Drill is required but not equipped?!"
    forall {sig :: (* -> *) -> * -> *} {m :: * -> *} {p}.
(Algebra sig m, Member (Throw Exn) sig, Member (State Robot) sig,
 Member (State GameState) sig, Eq p,
 Member (Reader (Recipe p)) (Reader (Recipe Entity))) =>
Inventory -> Text -> Direction -> p -> m CESK
applyDevice Inventory
ins Text
"drill" Direction
d Entity
tool

  applyDevice :: Inventory -> Text -> Direction -> p -> m CESK
applyDevice Inventory
ins Text
verbPhrase Direction
d p
tool = do
    (Cosmic Location
nextLoc, Entity
nextE) <- forall {sig :: (* -> *) -> * -> *} {m :: * -> *}.
(Algebra sig m, Member (Throw Exn) sig, Member (State Robot) sig,
 Member (State GameState) sig) =>
Text -> Direction -> m (Cosmic Location, Entity)
getDeviceTarget Text
verbPhrase Direction
d
    IntMap [Recipe Entity]
inRs <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use forall a b. (a -> b) -> a -> b
$ Lens' GameState Recipes
recipesInfo forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Recipes (IntMap [Recipe Entity])
recipesIn

    let recipes :: [Recipe Entity]
recipes = forall a. (a -> Bool) -> [a] -> [a]
filter Recipe Entity -> Bool
isApplicableRecipe (IntMap [Recipe Entity] -> Entity -> [Recipe Entity]
recipesFor IntMap [Recipe Entity]
inRs Entity
nextE)
        isApplicableRecipe :: Recipe Entity -> Bool
isApplicableRecipe = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((forall a. Eq a => a -> a -> Bool
== p
tool) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Reader r) sig m =>
Getting a r a -> m a
view forall e. Lens' (Recipe e) (IngredientList e)
recipeCatalysts

    Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Recipe Entity]
recipes)
      forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Bool -> [Text] -> m ()
`holdsOrFail` [ Text
"There is no way to"
                    , Text
verbPhrase
                    , Text -> Text
indefinite (Entity
nextE forall s a. s -> Getting a s a -> a
^. Lens' Entity Text
entityName) forall a. Semigroup a => a -> a -> a
<> Text
"."
                    ]

    Inventory
inv <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot Inventory
robotInventory

    -- add the targeted entity so it can be consumed by the recipe
    let makeRecipe :: Recipe Entity
-> Either
     [MissingIngredient] ((Inventory, [(RID, Entity)]), Recipe Entity)
makeRecipe Recipe Entity
r = (,Recipe Entity
r) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Inventory, Inventory)
-> Recipe Entity
-> Either [MissingIngredient] (Inventory, [(RID, Entity)])
make' (Entity -> Inventory -> Inventory
insert Entity
nextE Inventory
inv, Inventory
ins) Recipe Entity
r
    Maybe ((Inventory, [(RID, Entity)]), Recipe Entity)
chosenRecipe <-
      forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (State GameState) sig m =>
(a -> Integer) -> [a] -> m (Maybe a)
weightedChoice (\((Inventory
_, [(RID, Entity)]
_), Recipe Entity
r) -> Recipe Entity
r forall s a. s -> Getting a s a -> a
^. forall e. Lens' (Recipe e) Integer
recipeWeight) forall a b. (a -> b) -> a -> b
$
        forall a b. [Either a b] -> [b]
rights forall a b. (a -> b) -> a -> b
$
          forall a b. (a -> b) -> [a] -> [b]
map Recipe Entity
-> Either
     [MissingIngredient] ((Inventory, [(RID, Entity)]), Recipe Entity)
makeRecipe [Recipe Entity]
recipes
    ((Inventory
invTaken, [(RID, Entity)]
outs), Recipe Entity
recipe) <-
      Maybe ((Inventory, [(RID, Entity)]), Recipe Entity)
chosenRecipe
        forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Maybe a -> [Text] -> m a
`isJustOrFail` [Text
"You don't have the ingredients to", Text
verbPhrase, Text -> Text
indefinite (Entity
nextE forall s a. s -> Getting a s a -> a
^. Lens' Entity Text
entityName) forall a. Semigroup a => a -> a -> a
<> Text
"."]

    let ([(RID, Entity)]
out, [(RID, Entity)]
down) = forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition ((Entity -> EntityProperty -> Bool
`hasProperty` EntityProperty
Portable) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(RID, Entity)]
outs
        learn :: [RobotUpdate]
learn = forall a b. (a -> b) -> [a] -> [b]
map (Entity -> RobotUpdate
LearnEntity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(RID, Entity)]
down
        gain :: [RobotUpdate]
gain = forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry RID -> Entity -> RobotUpdate
AddEntity) [(RID, Entity)]
out

    Maybe Entity
newEntity <- case [(RID, Entity)]
down of
      [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
      [(RID
1, Entity
de)] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Entity
de
      [(RID, Entity)]
_ -> forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text -> Exn
Fatal Text
"Bad recipe:\n more than one unmovable entity produced."
    let changeWorld :: WorldUpdate Entity
changeWorld =
          ReplaceEntity
            { updatedLoc :: Cosmic Location
updatedLoc = Cosmic Location
nextLoc
            , originalEntity :: Entity
originalEntity = Entity
nextE
            , newEntity :: Maybe Entity
newEntity = Maybe Entity
newEntity
            }

    -- take recipe inputs from inventory and add outputs after recipeTime
    Lens' Robot Inventory
robotInventory forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= Inventory
invTaken

    let cmdOutput :: Value
cmdOutput = forall a. Valuable a => a -> Value
asValue forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> Maybe a
listToMaybe [(RID, Entity)]
out
    forall (sig :: (* -> *) -> * -> *) (m :: * -> *) e.
HasRobotStepState sig m =>
Recipe e
-> Value -> [WorldUpdate Entity] -> [RobotUpdate] -> m CESK
finishCookingRecipe Recipe Entity
recipe Value
cmdOutput [WorldUpdate Entity
changeWorld] ([RobotUpdate]
learn forall a. Semigroup a => a -> a -> a
<> [RobotUpdate]
gain)

  getDeviceTarget :: Text -> Direction -> m (Cosmic Location, Entity)
getDeviceTarget Text
verb Direction
d = do
    Text
rname <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot Text
robotName

    (Cosmic Location
nextLoc, Maybe Entity
nextME) <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Direction -> m (Cosmic Location, Maybe Entity)
lookInDirection Direction
d
    Entity
nextE <-
      Maybe Entity
nextME
        forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Maybe a -> [Text] -> m a
`isJustOrFail` [Text
"There is nothing to", Text
verb, Text
directionText, Text
"robot", Text
rname forall a. Semigroup a => a -> a -> a
<> Text
"."]
    forall (m :: * -> *) a. Monad m => a -> m a
return (Cosmic Location
nextLoc, Entity
nextE)
   where
    directionText :: Text
directionText = case Direction
d of
      DRelative RelativeDir
DDown -> Text
"under"
      DRelative (DPlanar PlanarRelativeDir
DForward) -> Text
"ahead of"
      DRelative (DPlanar PlanarRelativeDir
DBack) -> Text
"behind"
      Direction
_ -> Direction -> Text
directionSyntax Direction
d forall a. Semigroup a => a -> a -> a
<> Text
" of"

  goAtomic :: HasRobotStepState sig m => m CESK
  goAtomic :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
m CESK
goAtomic = case [Value]
vs of
    -- To execute an atomic block, set the runningAtomic flag,
    -- push an FFinishAtomic frame so that we unset the flag when done, and
    -- proceed to execute the argument.
    [Value
cmd] -> do
      Lens' Robot Bool
runningAtomic forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= Bool
True
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
cmd Store
s (Frame
FExec forall a. a -> [a] -> [a]
: Frame
FFinishAtomic forall a. a -> [a] -> [a]
: Cont
k)
    [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst

  -- Case-insensitive matching on entity names
  isEntityNamed :: T.Text -> Entity -> Bool
  isEntityNamed :: Text -> Entity -> Bool
isEntityNamed Text
n Entity
e = (forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Text -> Text
T.toLower) (Entity
e forall s a. s -> Getting a s a -> a
^. Lens' Entity Text
entityName) Text
n

  badConst :: HasRobotStepState sig m => m a
  badConst :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst = forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text -> Exn
Fatal Text
badConstMsg

  badConstMsg :: Text
  badConstMsg :: Text
badConstMsg =
    [Text] -> Text
T.unlines
      [ Text
"Bad application of execConst:"
      , String -> Text
T.pack (forall a. Show a => a -> String
show Const
c)
      , String -> Text
T.pack (forall a. Show a => a -> String
show (forall a. [a] -> [a]
reverse [Value]
vs))
      , forall a. PrettyPrec a => a -> Text
prettyText (Value -> Store -> Cont -> CESK
Out (Const -> [Value] -> Value
VCApp Const
c (forall a. [a] -> [a]
reverse [Value]
vs)) Store
s Cont
k)
      ]

  doResonate ::
    (HasRobotStepState sig m, Has (Lift IO) sig m) =>
    (Maybe Entity -> Bool) ->
    Integer ->
    Integer ->
    Integer ->
    Integer ->
    m CESK
  doResonate :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(HasRobotStepState sig m, Has (Lift IO) sig m) =>
(Maybe Entity -> Bool)
-> Integer -> Integer -> Integer -> Integer -> m CESK
doResonate Maybe Entity -> Bool
p Integer
x1 Integer
y1 Integer
x2 Integer
y2 = do
    Cosmic Location
loc <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot (Cosmic Location)
robotLocation
    let offsets :: [Heading]
offsets = Integer -> Integer -> Integer -> Integer -> [Heading]
rectCells Integer
x1 Integer
y1 Integer
x2 Integer
y2
    [RID]
hits <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Enum a => a -> RID
fromEnum forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Entity -> Bool
p) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
Cosmic Location -> m (Maybe Entity)
entityAt forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cosmic Location -> Heading -> Cosmic Location
offsetBy Cosmic Location
loc) [Heading]
offsets
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Integer -> Value
VInt forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [RID]
hits) Store
s Cont
k

  rectCells :: Integer -> Integer -> Integer -> Integer -> [V2 Int32]
  rectCells :: Integer -> Integer -> Integer -> Integer -> [Heading]
rectCells Integer
x1 Integer
y1 Integer
x2 Integer
y2 =
    Int32 -> Int32 -> Int32 -> Int32 -> [Heading]
rectCellsInt32
      (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
x1)
      (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
y1)
      (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
x2)
      (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
y2)

  rectCellsInt32 :: Int32 -> Int32 -> Int32 -> Int32 -> [V2 Int32]
  rectCellsInt32 :: Int32 -> Int32 -> Int32 -> Int32 -> [Heading]
rectCellsInt32 Int32
x1 Int32
y1 Int32
x2 Int32
y2 = [forall a. a -> a -> V2 a
V2 Int32
x Int32
y | Int32
x <- [Int32
xMin .. Int32
xMax], Int32
y <- [Int32
yMin .. Int32
yMax]]
   where
    (Int32
xMin, Int32
xMax) = forall b. Ord b => (b, b) -> (b, b)
sortPair (Int32
x1, Int32
x2)
    (Int32
yMin, Int32
yMax) = forall b. Ord b => (b, b) -> (b, b)
sortPair (Int32
y1, Int32
y2)

  findNearest ::
    HasRobotStepState sig m =>
    Text ->
    m (Maybe (Int32, V2 Int32))
  findNearest :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Text -> m (Maybe (Int32, Heading))
findNearest Text
name = do
    Cosmic Location
loc <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot (Cosmic Location)
robotLocation
    let f :: (a, Heading) -> m Bool
f = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False forall a b. (a -> b) -> a -> b
$ Text -> Entity -> Bool
isEntityNamed Text
name) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
Cosmic Location -> m (Maybe Entity)
entityAt forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cosmic Location -> Heading -> Cosmic Location
offsetBy Cosmic Location
loc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd
    forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Monad m) =>
(a -> m Bool) -> f a -> m (Maybe a)
findM forall {a}. (a, Heading) -> m Bool
f [(Int32, Heading)]
sortedOffsets
   where
    sortedOffsets :: [(Int32, V2 Int32)]
    sortedOffsets :: [(Int32, Heading)]
sortedOffsets = (Int32
0, forall (f :: * -> *) a. (Additive f, Num a) => f a
zero) forall a. a -> [a] -> [a]
: forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Int32 -> [(Int32, Heading)]
genDiamondSides [Int32
1 .. Int32
maxSniffRange]

    -- Grow a list of locations in a diamond shape outward, such that the nearest cells
    -- are searched first by construction, rather than having to sort.
    genDiamondSides :: Int32 -> [(Int32, V2 Int32)]
    genDiamondSides :: Int32 -> [(Int32, Heading)]
genDiamondSides Int32
diameter = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [forall {a}. Num a => a -> a -> [(a, V2 a)]
f Int32
diameter Int32
x | Int32
x <- [Int32
0 .. Int32
diameter]]
     where
      -- Adds a single cell to each of the four sides of the diamond
      f :: a -> a -> [(a, V2 a)]
f a
d a
x = forall a b. (a -> b) -> [a] -> [b]
map (a
d,) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. RID -> [a] -> [a]
take RID
4 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a) -> a -> [a]
iterate forall a. Num a => V2 a -> V2 a
perp forall a b. (a -> b) -> a -> b
$ forall a. a -> a -> V2 a
V2 a
x (a
d forall a. Num a => a -> a -> a
- a
x)

  finishCookingRecipe ::
    HasRobotStepState sig m =>
    Recipe e ->
    Value ->
    [WorldUpdate Entity] ->
    [RobotUpdate] ->
    m CESK
  finishCookingRecipe :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *) e.
HasRobotStepState sig m =>
Recipe e
-> Value -> [WorldUpdate Entity] -> [RobotUpdate] -> m CESK
finishCookingRecipe Recipe e
r Value
v [WorldUpdate Entity]
wf [RobotUpdate]
rf =
    if Integer
remTime forall a. Ord a => a -> a -> Bool
<= Integer
0
      then do
        forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Const -> [WorldUpdate Entity] -> [RobotUpdate] -> m ()
updateWorldAndRobots Const
c [WorldUpdate Entity]
wf [RobotUpdate]
rf
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
v Store
s Cont
k
      else do
        TickNumber
time <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use forall a b. (a -> b) -> a -> b
$ Lens' GameState TemporalState
temporal forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' TemporalState TickNumber
ticks
        forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Integer
remTime forall a. Ord a => a -> a -> Bool
<= Integer
1 then forall a. a -> a
id else TickNumber -> CESK -> CESK
Waiting (RID -> TickNumber -> TickNumber
addTicks (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
remTime) TickNumber
time)) forall a b. (a -> b) -> a -> b
$
          Value -> Store -> Cont -> CESK
Out Value
v Store
s (Const -> [WorldUpdate Entity] -> [RobotUpdate] -> Frame
FImmediate Const
c [WorldUpdate Entity]
wf [RobotUpdate]
rf forall a. a -> [a] -> [a]
: Cont
k)
   where
    remTime :: Integer
remTime = Recipe e
r forall s a. s -> Getting a s a -> a
^. forall e. Lens' (Recipe e) Integer
recipeTime

  ensureEquipped :: HasRobotStepState sig m => Text -> m Entity
  ensureEquipped :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Text -> m Entity
ensureEquipped Text
itemName = do
    Inventory
inst <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot Inventory
equippedDevices
    forall a. [a] -> Maybe a
listToMaybe (Text -> Inventory -> [Entity]
lookupByName Text
itemName Inventory
inst)
      forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Maybe a -> [Text] -> m a
`isJustOrFail` [Text
"You don't have a", Text -> Text
indefinite Text
itemName, Text
"equipped."]

  ensureItem :: HasRobotStepState sig m => Text -> Text -> m Entity
  ensureItem :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Text -> Text -> m Entity
ensureItem Text
itemName Text
action = do
    -- First, make sure we know about the entity.
    Inventory
inv <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot Inventory
robotInventory
    Inventory
inst <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot Inventory
equippedDevices
    Entity
item <-
      forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum (forall a b. (a -> b) -> [a] -> [b]
map (forall a. [a] -> Maybe a
listToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Inventory -> [Entity]
lookupByName Text
itemName) [Inventory
inv, Inventory
inst])
        forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Maybe a -> [Text] -> m a
`isJustOrFail` [Text
"What is", Text -> Text
indefinite Text
itemName forall a. Semigroup a => a -> a -> a
<> Text
"?"]

    -- Next, check whether we have one.  If we don't, add a hint about
    -- 'create' in creative mode.
    Bool
creative <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' GameState Bool
creativeMode
    let create :: [Text] -> [Text]
create [Text]
l = [Text]
l forall a. Semigroup a => a -> a -> a
<> [Text
"You can make one first with 'create \"" forall a. Semigroup a => a -> a -> a
<> Text
itemName forall a. Semigroup a => a -> a -> a
<> Text
"\"'." | Bool
creative]

    (Entity -> Inventory -> RID
E.lookup Entity
item Inventory
inv forall a. Ord a => a -> a -> Bool
> RID
0)
      forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Bool -> [Text] -> m ()
`holdsOrFail` [Text] -> [Text]
create [Text
"You don't have", Text -> Text
indefinite Text
itemName, Text
"to", Text
action forall a. Semigroup a => a -> a -> a
<> Text
"."]

    forall (m :: * -> *) a. Monad m => a -> m a
return Entity
item

  -- Check the required devices and inventory for running the given
  -- command on a target robot.  This function is used in common by
  -- both 'Build' and 'Reprogram'.
  --
  -- It is given as inputs the parent robot inventory, the inventory
  -- and equipped devices of the child (these will be empty in the
  -- case of 'Build'), and the command to be run (along with a few
  -- inputs to configure any error messages to be generated).
  --
  -- Throws an exception if it's not possible to set up the child
  -- robot with the things it needs to execute the given program.
  -- Otherwise, returns a pair consisting of the set of devices to be
  -- equipped, and the inventory that should be transferred from
  -- parent to child.
  checkRequirements ::
    HasRobotStepState sig m =>
    Inventory ->
    Inventory ->
    Inventory ->
    Term ->
    Text ->
    IncapableFix ->
    m (Set Entity, Inventory)
  checkRequirements :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Inventory
-> Inventory
-> Inventory
-> Term
-> Text
-> IncapableFix
-> m (Set Entity, Inventory)
checkRequirements Inventory
parentInventory Inventory
childInventory Inventory
childDevices Term
cmd Text
subject IncapableFix
fixI = do
    ReqCtx
currentContext <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use forall a b. (a -> b) -> a -> b
$ Lens' Robot RobotContext
robotContext forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' RobotContext ReqCtx
defReqs
    EntityMap
em <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use forall a b. (a -> b) -> a -> b
$ Lens' GameState Landscape
landscape forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Landscape EntityMap
entityMap
    Bool
creative <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' GameState Bool
creativeMode
    let -- Note that _capCtx must be empty: at least at the
        -- moment, definitions are only allowed at the top level,
        -- so there can't be any inside the argument to build.
        -- (Though perhaps there is an argument that this ought to be
        -- relaxed specifically in the cases of 'Build' and 'Reprogram'.)
        -- See #349
        (R.Requirements (forall a. Set a -> [a]
S.toList -> [Capability]
caps) (forall a. Set a -> [a]
S.toList -> [Text]
devNames) Map Text RID
reqInvNames, ReqCtx
_capCtx) = ReqCtx -> Term -> (Requirements, ReqCtx)
R.requirements ReqCtx
currentContext Term
cmd

    -- Check that all required device names exist (fail with
    -- an exception if not) and convert them to 'Entity' values.
    ([Entity]
devs :: [Entity]) <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Text]
devNames forall a b. (a -> b) -> a -> b
$ \Text
devName ->
      Text -> EntityMap -> Maybe Entity
E.lookupEntityName Text
devName EntityMap
em forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Maybe a -> [Text] -> m a
`isJustOrFail` [Text
"Unknown device required: " forall a. Semigroup a => a -> a -> a
<> Text
devName]

    -- Check that all required inventory entity names exist (fail with
    -- an exception if not) and convert them to 'Entity' values, with
    -- an associated count for each.
    (Inventory
reqInv :: Inventory) <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(RID, Entity)] -> Inventory
E.fromElems forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall k a. Map k a -> [(k, a)]
M.assocs Map Text RID
reqInvNames) forall a b. (a -> b) -> a -> b
$ \(Text
eName, RID
n) ->
      (RID
n,)
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ( Text -> EntityMap -> Maybe Entity
E.lookupEntityName Text
eName EntityMap
em
                forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Maybe a -> [Text] -> m a
`isJustOrFail` [Text
"Unknown entity required: " forall a. Semigroup a => a -> a -> a
<> Text
eName]
            )

    let -- List of possible devices per requirement.  For the
        -- requirements that stem from a required capability, we
        -- remember the capability alongside the possible devices, to
        -- help with later error message generation.
        possibleDevices :: [(Maybe Capability, [Entity])]
        possibleDevices :: [(Maybe Capability, [Entity])]
possibleDevices =
          forall a b. (a -> b) -> [a] -> [b]
map (forall a. a -> Maybe a
Just forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (Capability -> EntityMap -> [Entity]
`deviceForCap` EntityMap
em)) [Capability]
caps -- Possible devices for capabilities
            forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map ((forall a. Maybe a
Nothing,) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
: [])) [Entity]
devs -- Outright required devices

        -- A device is OK if it is available in the inventory of the
        -- parent robot, or already equipped in the child robot.
        deviceOK :: Entity -> Bool
        deviceOK :: Entity -> Bool
deviceOK Entity
d = Inventory
parentInventory Inventory -> Entity -> Bool
`E.contains` Entity
d Bool -> Bool -> Bool
|| Inventory
childDevices Inventory -> Entity -> Bool
`E.contains` Entity
d

        -- Partition each list of possible devices into a set of
        -- available devices and a set of unavailable devices.
        -- There's a problem if some capability is required but no
        -- devices that provide it are available.  In that case we can
        -- print an error message, using the second set as a list of
        -- suggestions.
        partitionedDevices :: [(Set Entity, Set Entity)]
        partitionedDevices :: [(Set Entity, Set Entity)]
partitionedDevices =
          forall a b. (a -> b) -> [a] -> [b]
map (forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
Lens.over forall (r :: * -> * -> *) a b.
Bitraversable r =>
Traversal (r a a) (r b b) a b
both forall a. Ord a => [a] -> Set a
S.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition Entity -> Bool
deviceOK forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Maybe Capability, [Entity])]
possibleDevices

        -- Devices equipped on the child, as a Set instead of an
        -- Inventory for convenience.
        alreadyEquipped :: Set Entity
        alreadyEquipped :: Set Entity
alreadyEquipped = forall a. Ord a => [a] -> Set a
S.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. Inventory -> [(RID, Entity)]
E.elems forall a b. (a -> b) -> a -> b
$ Inventory
childDevices

        -- Figure out what is still missing of the required inventory:
        -- the required inventory, less any inventory the child robot
        -- already has.
        missingChildInv :: Inventory
missingChildInv = Inventory
reqInv Inventory -> Inventory -> Inventory
`E.difference` Inventory
childInventory

    if Bool
creative
      then
        forall (m :: * -> *) a. Monad m => a -> m a
return
          ( -- In creative mode, just equip ALL the devices
            -- providing each required capability (because, why
            -- not?). But don't re-equip any that are already
            -- equipped.
            forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions (forall a b. (a -> b) -> [a] -> [b]
map (forall a. Ord a => [a] -> Set a
S.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Maybe Capability, [Entity])]
possibleDevices) forall a. Ord a => Set a -> Set a -> Set a
`S.difference` Set Entity
alreadyEquipped
          , -- Conjure the necessary missing inventory out of thin
            -- air.
            Inventory
missingChildInv
          )
      else do
        -- First, check that devices actually exist AT ALL to provide every
        -- required capability.  If not, we will generate an error message saying
        -- something like "missing capability X but no device yet provides it".
        let capsWithNoDevice :: [Capability]
capsWithNoDevice = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$ [(Maybe Capability, [Entity])]
possibleDevices
        forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Capability]
capsWithNoDevice
          forall e (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw e) sig m =>
Bool -> e -> m ()
`holdsOr` IncapableFix -> Requirements -> Term -> Exn
Incapable IncapableFix
fixI (Set Capability -> Set Text -> Map Text RID -> Requirements
R.Requirements (forall a. Ord a => [a] -> Set a
S.fromList [Capability]
capsWithNoDevice) forall a. Set a
S.empty forall k a. Map k a
M.empty) Term
cmd

        -- Now, ensure there is at least one device available to be
        -- equipped for each requirement.
        let missingDevices :: [Set Entity]
missingDevices = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ [(Set Entity, Set Entity)]
partitionedDevices
        forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Set Entity]
missingDevices
          forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Bool -> [Text] -> m ()
`holdsOrFail` ( Text -> Text -> Text
singularSubjectVerb Text
subject Text
"do"
                            forall a. a -> [a] -> [a]
: Text
"not have required devices, please"
                            forall a. a -> [a] -> [a]
: IncapableFix -> Text
formatIncapableFix IncapableFix
fixI forall a. Semigroup a => a -> a -> a
<> Text
":"
                            forall a. a -> [a] -> [a]
: ((Text
"\n  - " forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Entity -> Text
formatDevices forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Set Entity]
missingDevices)
                        )

        let minimalEquipSet :: Set Entity
minimalEquipSet = forall a. Ord a => [Set a] -> Set a
smallHittingSet (forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Set a -> Bool
S.null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => Set a -> Set a -> Set a
S.intersection Set Entity
alreadyEquipped) (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Set Entity, Set Entity)]
partitionedDevices))

            -- Check that we have enough in our inventory to cover the
            -- required devices PLUS what's missing from the child
            -- inventory.

            -- What do we need?
            neededParentInv :: Inventory
neededParentInv =
              Inventory
missingChildInv
                Inventory -> Inventory -> Inventory
`E.union` ([Entity] -> Inventory
fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
S.toList forall a b. (a -> b) -> a -> b
$ Set Entity
minimalEquipSet)

            -- What are we missing?
            missingParentInv :: Inventory
missingParentInv = Inventory
neededParentInv Inventory -> Inventory -> Inventory
`E.difference` Inventory
parentInventory
            missingMap :: Map Text RID
missingMap =
              forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Ord a => a -> a -> Bool
> RID
0) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a, b) -> (b, a)
swap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall s a. s -> Getting a s a -> a
^. Lens' Entity Text
entityName))
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. Inventory -> [(RID, Entity)]
E.elems
                forall a b. (a -> b) -> a -> b
$ Inventory
missingParentInv

        -- If we're missing anything, throw an error
        Inventory -> Bool
E.isEmpty Inventory
missingParentInv
          forall e (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw e) sig m =>
Bool -> e -> m ()
`holdsOr` IncapableFix -> Requirements -> Term -> Exn
Incapable IncapableFix
fixI (Set Capability -> Set Text -> Map Text RID -> Requirements
R.Requirements forall a. Set a
S.empty forall a. Set a
S.empty Map Text RID
missingMap) Term
cmd

        forall (m :: * -> *) a. Monad m => a -> m a
return (Set Entity
minimalEquipSet, Inventory
missingChildInv)

  -- Destroy the current robot, as long as it is not the base robot.
  --
  -- Depending on whether we destroy (True) or do not destroy
  -- (False) the current robot, possibly grant an achievement.
  --
  -- Note we cannot simply return a Boolean and grant achievements
  -- at call sites, because in the case that we do not destroy the
  -- base we actually throw an exception, so we do not return to the
  -- original call site.
  destroyIfNotBase ::
    (HasRobotStepState sig m, Has (Lift IO) sig m) =>
    (Bool -> Maybe GameplayAchievement) ->
    m ()
  destroyIfNotBase :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(HasRobotStepState sig m, Has (Lift IO) sig m) =>
(Bool -> Maybe GameplayAchievement) -> m ()
destroyIfNotBase Bool -> Maybe GameplayAchievement
mAch = do
    RID
rid <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot RID
robotID
    forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Bool -> [Text] -> Maybe GameplayAchievement -> m ()
holdsOrFailWithAchievement
      (RID
rid forall a. Eq a => a -> a -> Bool
/= RID
0)
      [Text
"You consider destroying your base, but decide not to do it after all."]
      (Bool -> Maybe GameplayAchievement
mAch Bool
False)

    Lens' Robot Bool
selfDestruct forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= Bool
True
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (Lift IO) sig m) =>
GameplayAchievement -> m ()
grantAchievement (Bool -> Maybe GameplayAchievement
mAch Bool
True)

  moveInDirection :: (HasRobotStepState sig m, Has (Lift IO) sig m) => Heading -> m CESK
  moveInDirection :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(HasRobotStepState sig m, Has (Lift IO) sig m) =>
Heading -> m CESK
moveInDirection Heading
orientation = do
    -- Figure out where we're going
    Cosmic Location
loc <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot (Cosmic Location)
robotLocation
    let nextLoc :: Cosmic Location
nextLoc = Cosmic Location
loc Cosmic Location -> Heading -> Cosmic Location
`offsetBy` Heading
orientation
    forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(HasRobotStepState sig m, Has (Lift IO) sig m) =>
Cosmic Location -> MoveFailureHandler -> m ()
checkMoveAhead Cosmic Location
nextLoc forall a b. (a -> b) -> a -> b
$ \case
      MoveFailureMode
PathBlocked -> RobotFailure
ThrowExn
      MoveFailureMode
PathLiquid -> RobotFailure
Destroy
    forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Cosmic Location -> Cosmic Location -> m ()
updateRobotLocation Cosmic Location
loc Cosmic Location
nextLoc
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s Cont
k

  applyMoveFailureEffect ::
    (HasRobotStepState sig m, Has (Lift IO) sig m) =>
    Maybe MoveFailureDetails ->
    MoveFailureHandler ->
    m ()
  applyMoveFailureEffect :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(HasRobotStepState sig m, Has (Lift IO) sig m) =>
Maybe MoveFailureDetails -> MoveFailureHandler -> m ()
applyMoveFailureEffect Maybe MoveFailureDetails
maybeFailure MoveFailureHandler
failureHandler =
    case Maybe MoveFailureDetails
maybeFailure of
      Maybe MoveFailureDetails
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just (MoveFailureDetails Entity
e MoveFailureMode
failureMode) -> case MoveFailureHandler
failureHandler MoveFailureMode
failureMode of
        RobotFailure
IgnoreFail -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        RobotFailure
Destroy -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(HasRobotStepState sig m, Has (Lift IO) sig m) =>
(Bool -> Maybe GameplayAchievement) -> m ()
destroyIfNotBase forall a b. (a -> b) -> a -> b
$ \Bool
b -> case (Bool
b, MoveFailureMode
failureMode) of
          (Bool
True, MoveFailureMode
PathLiquid) -> forall a. a -> Maybe a
Just GameplayAchievement
RobotIntoWater -- achievement for drowning
          (Bool, MoveFailureMode)
_ -> forall a. Maybe a
Nothing
        RobotFailure
ThrowExn -> forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. Const -> [Text] -> Exn
cmdExn Const
c forall a b. (a -> b) -> a -> b
$
          case MoveFailureMode
failureMode of
            MoveFailureMode
PathBlocked -> [Text
"There is a", Entity
e forall s a. s -> Getting a s a -> a
^. Lens' Entity Text
entityName, Text
"in the way!"]
            MoveFailureMode
PathLiquid -> [Text
"There is a dangerous liquid", Entity
e forall s a. s -> Getting a s a -> a
^. Lens' Entity Text
entityName, Text
"in the way!"]

  -- Determine the move failure mode and apply the corresponding effect.
  checkMoveAhead ::
    (HasRobotStepState sig m, Has (Lift IO) sig m) =>
    Cosmic Location ->
    MoveFailureHandler ->
    m ()
  checkMoveAhead :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(HasRobotStepState sig m, Has (Lift IO) sig m) =>
Cosmic Location -> MoveFailureHandler -> m ()
checkMoveAhead Cosmic Location
nextLoc MoveFailureHandler
failureHandler = do
    Maybe MoveFailureDetails
maybeFailure <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Cosmic Location -> m (Maybe MoveFailureDetails)
checkMoveFailure Cosmic Location
nextLoc
    forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(HasRobotStepState sig m, Has (Lift IO) sig m) =>
Maybe MoveFailureDetails -> MoveFailureHandler -> m ()
applyMoveFailureEffect Maybe MoveFailureDetails
maybeFailure MoveFailureHandler
failureHandler

  getRobotWithinTouch :: HasRobotStepState sig m => RID -> m Robot
  getRobotWithinTouch :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
RID -> m Robot
getRobotWithinTouch RID
rid = do
    RID
cid <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot RID
robotID
    if RID
cid forall a. Eq a => a -> a -> Bool
== RID
rid
      then forall s (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
m s
get @Robot
      else do
        Maybe Robot
mother <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
RID -> m (Maybe Robot)
robotWithID RID
rid
        Robot
other <- Maybe Robot
mother forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Maybe a -> [Text] -> m a
`isJustOrFail` [Text
"There is no robot with ID", forall source target. From source target => source -> target
from (forall a. Show a => a -> String
show RID
rid) forall a. Semigroup a => a -> a -> a
<> Text
"."]

        let otherLoc :: Cosmic Location
otherLoc = Robot
other forall s a. s -> Getting a s a -> a
^. Getter Robot (Cosmic Location)
robotLocation
        Bool
privileged <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m) =>
m Bool
isPrivilegedBot
        Cosmic Location
myLoc <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot (Cosmic Location)
robotLocation

        -- Make sure it is either in the same location or we do not care
        Bool -> Cosmic Location -> Cosmic Location -> Bool
isNearbyOrExempt Bool
privileged Cosmic Location
myLoc Cosmic Location
otherLoc
          forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Bool -> [Text] -> m ()
`holdsOrFail` [Text
"The robot with ID", forall source target. From source target => source -> target
from (forall a. Show a => a -> String
show RID
rid), Text
"is not close enough."]
        forall (m :: * -> *) a. Monad m => a -> m a
return Robot
other

  holdsOrFail :: (Has (Throw Exn) sig m) => Bool -> [Text] -> m ()
  holdsOrFail :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Bool -> [Text] -> m ()
holdsOrFail = forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Const -> Bool -> [Text] -> m ()
holdsOrFail' Const
c

  holdsOrFailWithAchievement :: (Has (Throw Exn) sig m) => Bool -> [Text] -> Maybe GameplayAchievement -> m ()
  holdsOrFailWithAchievement :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Bool -> [Text] -> Maybe GameplayAchievement -> m ()
holdsOrFailWithAchievement Bool
a [Text]
ts Maybe GameplayAchievement
mAch = case Maybe GameplayAchievement
mAch of
    Maybe GameplayAchievement
Nothing -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Bool -> [Text] -> m ()
holdsOrFail Bool
a [Text]
ts
    Just GameplayAchievement
ach -> Bool
a forall e (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw e) sig m =>
Bool -> e -> m ()
`holdsOr` Const -> [Text] -> GameplayAchievement -> Exn
cmdExnWithAchievement Const
c [Text]
ts GameplayAchievement
ach

  isJustOrFail :: (Has (Throw Exn) sig m) => Maybe a -> [Text] -> m a
  isJustOrFail :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Maybe a -> [Text] -> m a
isJustOrFail = forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Const -> Maybe a -> [Text] -> m a
isJustOrFail' Const
c

  returnEvalCmp :: m CESK
returnEvalCmp = case [Value]
vs of
    [Value
v1, Value
v2] -> (\Bool
b -> Value -> Store -> Cont -> CESK
Out (Bool -> Value
VBool Bool
b) Store
s Cont
k) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Const -> Value -> Value -> m Bool
evalCmp Const
c Value
v1 Value
v2
    [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
  returnEvalArith :: m CESK
returnEvalArith = case [Value]
vs of
    [VInt Integer
n1, VInt Integer
n2] -> (\Integer
r -> Value -> Store -> Cont -> CESK
Out (Integer -> Value
VInt Integer
r) Store
s Cont
k) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Const -> Integer -> Integer -> m Integer
evalArith Const
c Integer
n1 Integer
n2
    [Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst

  -- Make sure the robot has the thing in its inventory
  hasInInventoryOrFail :: HasRobotStepState sig m => Text -> m Entity
  hasInInventoryOrFail :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Text -> m Entity
hasInInventoryOrFail Text
eName = do
    Inventory
inv <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot Inventory
robotInventory
    Entity
e <-
      forall a. [a] -> Maybe a
listToMaybe (Text -> Inventory -> [Entity]
lookupByName Text
eName Inventory
inv)
        forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Maybe a -> [Text] -> m a
`isJustOrFail` [Text
"What is", Text -> Text
indefinite Text
eName forall a. Semigroup a => a -> a -> a
<> Text
"?"]
    let cmd :: Text
cmd = Text -> Text
T.toLower forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Const
c
    (Entity -> Inventory -> RID
E.lookup Entity
e Inventory
inv forall a. Ord a => a -> a -> Bool
> RID
0)
      forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Bool -> [Text] -> m ()
`holdsOrFail` [Text
"You don't have", Text -> Text
indefinite Text
eName, Text
"to", Text
cmd forall a. Semigroup a => a -> a -> a
<> Text
"."]
    forall (m :: * -> *) a. Monad m => a -> m a
return Entity
e

  mkReturn :: Valuable a => a -> CESK
  mkReturn :: forall a. Valuable a => a -> CESK
mkReturn a
x = Value -> Store -> Cont -> CESK
Out (forall a. Valuable a => a -> Value
asValue a
x) Store
s Cont
k

  -- The code for grab and harvest is almost identical, hence factored
  -- out here.
  doGrab :: (HasRobotStepState sig m, Has (Lift IO) sig m) => GrabbingCmd -> m Entity
  doGrab :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(HasRobotStepState sig m, Has (Lift IO) sig m) =>
GrabbingCmd -> m Entity
doGrab GrabbingCmd
cmd = do
    let verb :: Text
verb = GrabbingCmd -> Text
verbGrabbingCmd GrabbingCmd
cmd
        verbed :: Text
verbed = GrabbingCmd -> Text
verbedGrabbingCmd GrabbingCmd
cmd

    -- Ensure there is an entity here.
    Cosmic Location
loc <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot (Cosmic Location)
robotLocation
    Entity
e <-
      forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
Cosmic Location -> m (Maybe Entity)
entityAt Cosmic Location
loc
        forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Maybe a -> [Text] -> m a
`isJustOrFail` [Text
"There is nothing here to", Text
verb forall a. Semigroup a => a -> a -> a
<> Text
"."])

    -- Ensure it can be picked up.
    Bool
omni <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m) =>
m Bool
isPrivilegedBot
    (Bool
omni Bool -> Bool -> Bool
|| Entity
e Entity -> EntityProperty -> Bool
`hasProperty` EntityProperty
Portable)
      forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Bool -> [Text] -> m ()
`holdsOrFail` [Text
"The", Entity
e forall s a. s -> Getting a s a -> a
^. Lens' Entity Text
entityName, Text
"here can't be", Text
verbed forall a. Semigroup a => a -> a -> a
<> Text
"."]

    -- Remove the entity from the world.
    forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
Cosmic Location -> (Maybe Entity -> Maybe Entity) -> m ()
updateEntityAt Cosmic Location
loc (forall a b. a -> b -> a
const forall a. Maybe a
Nothing)
    forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
m ()
flagRedraw

    -- Immediately regenerate entities with 'infinite' property.
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Entity
e Entity -> EntityProperty -> Bool
`hasProperty` EntityProperty
Infinite) forall a b. (a -> b) -> a -> b
$
      forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
Cosmic Location -> (Maybe Entity -> Maybe Entity) -> m ()
updateEntityAt Cosmic Location
loc (forall a b. a -> b -> a
const (forall a. a -> Maybe a
Just Entity
e))

    -- Possibly regrow the entity, if it is growable and the 'harvest'
    -- command was used.
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Entity
e Entity -> EntityProperty -> Bool
`hasProperty` EntityProperty
Growable) Bool -> Bool -> Bool
&& GrabbingCmd
cmd forall a. Eq a => a -> a -> Bool
== GrabbingCmd
Harvest') forall a b. (a -> b) -> a -> b
$ do
      let GrowthTime (Integer
minT, Integer
maxT) = (Entity
e forall s a. s -> Getting a s a -> a
^. Lens' Entity (Maybe GrowthTime)
entityGrowth) forall a. Maybe a -> a -> a
? GrowthTime
defaultGrowthTime

      TimeSpec
createdAt <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Lift IO) sig m =>
m TimeSpec
getNow

      -- Grow a new entity from a seed.
      forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
Entity -> (Integer, Integer) -> Cosmic Location -> TimeSpec -> m ()
addSeedBot Entity
e (Integer
minT, Integer
maxT) Cosmic Location
loc TimeSpec
createdAt

    -- Add the picked up item to the robot's inventory.  If the
    -- entity yields something different, add that instead.
    let yieldName :: Maybe Text
yieldName = Entity
e forall s a. s -> Getting a s a -> a
^. Lens' Entity (Maybe Text)
entityYields
    Entity
e' <- case Maybe Text
yieldName of
      Maybe Text
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Entity
e
      Just Text
n -> forall a. a -> Maybe a -> a
fromMaybe Entity
e forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s a b (f :: * -> *) (sig :: (* -> *) -> * -> *).
Has (State s) sig f =>
Getting a s a -> (a -> b) -> f b
uses (Lens' GameState Landscape
landscape forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Landscape EntityMap
entityMap) (Text -> EntityMap -> Maybe Entity
lookupEntityName Text
n)

    Lens' Robot Inventory
robotInventory forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= Entity -> Inventory -> Inventory
insert Entity
e'
    forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Entity -> m ()
updateDiscoveredEntities Entity
e'

    -- Return the item obtained.
    forall (m :: * -> *) a. Monad m => a -> m a
return Entity
e'

------------------------------------------------------------
-- 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
  RID
rid <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot RID
robotID
  Lens' GameState (Map (Cosmic Location) (Set RID))
robotsWatching forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith forall a. Semigroup a => a -> a -> a
(<>) Cosmic Location
loc (forall a. a -> Set a
S.singleton RID
rid)

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

  let isNearby :: Cosmic Location -> Bool
isNearby = Bool -> Cosmic Location -> Cosmic Location -> Bool
isNearbyOrExempt Bool
privileged Cosmic Location
myLoc
      f :: Cosmic Location -> Set RID -> Set RID
f Cosmic Location
loc =
        if Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Cosmic Location -> Bool
isNearby Cosmic Location
loc
          then forall a. Ord a => a -> Set a -> Set a
S.delete RID
rid
          else forall a. a -> a
id

  Lens' GameState (Map (Cosmic Location) (Set RID))
robotsWatching forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a b. (k -> a -> b) -> Map k a -> Map k b
M.mapWithKey Cosmic Location -> Set RID -> Set RID
f

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

-- | 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 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 forall a. Ord a => a -> a -> Bool
<= Int32
1

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
  ZonedTime
currentTime <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Lift IO) sig m =>
IO a -> m a
sendIO IO ZonedTime
getZonedTime
  Maybe String
scenarioPath <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' GameState (Maybe String)
currentScenarioPath
  Lens' GameState Discovery
discovery forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Discovery (Map GameplayAchievement Attainment)
gameAchievements
    forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith
      forall a. Semigroup a => a -> a -> a
(<>)
      GameplayAchievement
a
      (CategorizedAchievement -> Maybe String -> ZonedTime -> Attainment
Attainment (GameplayAchievement -> CategorizedAchievement
GameplayAchievement GameplayAchievement
a) Maybe String
scenarioPath ZonedTime
currentTime)

-- | How to handle failure, for example when moving to blocked location
data RobotFailure = ThrowExn | Destroy | IgnoreFail

-- | How to handle different types of failure when moving/teleporting
--   to a location.
type MoveFailureHandler = MoveFailureMode -> RobotFailure

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

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

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

-- | 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 " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall s a. s -> Getting a s a -> a
^. Lens' Entity Text
entityName) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
S.toList

-- | 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 =>
RID -> Inventory -> Inventory -> m ()
provisionChild RID
childID Inventory
toEquip Inventory
toGive = do
  -- Equip and give devices to child
  Lens' GameState (IntMap Robot)
robotMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix RID
childID forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Robot Inventory
equippedDevices 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
  Lens' GameState (IntMap Robot)
robotMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix RID
childID forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Robot Inventory
robotInventory 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 <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' GameState Bool
creativeMode
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
creative forall a b. (a -> b) -> a -> b
$
    Lens' Robot Inventory
robotInventory 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))

-- | 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 forall a. Eq a => a -> a -> Bool
== Cosmic Location
newLoc = forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise = do
      Cosmic Location
newlocWithPortal <- forall {sig :: (* -> *) -> * -> *} {m :: * -> *}.
(Algebra sig m, Member (State Robot) sig,
 Member (State GameState) sig) =>
Cosmic Location -> m (Cosmic Location)
applyPortal Cosmic Location
newLoc
      RID
rid <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot RID
robotID
      forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
Cosmic Location -> RID -> m ()
removeRobotFromLocationMap Cosmic Location
oldLoc RID
rid
      forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
RID -> Cosmic Location -> m ()
addRobotToLocation RID
rid Cosmic Location
newlocWithPortal
      forall s (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
(s -> s) -> m ()
modify (Cosmic Location -> Robot -> Robot
unsafeSetRobotLocation Cosmic Location
newlocWithPortal)
      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 <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use forall a b. (a -> b) -> a -> b
$ Lens' GameState Landscape
landscape forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Landscape (Navigation (Map SubworldName) Location)
worldNavigation
    let maybePortalInfo :: Maybe (AnnotatedDestination Location)
maybePortalInfo = forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Cosmic Location
loc forall a b. (a -> b) -> a -> b
$ forall (additionalDimension :: * -> *) portalExitLoc.
Navigation additionalDimension portalExitLoc
-> Map (Cosmic Location) (AnnotatedDestination portalExitLoc)
portals Navigation (Map SubworldName) Location
lms
        updatedLoc :: Cosmic Location
updatedLoc = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Cosmic Location
loc forall a. AnnotatedDestination a -> Cosmic a
destination Maybe (AnnotatedDestination Location)
maybePortalInfo
        maybeTurn :: Maybe Direction
maybeTurn = forall a. AnnotatedDestination a -> Direction
reorientation forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (AnnotatedDestination Location)
maybePortalInfo
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Direction
maybeTurn forall a b. (a -> b) -> a -> b
$ \Direction
d ->
      Lens' Robot (Maybe Heading)
robotOrientation forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= Direction -> Heading -> Heading
applyTurn Direction
d
    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) =>
RID
-> (forall (sig' :: (* -> *) -> * -> *) (m' :: * -> *).
    (HasRobotStepState sig' m', Has (Lift IO) sig' m') =>
    m' ())
-> m ()
onTarget RID
rid forall (sig' :: (* -> *) -> * -> *) (m' :: * -> *).
(HasRobotStepState sig' m', Has (Lift IO) sig' m') =>
m' ()
act = do
  RID
myID <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot RID
robotID
  case RID
myID forall a. Eq a => a -> a -> Bool
== RID
rid of
    Bool
True -> forall (sig' :: (* -> *) -> * -> *) (m' :: * -> *).
(HasRobotStepState sig' m', Has (Lift IO) sig' m') =>
m' ()
act
    Bool
False -> do
      Maybe Robot
mtgt <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use (Lens' GameState (IntMap Robot)
robotMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at RID
rid)
      case Maybe Robot
mtgt of
        Maybe Robot
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just Robot
tgt -> do
          Robot
tgt' <- forall s (m :: * -> *) a. Functor m => s -> StateC s m a -> m s
execState @Robot Robot
tgt forall (sig' :: (* -> *) -> * -> *) (m' :: * -> *).
(HasRobotStepState sig' m', Has (Lift IO) sig' m') =>
m' ()
act
          if Robot
tgt' forall s a. s -> Getting a s a -> a
^. Lens' Robot Bool
selfDestruct
            then forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
RID -> m ()
deleteRobot RID
rid
            else Lens' GameState (IntMap Robot)
robotMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix RID
rid forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= Robot
tgt'

------------------------------------------------------------
-- Comparison
------------------------------------------------------------

-- | Evaluate the application of a comparison operator.  Returns
--   @Nothing@ if the application does not make sense.
evalCmp :: Has (Throw Exn) sig m => Const -> Value -> Value -> m Bool
evalCmp :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Const -> Value -> Value -> m Bool
evalCmp Const
c Value
v1 Value
v2 = Const -> m Ordering -> m Bool
decideCmp Const
c forall a b. (a -> b) -> a -> b
$ forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Value -> Value -> m Ordering
compareValues Value
v1 Value
v2
 where
  decideCmp :: Const -> m Ordering -> m Bool
decideCmp = \case
    Const
Eq -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Eq a => a -> a -> Bool
== Ordering
EQ)
    Const
Neq -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Eq a => a -> a -> Bool
/= Ordering
EQ)
    Const
Lt -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Eq a => a -> a -> Bool
== Ordering
LT)
    Const
Gt -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Eq a => a -> a -> Bool
== Ordering
GT)
    Const
Leq -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Eq a => a -> a -> Bool
/= Ordering
GT)
    Const
Geq -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Eq a => a -> a -> Bool
/= Ordering
LT)
    Const
_ -> forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Exn
Fatal forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text
T.append Text
"evalCmp called on bad constant " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall source target. From source target => source -> target
from forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Const
c

-- | Compare two values, returning an 'Ordering' if they can be
--   compared, or @Nothing@ if they cannot.
compareValues :: Has (Throw Exn) sig m => Value -> Value -> m Ordering
compareValues :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Value -> Value -> m Ordering
compareValues Value
v1 = case Value
v1 of
  Value
VUnit -> \case Value
VUnit -> forall (m :: * -> *) a. Monad m => a -> m a
return Ordering
EQ; Value
v2 -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Value -> Value -> m a
incompatCmp Value
VUnit Value
v2
  VInt Integer
n1 -> \case VInt Integer
n2 -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Ord a => a -> a -> Ordering
compare Integer
n1 Integer
n2); Value
v2 -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Value -> Value -> m a
incompatCmp Value
v1 Value
v2
  VText Text
t1 -> \case VText Text
t2 -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Ord a => a -> a -> Ordering
compare Text
t1 Text
t2); Value
v2 -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Value -> Value -> m a
incompatCmp Value
v1 Value
v2
  VDir Direction
d1 -> \case VDir Direction
d2 -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Ord a => a -> a -> Ordering
compare Direction
d1 Direction
d2); Value
v2 -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Value -> Value -> m a
incompatCmp Value
v1 Value
v2
  VBool Bool
b1 -> \case VBool Bool
b2 -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Ord a => a -> a -> Ordering
compare Bool
b1 Bool
b2); Value
v2 -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Value -> Value -> m a
incompatCmp Value
v1 Value
v2
  VRobot RID
r1 -> \case VRobot RID
r2 -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Ord a => a -> a -> Ordering
compare RID
r1 RID
r2); Value
v2 -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Value -> Value -> m a
incompatCmp Value
v1 Value
v2
  VInj Bool
s1 Value
v1' -> \case
    VInj Bool
s2 Value
v2' ->
      case forall a. Ord a => a -> a -> Ordering
compare Bool
s1 Bool
s2 of
        Ordering
EQ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Value -> Value -> m Ordering
compareValues Value
v1' Value
v2'
        Ordering
o -> forall (m :: * -> *) a. Monad m => a -> m a
return Ordering
o
    Value
v2 -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Value -> Value -> m a
incompatCmp Value
v1 Value
v2
  VPair Value
v11 Value
v12 -> \case
    VPair Value
v21 Value
v22 ->
      forall a. Semigroup a => a -> a -> a
(<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Value -> Value -> m Ordering
compareValues Value
v11 Value
v21 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Value -> Value -> m Ordering
compareValues Value
v12 Value
v22
    Value
v2 -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Value -> Value -> m a
incompatCmp Value
v1 Value
v2
  VRcd Map Text Value
m1 -> \case
    VRcd Map Text Value
m2 -> forall a. Monoid a => [a] -> a
mconcat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Value -> Value -> m Ordering
compareValues forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall k a. Map k a -> [a]
M.elems) Map Text Value
m1 Map Text Value
m2
    Value
v2 -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Value -> Value -> m a
incompatCmp Value
v1 Value
v2
  VKey KeyCombo
kc1 -> \case
    VKey KeyCombo
kc2 -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Ord a => a -> a -> Ordering
compare KeyCombo
kc1 KeyCombo
kc2)
    Value
v2 -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Value -> Value -> m a
incompatCmp Value
v1 Value
v2
  VClo {} -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Value -> Value -> m a
incomparable Value
v1
  VCApp {} -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Value -> Value -> m a
incomparable Value
v1
  VDef {} -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Value -> Value -> m a
incomparable Value
v1
  VResult {} -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Value -> Value -> m a
incomparable Value
v1
  VBind {} -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Value -> Value -> m a
incomparable Value
v1
  VDelay {} -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Value -> Value -> m a
incomparable Value
v1
  VRef {} -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Value -> Value -> m a
incomparable Value
v1
  VRequirements {} -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Value -> Value -> m a
incomparable Value
v1

-- | Values with different types were compared; this should not be
--   possible since the type system should catch it.
incompatCmp :: Has (Throw Exn) sig m => Value -> Value -> m a
incompatCmp :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Value -> Value -> m a
incompatCmp Value
v1 Value
v2 =
  forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError forall a b. (a -> b) -> a -> b
$
    Text -> Exn
Fatal forall a b. (a -> b) -> a -> b
$
      [Text] -> Text
T.unwords [Text
"Incompatible comparison of ", Value -> Text
prettyValue Value
v1, Text
"and", Value -> Text
prettyValue Value
v2]

-- | Values were compared of a type which cannot be compared
--   (e.g. functions, etc.).
incomparable :: Has (Throw Exn) sig m => Value -> Value -> m a
incomparable :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Value -> Value -> m a
incomparable Value
v1 Value
v2 =
  forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError forall a b. (a -> b) -> a -> b
$
    Const -> [Text] -> Exn
cmdExn
      Const
Lt
      [Text
"Comparison is undefined for ", Value -> Text
prettyValue Value
v1, Text
"and", Value -> Text
prettyValue Value
v2]

------------------------------------------------------------
-- Arithmetic
------------------------------------------------------------

-- | Evaluate the application of an arithmetic operator, returning
--   an exception in the case of a failing operation, or in case we
--   incorrectly use it on a bad 'Const' in the library.
evalArith :: Has (Throw Exn) sig m => Const -> Integer -> Integer -> m Integer
evalArith :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Const -> Integer -> Integer -> m Integer
evalArith = \case
  Const
Add -> forall {m :: * -> *} {t} {t} {a}.
Monad m =>
(t -> t -> a) -> t -> t -> m a
ok forall a. Num a => a -> a -> a
(+)
  Const
Sub -> forall {m :: * -> *} {t} {t} {a}.
Monad m =>
(t -> t -> a) -> t -> t -> m a
ok (-)
  Const
Mul -> forall {m :: * -> *} {t} {t} {a}.
Monad m =>
(t -> t -> a) -> t -> t -> m a
ok forall a. Num a => a -> a -> a
(*)
  Const
Div -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Integer -> Integer -> m Integer
safeDiv
  Const
Exp -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Integer -> Integer -> m Integer
safeExp
  Const
c -> \Integer
_ Integer
_ -> forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text -> Exn
Fatal forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text
T.append Text
"evalArith called on bad constant " (forall source target. From source target => source -> target
from (forall a. Show a => a -> String
show Const
c))
 where
  ok :: (t -> t -> a) -> t -> t -> m a
ok t -> t -> a
f t
x t
y = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ t -> t -> a
f t
x t
y

-- | Perform an integer division, but return @Nothing@ for division by
--   zero.
safeDiv :: Has (Throw Exn) sig m => Integer -> Integer -> m Integer
safeDiv :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Integer -> Integer -> m Integer
safeDiv Integer
_ Integer
0 = forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Const -> [Text] -> Exn
cmdExn Const
Div forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"Division by zero"
safeDiv Integer
a Integer
b = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Integer
a forall a. Integral a => a -> a -> a
`div` Integer
b

-- | Perform exponentiation, but return @Nothing@ if the power is negative.
safeExp :: Has (Throw Exn) sig m => Integer -> Integer -> m Integer
safeExp :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Integer -> Integer -> m Integer
safeExp Integer
a Integer
b
  | Integer
b forall a. Ord a => a -> a -> Bool
< Integer
0 = forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Const -> [Text] -> Exn
cmdExn Const
Exp forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"Negative exponent"
  | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Integer
a forall a b. (Num a, Integral b) => a -> b -> a
^ Integer
b

------------------------------------------------------------
-- 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 <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use forall a b. (a -> b) -> a -> b
$ Lens' GameState Discovery
discovery forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Discovery Inventory
allDiscoveredEntities
  if Entity -> Inventory -> Bool
E.contains0plus Entity
e Inventory
allDiscovered
    then forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    else do
      let newAllDiscovered :: Inventory
newAllDiscovered = RID -> Entity -> Inventory -> Inventory
E.insertCount RID
1 Entity
e Inventory
allDiscovered
      forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
(Inventory, Inventory) -> Entity -> m ()
updateAvailableRecipes (Inventory
newAllDiscovered, Inventory
newAllDiscovered) Entity
e
      forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
Entity -> m ()
updateAvailableCommands Entity
e
      Lens' GameState Discovery
discovery forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Discovery Inventory
allDiscoveredEntities 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 <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use forall a b. (a -> b) -> a -> b
$ Lens' GameState Recipes
recipesInfo forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall a. (a -> Bool) -> [a] -> [a]
filter ((Inventory, Inventory) -> Recipe Entity -> Bool
knowsIngredientsFor (Inventory, Inventory)
invs) [Recipe Entity]
entityRecipes
  [Recipe Entity]
knownRecipes <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use forall a b. (a -> b) -> a -> b
$ Lens' GameState Discovery
discovery forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Discovery (Notifications (Recipe Entity))
availableRecipes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a1 a2. Lens (Notifications a1) (Notifications a2) [a1] [a2]
notificationsContent
  let newRecipes :: [Recipe Entity]
newRecipes = forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Recipe Entity]
knownRecipes) [Recipe Entity]
usableRecipes
      newCount :: RID
newCount = forall (t :: * -> *) a. Foldable t => t a -> RID
length [Recipe Entity]
newRecipes
  Lens' GameState Discovery
discovery forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Discovery (Notifications (Recipe Entity))
availableRecipes forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= forall a. Monoid a => a -> a -> a
mappend (forall a. RID -> [a] -> Notifications a
Notifications RID
newCount [Recipe Entity]
newRecipes)
  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 :: Set Capability
newCaps = Entity
e forall s a. s -> Getting a s a -> a
^. Lens' Entity (Set Capability)
entityCapabilities
      keepConsts :: Maybe Capability -> Bool
keepConsts = \case
        Just Capability
cap -> Capability
cap forall a. Ord a => a -> Set a -> Bool
`S.member` Set Capability
newCaps
        Maybe Capability
Nothing -> Bool
False
      entityConsts :: [Const]
entityConsts = forall a. (a -> Bool) -> [a] -> [a]
filter (Maybe Capability -> Bool
keepConsts forall b c a. (b -> c) -> (a -> b) -> a -> c
. Const -> Maybe Capability
constCaps) [Const]
allConst
  [Const]
knownCommands <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use forall a b. (a -> b) -> a -> b
$ Lens' GameState Discovery
discovery forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Discovery (Notifications Const)
availableCommands forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a1 a2. Lens (Notifications a1) (Notifications a2) [a1] [a2]
notificationsContent
  let newCommands :: [Const]
newCommands = forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Const]
knownCommands) [Const]
entityConsts
      newCount :: RID
newCount = forall (t :: * -> *) a. Foldable t => t a -> RID
length [Const]
newCommands
  Lens' GameState Discovery
discovery forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Discovery (Notifications Const)
availableCommands forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= forall a. Monoid a => a -> a -> a
mappend (forall a. RID -> [a] -> Notifications a
Notifications RID
newCount [Const]
newCommands)