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

-- |
-- SPDX-License-Identifier: BSD-3-Clause
-- Description: Stepping robot CESK machines
--
-- 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.Carrier.Error.Either (ErrorC, runError)
import Control.Carrier.State.Lazy
import Control.Carrier.Throw.Either (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_, unless, when)
import Data.Foldable.Extra (notNull)
import Data.Functor (void)
import Data.IntMap qualified as IM
import Data.IntSet qualified as IS
import Data.Map qualified as M
import Data.Maybe (fromMaybe)
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 Linear (zero)
import Prettyprinter (pretty)
import Swarm.Effect as Effect (Time, getNow)
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.Exception
import Swarm.Game.Land
import Swarm.Game.Robot
import Swarm.Game.Robot.Activity
import Swarm.Game.Robot.Concrete
import Swarm.Game.Robot.Walk (emptyExceptions)
import Swarm.Game.Scenario.Objective qualified as OB
import Swarm.Game.Scenario.Objective.WinCheck qualified as WC
import Swarm.Game.State
import Swarm.Game.State.Landscape
import Swarm.Game.State.Robot
import Swarm.Game.State.Substate
import Swarm.Game.Step.Const
import Swarm.Game.Step.RobotStepState
import Swarm.Game.Step.Util
import Swarm.Game.Step.Util.Command
import Swarm.Game.Tick
import Swarm.Language.Capability
import Swarm.Language.Requirements qualified as R
import Swarm.Language.Syntax
import Swarm.Language.TDVar (tdVarName)
import Swarm.Language.Typed (Typed (..))
import Swarm.Language.Value
import Swarm.Log
import Swarm.Pretty (BulletList (BulletList, bulletListItems), prettyText)
import Swarm.Util hiding (both)
import Swarm.Util.WindowedCounter qualified as WC
import System.Clock (TimeSpec)
import Witch (From (from))
import Prelude hiding (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 :: HasGameStepState sig m => m Bool
gameTick :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasGameStepState sig m =>
m Bool
gameTick = do
  TickNumber
time <- Getting TickNumber GameState TickNumber -> m TickNumber
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use (Getting TickNumber GameState TickNumber -> m TickNumber)
-> Getting TickNumber GameState TickNumber -> m TickNumber
forall a b. (a -> b) -> a -> b
$ (TemporalState -> Const TickNumber TemporalState)
-> GameState -> Const TickNumber GameState
Lens' GameState TemporalState
temporal ((TemporalState -> Const TickNumber TemporalState)
 -> GameState -> Const TickNumber GameState)
-> ((TickNumber -> Const TickNumber TickNumber)
    -> TemporalState -> Const TickNumber TemporalState)
-> Getting TickNumber GameState TickNumber
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TickNumber -> Const TickNumber TickNumber)
-> TemporalState -> Const TickNumber TemporalState
Lens' TemporalState TickNumber
ticks
  StateC Robots Identity () -> m ()
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) b.
Has (State GameState) sig m =>
StateC Robots Identity b -> m b
zoomRobots (StateC Robots Identity () -> m ())
-> StateC Robots Identity () -> m ()
forall a b. (a -> b) -> a -> b
$ TickNumber -> StateC Robots Identity ()
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State Robots) sig m =>
TickNumber -> m ()
wakeUpRobotsDoneSleeping TickNumber
time
  IntSet
active <- Getting IntSet GameState IntSet -> m IntSet
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use (Getting IntSet GameState IntSet -> m IntSet)
-> Getting IntSet GameState IntSet -> m IntSet
forall a b. (a -> b) -> a -> b
$ (Robots -> Const IntSet Robots)
-> GameState -> Const IntSet GameState
Lens' GameState Robots
robotInfo ((Robots -> Const IntSet Robots)
 -> GameState -> Const IntSet GameState)
-> ((IntSet -> Const IntSet IntSet)
    -> Robots -> Const IntSet Robots)
-> Getting IntSet GameState IntSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IntSet -> Const IntSet IntSet) -> Robots -> Const IntSet Robots
Getter Robots IntSet
activeRobots
  RID
focusedRob <- Getting RID GameState RID -> m RID
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use (Getting RID GameState RID -> m RID)
-> Getting RID GameState RID -> m RID
forall a b. (a -> b) -> a -> b
$ (Robots -> Const RID Robots) -> GameState -> Const RID GameState
Lens' GameState Robots
robotInfo ((Robots -> Const RID Robots) -> GameState -> Const RID GameState)
-> ((RID -> Const RID RID) -> Robots -> Const RID Robots)
-> Getting RID GameState RID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RID -> Const RID RID) -> Robots -> Const RID Robots
Getter Robots RID
focusedRobotID

  Bool
ticked <-
    Getting Step GameState Step -> m Step
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use ((TemporalState -> Const Step TemporalState)
-> GameState -> Const Step GameState
Lens' GameState TemporalState
temporal ((TemporalState -> Const Step TemporalState)
 -> GameState -> Const Step GameState)
-> ((Step -> Const Step Step)
    -> TemporalState -> Const Step TemporalState)
-> Getting Step GameState Step
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Step -> Const Step Step)
-> TemporalState -> Const Step TemporalState
Lens' TemporalState Step
gameStep) m Step -> (Step -> m Bool) -> m Bool
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Step
WorldTick -> do
        IntSet -> m ()
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasGameStepState sig m =>
IntSet -> m ()
runRobotIDs IntSet
active
        (TemporalState -> Identity TemporalState)
-> GameState -> Identity GameState
Lens' GameState TemporalState
temporal ((TemporalState -> Identity TemporalState)
 -> GameState -> Identity GameState)
-> ((TickNumber -> Identity TickNumber)
    -> TemporalState -> Identity TemporalState)
-> (TickNumber -> Identity TickNumber)
-> GameState
-> Identity GameState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TickNumber -> Identity TickNumber)
-> TemporalState -> Identity TemporalState
Lens' TemporalState TickNumber
ticks ((TickNumber -> Identity TickNumber)
 -> GameState -> Identity GameState)
-> (TickNumber -> TickNumber) -> m ()
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
        Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
      RobotStep SingleStep
ss -> SingleStep -> RID -> IntSet -> m Bool
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasGameStepState 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 <- Getting (Maybe Robot) GameState (Maybe Robot) -> m (Maybe Robot)
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use ((Robots -> Const (Maybe Robot) Robots)
-> GameState -> Const (Maybe Robot) GameState
Lens' GameState Robots
robotInfo ((Robots -> Const (Maybe Robot) Robots)
 -> GameState -> Const (Maybe Robot) GameState)
-> ((Maybe Robot -> Const (Maybe Robot) (Maybe Robot))
    -> Robots -> Const (Maybe Robot) Robots)
-> Getting (Maybe Robot) GameState (Maybe Robot)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IntMap Robot -> Const (Maybe Robot) (IntMap Robot))
-> Robots -> Const (Maybe Robot) Robots
Lens' Robots (IntMap Robot)
robotMap ((IntMap Robot -> Const (Maybe Robot) (IntMap Robot))
 -> Robots -> Const (Maybe Robot) Robots)
-> ((Maybe Robot -> Const (Maybe Robot) (Maybe Robot))
    -> IntMap Robot -> Const (Maybe Robot) (IntMap Robot))
-> (Maybe Robot -> Const (Maybe Robot) (Maybe Robot))
-> Robots
-> Const (Maybe Robot) Robots
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (IntMap Robot)
-> Lens' (IntMap Robot) (Maybe (IxValue (IntMap Robot)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at RID
Index (IntMap Robot)
0)
  Maybe Robot -> (Robot -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Robot
mr ((Robot -> m ()) -> m ()) -> (Robot -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Robot
r -> do
    REPLStatus
res <- Getting REPLStatus GameState REPLStatus -> m REPLStatus
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use (Getting REPLStatus GameState REPLStatus -> m REPLStatus)
-> Getting REPLStatus GameState REPLStatus -> m REPLStatus
forall a b. (a -> b) -> a -> b
$ (GameControls -> Const REPLStatus GameControls)
-> GameState -> Const REPLStatus GameState
Lens' GameState GameControls
gameControls ((GameControls -> Const REPLStatus GameControls)
 -> GameState -> Const REPLStatus GameState)
-> ((REPLStatus -> Const REPLStatus REPLStatus)
    -> GameControls -> Const REPLStatus GameControls)
-> Getting REPLStatus GameState REPLStatus
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (REPLStatus -> Const REPLStatus REPLStatus)
-> GameControls -> Const REPLStatus GameControls
Lens' GameControls REPLStatus
replStatus
    case REPLStatus
res of
      REPLWorking Polytype
ty Maybe Value
Nothing -> Maybe Value -> (Value -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Robot -> Maybe Value
getResult Robot
r) ((Value -> m ()) -> m ()) -> (Value -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Value
v ->
        (GameControls -> Identity GameControls)
-> GameState -> Identity GameState
Lens' GameState GameControls
gameControls ((GameControls -> Identity GameControls)
 -> GameState -> Identity GameState)
-> ((REPLStatus -> Identity REPLStatus)
    -> GameControls -> Identity GameControls)
-> (REPLStatus -> Identity REPLStatus)
-> GameState
-> Identity GameState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (REPLStatus -> Identity REPLStatus)
-> GameControls -> Identity GameControls
Lens' GameControls REPLStatus
replStatus ((REPLStatus -> Identity REPLStatus)
 -> GameState -> Identity GameState)
-> REPLStatus -> m ()
forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= Polytype -> Maybe Value -> REPLStatus
REPLWorking Polytype
ty (Value -> Maybe Value
forall a. a -> Maybe a
Just Value
v)
      REPLStatus
_otherREPLStatus -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

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

  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ticked (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    -- On new tick see if the winning condition for the current objective is met.
    WinCondition
wc <- Getting WinCondition GameState WinCondition -> m WinCondition
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getting WinCondition GameState WinCondition
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 <- Getting EntityMap GameState EntityMap -> m EntityMap
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use (Getting EntityMap GameState EntityMap -> m EntityMap)
-> Getting EntityMap GameState EntityMap -> m EntityMap
forall a b. (a -> b) -> a -> b
$ (Landscape -> Const EntityMap Landscape)
-> GameState -> Const EntityMap GameState
Lens' GameState Landscape
landscape ((Landscape -> Const EntityMap Landscape)
 -> GameState -> Const EntityMap GameState)
-> ((EntityMap -> Const EntityMap EntityMap)
    -> Landscape -> Const EntityMap Landscape)
-> Getting EntityMap GameState EntityMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TerrainEntityMaps -> Const EntityMap TerrainEntityMaps)
-> Landscape -> Const EntityMap Landscape
Lens' Landscape TerrainEntityMaps
terrainAndEntities ((TerrainEntityMaps -> Const EntityMap TerrainEntityMaps)
 -> Landscape -> Const EntityMap Landscape)
-> ((EntityMap -> Const EntityMap EntityMap)
    -> TerrainEntityMaps -> Const EntityMap TerrainEntityMaps)
-> (EntityMap -> Const EntityMap EntityMap)
-> Landscape
-> Const EntityMap Landscape
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EntityMap -> Const EntityMap EntityMap)
-> TerrainEntityMaps -> Const EntityMap TerrainEntityMaps
Lens' TerrainEntityMaps EntityMap
entityMap
        EntityMap -> GameState -> WinStatus -> ObjectiveCompletion -> m ()
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has Time sig m,
 Has (Lift IO) sig m) =>
EntityMap -> GameState -> WinStatus -> ObjectiveCompletion -> m ()
hypotheticalWinCheck EntityMap
em GameState
g WinStatus
winState ObjectiveCompletion
oc
      WinCondition
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  Bool -> m Bool
forall a. a -> m a
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 :: HasGameStepState sig m => m ()
finishGameTick :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasGameStepState sig m =>
m ()
finishGameTick =
  Getting Step GameState Step -> m Step
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use ((TemporalState -> Const Step TemporalState)
-> GameState -> Const Step GameState
Lens' GameState TemporalState
temporal ((TemporalState -> Const Step TemporalState)
 -> GameState -> Const Step GameState)
-> ((Step -> Const Step Step)
    -> TemporalState -> Const Step TemporalState)
-> Getting Step GameState Step
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Step -> Const Step Step)
-> TemporalState -> Const Step TemporalState
Lens' TemporalState Step
gameStep) m Step -> (Step -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Step
WorldTick -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    RobotStep SingleStep
SBefore -> (TemporalState -> Identity TemporalState)
-> GameState -> Identity GameState
Lens' GameState TemporalState
temporal ((TemporalState -> Identity TemporalState)
 -> GameState -> Identity GameState)
-> ((Step -> Identity Step)
    -> TemporalState -> Identity TemporalState)
-> (Step -> Identity Step)
-> GameState
-> Identity GameState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Step -> Identity Step) -> TemporalState -> Identity TemporalState
Lens' TemporalState Step
gameStep ((Step -> Identity Step) -> GameState -> Identity GameState)
-> Step -> m ()
forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= Step
WorldTick
    RobotStep SingleStep
_ -> m Bool -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void m Bool
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasGameStepState sig m =>
m Bool
gameTick m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m ()
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasGameStepState 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 <- Getting TickNumber GameState TickNumber -> m TickNumber
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use (Getting TickNumber GameState TickNumber -> m TickNumber)
-> Getting TickNumber GameState TickNumber -> m TickNumber
forall a b. (a -> b) -> a -> b
$ (TemporalState -> Const TickNumber TemporalState)
-> GameState -> Const TickNumber GameState
Lens' GameState TemporalState
temporal ((TemporalState -> Const TickNumber TemporalState)
 -> GameState -> Const TickNumber GameState)
-> ((TickNumber -> Const TickNumber TickNumber)
    -> TemporalState -> Const TickNumber TemporalState)
-> Getting TickNumber GameState TickNumber
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TickNumber -> Const TickNumber TickNumber)
-> TemporalState -> Const TickNumber TemporalState
Lens' TemporalState TickNumber
ticks
  StateC Robots Identity () -> m ()
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) b.
Has (State GameState) sig m =>
StateC Robots Identity b -> m b
zoomRobots (StateC Robots Identity () -> m ())
-> StateC Robots Identity () -> m ()
forall a b. (a -> b) -> a -> b
$
    if Robot
rob Robot -> Getting Bool Robot Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool Robot Bool
Lens' Robot Bool
selfDestruct
      then RID -> StateC Robots Identity ()
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State Robots) sig m =>
RID -> m ()
deleteRobot RID
rn
      else do
        (IntMap Robot -> Identity (IntMap Robot))
-> Robots -> Identity Robots
Lens' Robots (IntMap Robot)
robotMap ((IntMap Robot -> Identity (IntMap Robot))
 -> Robots -> Identity Robots)
-> (IntMap Robot -> IntMap Robot) -> StateC Robots Identity ()
forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= RID -> Robot -> IntMap Robot -> IntMap Robot
forall a. RID -> a -> IntMap a -> IntMap a
IM.insert RID
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 TickNumber -> TickNumber -> Bool
forall a. Ord a => a -> a -> Bool
<= RID -> TickNumber -> TickNumber
addTicks RID
2 TickNumber
time -> () -> StateC Robots Identity ()
forall a. a -> StateC Robots Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            | Bool
otherwise -> RID -> TickNumber -> StateC Robots Identity ()
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State Robots) sig m =>
RID -> TickNumber -> m ()
sleepUntil RID
rn TickNumber
wakeUpTime
          Maybe TickNumber
Nothing ->
            Bool -> StateC Robots Identity () -> StateC Robots Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Robot -> Bool
isActive Robot
rob) (RID -> StateC Robots Identity ()
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State Robots) sig m =>
RID -> m ()
sleepForever RID
rn)

-- | GameState with support for IO and Time effect
type HasGameStepState sig m = (Has (State GameState) sig m, Has (Lift IO) sig m, Has Effect.Time sig m)

-- | Run a set of robots - this is used to run robots before/after the focused one.
--
-- Note that during the iteration over the supplied robot IDs, it is possible
-- that a robot that may have been present in 'robotMap' at the outset
-- of the iteration to be removed before the iteration comes upon it.
-- This is why we must perform a 'robotMap' lookup at each iteration, rather
-- than looking up elements from 'robotMap' in bulk up front with something like
-- 'restrictKeys'.
--
-- = Invariants
--
-- * Every tick, every active robot shall have exactly one opportunity to run.
-- * The sequence in which robots are chosen to run is by increasing order of 'RID'.
runRobotIDs :: HasGameStepState sig m => IS.IntSet -> m ()
runRobotIDs :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasGameStepState sig m =>
IntSet -> m ()
runRobotIDs IntSet
robotNames = do
  TickNumber
time <- Getting TickNumber GameState TickNumber -> m TickNumber
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use (Getting TickNumber GameState TickNumber -> m TickNumber)
-> Getting TickNumber GameState TickNumber -> m TickNumber
forall a b. (a -> b) -> a -> b
$ (TemporalState -> Const TickNumber TemporalState)
-> GameState -> Const TickNumber GameState
Lens' GameState TemporalState
temporal ((TemporalState -> Const TickNumber TemporalState)
 -> GameState -> Const TickNumber GameState)
-> ((TickNumber -> Const TickNumber TickNumber)
    -> TemporalState -> Const TickNumber TemporalState)
-> Getting TickNumber GameState TickNumber
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TickNumber -> Const TickNumber TickNumber)
-> TemporalState -> Const TickNumber TemporalState
Lens' TemporalState TickNumber
ticks
  ((RID -> m ()) -> IntSet -> m ())
-> IntSet -> (RID -> m ()) -> m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (TickNumber -> (RID -> m ()) -> IntSet -> m ()
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasGameStepState sig m =>
TickNumber -> (RID -> m ()) -> IntSet -> m ()
iterateRobots TickNumber
time) IntSet
robotNames ((RID -> m ()) -> m ()) -> (RID -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \RID
rn -> do
    Maybe Robot
mr <- Getting (IntMap Robot) GameState (IntMap Robot)
-> (IntMap Robot -> Maybe Robot) -> m (Maybe Robot)
forall s a b (f :: * -> *) (sig :: (* -> *) -> * -> *).
Has (State s) sig f =>
Getting a s a -> (a -> b) -> f b
uses ((Robots -> Const (IntMap Robot) Robots)
-> GameState -> Const (IntMap Robot) GameState
Lens' GameState Robots
robotInfo ((Robots -> Const (IntMap Robot) Robots)
 -> GameState -> Const (IntMap Robot) GameState)
-> ((IntMap Robot -> Const (IntMap Robot) (IntMap Robot))
    -> Robots -> Const (IntMap Robot) Robots)
-> Getting (IntMap Robot) GameState (IntMap Robot)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IntMap Robot -> Const (IntMap Robot) (IntMap Robot))
-> Robots -> Const (IntMap Robot) Robots
Lens' Robots (IntMap Robot)
robotMap) (RID -> IntMap Robot -> Maybe Robot
forall a. RID -> IntMap a -> Maybe a
IM.lookup RID
rn)
    Maybe Robot -> (Robot -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Robot
mr (RID -> Robot -> m ()
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasGameStepState sig m =>
RID -> Robot -> m ()
stepOneRobot RID
rn)
 where
  stepOneRobot :: HasGameStepState sig m => RID -> Robot -> m ()
  stepOneRobot :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasGameStepState sig m =>
RID -> Robot -> m ()
stepOneRobot RID
rn Robot
rob = Robot -> m Robot
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasGameStepState sig m =>
Robot -> m Robot
tickRobot Robot
rob m Robot -> (Robot -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= RID -> Robot -> m ()
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
RID -> Robot -> m ()
insertBackRobot RID
rn

-- |
-- Runs the given robots in increasing order of 'RID'.
--
-- Running a given robot _may_ cause another robot
-- with a higher 'RID' to be inserted into the runnable set.
--
-- Note that the behavior we desire is described precisely by a
-- <Monotone_priority_queue https://en.wikipedia.org/wiki/Monotone_priority_queue>.
--
-- A priority queue allows O(1) access to the lowest priority item. However,
-- /splitting/ the min item from rest of the queue is still an O(log N) operation,
-- and therefore is not any better than the 'minView' function from 'IntSet'.
--
-- Tail-recursive.
iterateRobots :: HasGameStepState sig m => TickNumber -> (RID -> m ()) -> IS.IntSet -> m ()
iterateRobots :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasGameStepState sig m =>
TickNumber -> (RID -> m ()) -> IntSet -> m ()
iterateRobots TickNumber
time RID -> m ()
f IntSet
runnableBots =
  Maybe (RID, IntSet) -> ((RID, IntSet) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (IntSet -> Maybe (RID, IntSet)
IS.minView IntSet
runnableBots) (((RID, IntSet) -> m ()) -> m ())
-> ((RID, IntSet) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(RID
thisRobotId, IntSet
remainingBotIDs) -> do
    RID -> m ()
f RID
thisRobotId

    -- We may have awakened new robots in the current robot's iteration,
    -- so we add them to the list
    IntSet -> IntSet
poolAugmentation <- do
      -- NOTE: We could use 'IS.split thisRobotId activeRIDsThisTick'
      -- to ensure that we only insert RIDs greater than 'thisRobotId'
      -- into the queue.
      -- However, we already ensure in 'wakeWatchingRobots' that only
      -- robots with a larger RID are scheduled for the current tick;
      -- robots with smaller RIDs will be scheduled for the next tick.
      [RID]
robotsToAdd <- Getting [RID] GameState [RID] -> m [RID]
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use (Getting [RID] GameState [RID] -> m [RID])
-> Getting [RID] GameState [RID] -> m [RID]
forall a b. (a -> b) -> a -> b
$ (Robots -> Const [RID] Robots)
-> GameState -> Const [RID] GameState
Lens' GameState Robots
robotInfo ((Robots -> Const [RID] Robots)
 -> GameState -> Const [RID] GameState)
-> (([RID] -> Const [RID] [RID]) -> Robots -> Const [RID] Robots)
-> Getting [RID] GameState [RID]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([RID] -> Const [RID] [RID]) -> Robots -> Const [RID] Robots
Lens' Robots [RID]
currentTickWakeableBots
      if [RID] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RID]
robotsToAdd
        then (IntSet -> IntSet) -> m (IntSet -> IntSet)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return IntSet -> IntSet
forall a. a -> a
id
        else do
          StateC Robots Identity () -> m ()
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) b.
Has (State GameState) sig m =>
StateC Robots Identity b -> m b
zoomRobots (StateC Robots Identity () -> m ())
-> StateC Robots Identity () -> m ()
forall a b. (a -> b) -> a -> b
$ TickNumber -> StateC Robots Identity ()
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State Robots) sig m =>
TickNumber -> m ()
wakeUpRobotsDoneSleeping TickNumber
time
          (Robots -> Identity Robots) -> GameState -> Identity GameState
Lens' GameState Robots
robotInfo ((Robots -> Identity Robots) -> GameState -> Identity GameState)
-> (([RID] -> Identity [RID]) -> Robots -> Identity Robots)
-> ([RID] -> Identity [RID])
-> GameState
-> Identity GameState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([RID] -> Identity [RID]) -> Robots -> Identity Robots
Lens' Robots [RID]
currentTickWakeableBots (([RID] -> Identity [RID]) -> GameState -> Identity GameState)
-> [RID] -> m ()
forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= []
          (IntSet -> IntSet) -> m (IntSet -> IntSet)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((IntSet -> IntSet) -> m (IntSet -> IntSet))
-> (IntSet -> IntSet) -> m (IntSet -> IntSet)
forall a b. (a -> b) -> a -> b
$ IntSet -> IntSet -> IntSet
IS.union (IntSet -> IntSet -> IntSet) -> IntSet -> IntSet -> IntSet
forall a b. (a -> b) -> a -> b
$ [RID] -> IntSet
IS.fromList [RID]
robotsToAdd

    TickNumber -> (RID -> m ()) -> IntSet -> m ()
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasGameStepState sig m =>
TickNumber -> (RID -> m ()) -> IntSet -> m ()
iterateRobots TickNumber
time RID -> m ()
f (IntSet -> m ()) -> IntSet -> m ()
forall a b. (a -> b) -> a -> b
$ IntSet -> IntSet
poolAugmentation IntSet
remainingBotIDs

-- | This is a helper function to do one robot step or run robots before/after.
singleStep :: HasGameStepState sig m => SingleStep -> RID -> IS.IntSet -> m Bool
singleStep :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasGameStepState 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
      IntSet -> m ()
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasGameStepState sig m =>
IntSet -> m ()
runRobotIDs IntSet
preFoc
      (TemporalState -> Identity TemporalState)
-> GameState -> Identity GameState
Lens' GameState TemporalState
temporal ((TemporalState -> Identity TemporalState)
 -> GameState -> Identity GameState)
-> ((Step -> Identity Step)
    -> TemporalState -> Identity TemporalState)
-> (Step -> Identity Step)
-> GameState
-> Identity GameState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Step -> Identity Step) -> TemporalState -> Identity TemporalState
Lens' TemporalState Step
gameStep ((Step -> Identity Step) -> GameState -> Identity GameState)
-> Step -> m ()
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 <- Getting RID GameState RID -> m RID
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use (Getting RID GameState RID -> m RID)
-> Getting RID GameState RID -> m RID
forall a b. (a -> b) -> a -> b
$ (TemporalState -> Const RID TemporalState)
-> GameState -> Const RID GameState
Lens' GameState TemporalState
temporal ((TemporalState -> Const RID TemporalState)
 -> GameState -> Const RID GameState)
-> ((RID -> Const RID RID)
    -> TemporalState -> Const RID TemporalState)
-> Getting RID GameState RID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RID -> Const RID RID) -> TemporalState -> Const RID TemporalState
Lens' TemporalState RID
robotStepsPerTick
      (Robots -> Identity Robots) -> GameState -> Identity GameState
Lens' GameState Robots
robotInfo ((Robots -> Identity Robots) -> GameState -> Identity GameState)
-> ((RID -> Identity RID) -> Robots -> Identity Robots)
-> (RID -> Identity RID)
-> GameState
-> Identity GameState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IntMap Robot -> Identity (IntMap Robot))
-> Robots -> Identity Robots
Lens' Robots (IntMap Robot)
robotMap ((IntMap Robot -> Identity (IntMap Robot))
 -> Robots -> Identity Robots)
-> ((RID -> Identity RID)
    -> IntMap Robot -> Identity (IntMap Robot))
-> (RID -> Identity RID)
-> Robots
-> Identity Robots
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (IntMap Robot)
-> Traversal' (IntMap Robot) (IxValue (IntMap Robot))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix RID
Index (IntMap Robot)
focRID ((Robot -> Identity Robot)
 -> IntMap Robot -> Identity (IntMap Robot))
-> ((RID -> Identity RID) -> Robot -> Identity Robot)
-> (RID -> Identity RID)
-> IntMap Robot
-> Identity (IntMap Robot)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ActivityCounts -> Identity ActivityCounts)
-> Robot -> Identity Robot
Lens' Robot ActivityCounts
activityCounts ((ActivityCounts -> Identity ActivityCounts)
 -> Robot -> Identity Robot)
-> ((RID -> Identity RID)
    -> ActivityCounts -> Identity ActivityCounts)
-> (RID -> Identity RID)
-> Robot
-> Identity Robot
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RID -> Identity RID) -> ActivityCounts -> Identity ActivityCounts
Lens' ActivityCounts RID
tickStepBudget ((RID -> Identity RID) -> GameState -> Identity GameState)
-> RID -> m ()
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 SingleStep -> RID -> IntSet -> m Bool
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasGameStepState sig m =>
SingleStep -> RID -> IntSet -> m Bool
singleStep (RID -> SingleStep
SSingle RID
focRID) RID
focRID IntSet
robotSet
        else Bool -> m Bool
forall a. a -> m a
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
      SingleStep -> RID -> IntSet -> m Bool
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasGameStepState 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 <- Getting (IntMap Robot) GameState (IntMap Robot)
-> (IntMap Robot -> Maybe Robot) -> m (Maybe Robot)
forall s a b (f :: * -> *) (sig :: (* -> *) -> * -> *).
Has (State s) sig f =>
Getting a s a -> (a -> b) -> f b
uses ((Robots -> Const (IntMap Robot) Robots)
-> GameState -> Const (IntMap Robot) GameState
Lens' GameState Robots
robotInfo ((Robots -> Const (IntMap Robot) Robots)
 -> GameState -> Const (IntMap Robot) GameState)
-> ((IntMap Robot -> Const (IntMap Robot) (IntMap Robot))
    -> Robots -> Const (IntMap Robot) Robots)
-> Getting (IntMap Robot) GameState (IntMap Robot)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IntMap Robot -> Const (IntMap Robot) (IntMap Robot))
-> Robots -> Const (IntMap Robot) Robots
Lens' Robots (IntMap Robot)
robotMap) (RID -> IntMap Robot -> Maybe Robot
forall a. RID -> IntMap a -> Maybe a
IM.lookup RID
focRID)
      case Maybe Robot
mOldR of
        Maybe Robot
Nothing | RID
rid RID -> RID -> Bool
forall a. Eq a => a -> a -> Bool
== RID
focRID -> do
          Text -> m ()
forall {sig :: (* -> *) -> * -> *} {m :: * -> *}.
(Member (State GameState) sig, Algebra sig m) =>
Text -> m ()
debugLog Text
"The debugged robot does not exist! Exiting single step mode."
          IntSet -> m ()
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasGameStepState sig m =>
IntSet -> m ()
runRobotIDs IntSet
postFoc
          (TemporalState -> Identity TemporalState)
-> GameState -> Identity GameState
Lens' GameState TemporalState
temporal ((TemporalState -> Identity TemporalState)
 -> GameState -> Identity GameState)
-> ((Step -> Identity Step)
    -> TemporalState -> Identity TemporalState)
-> (Step -> Identity Step)
-> GameState
-> Identity GameState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Step -> Identity Step) -> TemporalState -> Identity TemporalState
Lens' TemporalState Step
gameStep ((Step -> Identity Step) -> GameState -> Identity GameState)
-> Step -> m ()
forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= Step
WorldTick
          (TemporalState -> Identity TemporalState)
-> GameState -> Identity GameState
Lens' GameState TemporalState
temporal ((TemporalState -> Identity TemporalState)
 -> GameState -> Identity GameState)
-> ((TickNumber -> Identity TickNumber)
    -> TemporalState -> Identity TemporalState)
-> (TickNumber -> Identity TickNumber)
-> GameState
-> Identity GameState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TickNumber -> Identity TickNumber)
-> TemporalState -> Identity TemporalState
Lens' TemporalState TickNumber
ticks ((TickNumber -> Identity TickNumber)
 -> GameState -> Identity GameState)
-> (TickNumber -> TickNumber) -> m ()
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
          Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        Maybe Robot
Nothing | Bool
otherwise -> do
          Text -> m ()
forall {sig :: (* -> *) -> * -> *} {m :: * -> *}.
(Member (State GameState) sig, Algebra sig m) =>
Text -> m ()
debugLog Text
"The previously debugged robot does not exist!"
          SingleStep -> RID -> IntSet -> m Bool
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasGameStepState 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 RID -> RID -> Bool
forall a. Eq a => a -> a -> Bool
== RID
focRID then Robot -> m Robot
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasGameStepState sig m =>
Robot -> m Robot
stepRobot else Robot -> m Robot
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasGameStepState sig m =>
Robot -> m Robot
tickRobotRec) Robot
oldR
          RID -> Robot -> m ()
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
RID -> Robot -> m ()
insertBackRobot RID
focRID Robot
newR
          if RID
rid RID -> RID -> Bool
forall a. Eq a => a -> a -> Bool
== RID
focRID
            then do
              Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Robot
newR Robot -> Getting RID Robot RID -> RID
forall s a. s -> Getting a s a -> a
^. (ActivityCounts -> Const RID ActivityCounts)
-> Robot -> Const RID Robot
Lens' Robot ActivityCounts
activityCounts ((ActivityCounts -> Const RID ActivityCounts)
 -> Robot -> Const RID Robot)
-> ((RID -> Const RID RID)
    -> ActivityCounts -> Const RID ActivityCounts)
-> Getting RID Robot RID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RID -> Const RID RID)
-> ActivityCounts -> Const RID ActivityCounts
Lens' ActivityCounts RID
tickStepBudget RID -> RID -> Bool
forall a. Eq a => a -> a -> Bool
== RID
0) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
                (TemporalState -> Identity TemporalState)
-> GameState -> Identity GameState
Lens' GameState TemporalState
temporal ((TemporalState -> Identity TemporalState)
 -> GameState -> Identity GameState)
-> ((Step -> Identity Step)
    -> TemporalState -> Identity TemporalState)
-> (Step -> Identity Step)
-> GameState
-> Identity GameState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Step -> Identity Step) -> TemporalState -> Identity TemporalState
Lens' TemporalState Step
gameStep ((Step -> Identity Step) -> GameState -> Identity GameState)
-> Step -> m ()
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)
              Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
            else do
              -- continue to newly focused
              SingleStep -> RID -> IntSet -> m Bool
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasGameStepState 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 RID -> RID -> Bool
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
      IntSet -> m ()
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasGameStepState sig m =>
IntSet -> m ()
runRobotIDs IntSet
postFoc
      (TemporalState -> Identity TemporalState)
-> GameState -> Identity GameState
Lens' GameState TemporalState
temporal ((TemporalState -> Identity TemporalState)
 -> GameState -> Identity GameState)
-> ((Step -> Identity Step)
    -> TemporalState -> Identity TemporalState)
-> (Step -> Identity Step)
-> GameState
-> Identity GameState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Step -> Identity Step) -> TemporalState -> Identity TemporalState
Lens' TemporalState Step
gameStep ((Step -> Identity Step) -> GameState -> Identity GameState)
-> Step -> m ()
forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= SingleStep -> Step
RobotStep SingleStep
SBefore
      (TemporalState -> Identity TemporalState)
-> GameState -> Identity GameState
Lens' GameState TemporalState
temporal ((TemporalState -> Identity TemporalState)
 -> GameState -> Identity GameState)
-> ((TickNumber -> Identity TickNumber)
    -> TemporalState -> Identity TemporalState)
-> (TickNumber -> Identity TickNumber)
-> GameState
-> Identity GameState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TickNumber -> Identity TickNumber)
-> TemporalState -> Identity TemporalState
Lens' TemporalState TickNumber
ticks ((TickNumber -> Identity TickNumber)
 -> GameState -> Identity GameState)
-> (TickNumber -> TickNumber) -> m ()
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
      Bool -> m Bool
forall a. a -> m a
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
      SingleStep -> RID -> IntSet -> m Bool
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasGameStepState 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 (StateC Robot m LogEntry -> m LogEntry)
-> StateC Robot m LogEntry -> m LogEntry
forall a b. (a -> b) -> a -> b
$ RobotLogSource -> Severity -> Text -> StateC Robot m LogEntry
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
    LogEntry -> m ()
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 Effect.Time sig m, Has (Lift IO) sig m) =>
  EntityMap ->
  GameState ->
  WinStatus ->
  ObjectiveCompletion ->
  m ()
hypotheticalWinCheck :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has Time 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 <-
    (CompletionsWithExceptions
 -> Objective -> m CompletionsWithExceptions)
-> CompletionsWithExceptions
-> [Objective]
-> m CompletionsWithExceptions
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM CompletionsWithExceptions
-> Objective -> m CompletionsWithExceptions
forall {m :: * -> *} {sig :: (* -> *) -> * -> *}.
(Algebra sig m, Member (Lift IO) sig, Member Time sig) =>
CompletionsWithExceptions
-> Objective -> m CompletionsWithExceptions
foldFunc CompletionsWithExceptions
initialAccumulator ([Objective] -> m CompletionsWithExceptions)
-> [Objective] -> m CompletionsWithExceptions
forall a b. (a -> b) -> a -> b
$
      [Objective] -> [Objective]
forall a. [a] -> [a]
reverse [Objective]
incompleteGoals

  TickNumber
ts <- Getting TickNumber GameState TickNumber -> m TickNumber
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use (Getting TickNumber GameState TickNumber -> m TickNumber)
-> Getting TickNumber GameState TickNumber -> m TickNumber
forall a b. (a -> b) -> a -> b
$ (TemporalState -> Const TickNumber TemporalState)
-> GameState -> Const TickNumber GameState
Lens' GameState TemporalState
temporal ((TemporalState -> Const TickNumber TemporalState)
 -> GameState -> Const TickNumber GameState)
-> ((TickNumber -> Const TickNumber TickNumber)
    -> TemporalState -> Const TickNumber TemporalState)
-> Getting TickNumber GameState TickNumber
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TickNumber -> Const TickNumber TickNumber)
-> TemporalState -> Const TickNumber TemporalState
Lens' TemporalState TickNumber
ticks
  let newWinState :: WinStatus
newWinState = case WinStatus
ws of
        WinStatus
Ongoing -> TickNumber -> ObjectiveCompletion -> WinStatus
getNextWinState TickNumber
ts (ObjectiveCompletion -> WinStatus)
-> ObjectiveCompletion -> WinStatus
forall a b. (a -> b) -> a -> b
$ CompletionsWithExceptions -> ObjectiveCompletion
completions CompletionsWithExceptions
finalAccumulator
        WinStatus
_ -> WinStatus
ws

  (WinCondition -> Identity WinCondition)
-> GameState -> Identity GameState
Lens' GameState WinCondition
winCondition ((WinCondition -> Identity WinCondition)
 -> GameState -> Identity GameState)
-> WinCondition -> m ()
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
_ -> GameplayAchievement -> m ()
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (Lift IO) sig m) =>
GameplayAchievement -> m ()
grantAchievement GameplayAchievement
LoseScenario
    WinStatus
_ -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  Seq Announcement
queue <- (Messages -> (Seq Announcement, Messages))
-> GameState -> (Seq Announcement, GameState)
Lens' GameState Messages
messageInfo ((Messages -> (Seq Announcement, Messages))
 -> GameState -> (Seq Announcement, GameState))
-> ((Seq Announcement -> (Seq Announcement, Seq Announcement))
    -> Messages -> (Seq Announcement, Messages))
-> (Seq Announcement -> (Seq Announcement, Seq Announcement))
-> GameState
-> (Seq Announcement, GameState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Seq Announcement -> (Seq Announcement, Seq Announcement))
-> Messages -> (Seq Announcement, Messages)
Lens' Messages (Seq Announcement)
announcementQueue ((Seq Announcement -> (Seq Announcement, Seq Announcement))
 -> GameState -> (Seq Announcement, GameState))
-> (Seq Announcement -> Seq Announcement) -> m (Seq Announcement)
forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (State s) sig m =>
LensLike' ((,) a) s a -> (a -> a) -> m a
Swarm.Util.<%= (Seq Announcement -> Seq Announcement -> Seq Announcement
forall a. Seq a -> Seq a -> Seq a
>< [Announcement] -> Seq Announcement
forall a. [a] -> Seq a
Seq.fromList ((Objective -> Announcement) -> [Objective] -> [Announcement]
forall a b. (a -> b) -> [a] -> [b]
map Objective -> Announcement
ObjectiveCompleted ([Objective] -> [Announcement]) -> [Objective] -> [Announcement]
forall a b. (a -> b) -> a -> b
$ CompletionsWithExceptions -> [Objective]
completionAnnouncementQueue CompletionsWithExceptions
finalAccumulator))
  PauseOnObjective
shouldPause <- Getting PauseOnObjective GameState PauseOnObjective
-> m PauseOnObjective
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use (Getting PauseOnObjective GameState PauseOnObjective
 -> m PauseOnObjective)
-> Getting PauseOnObjective GameState PauseOnObjective
-> m PauseOnObjective
forall a b. (a -> b) -> a -> b
$ (TemporalState -> Const PauseOnObjective TemporalState)
-> GameState -> Const PauseOnObjective GameState
Lens' GameState TemporalState
temporal ((TemporalState -> Const PauseOnObjective TemporalState)
 -> GameState -> Const PauseOnObjective GameState)
-> ((PauseOnObjective -> Const PauseOnObjective PauseOnObjective)
    -> TemporalState -> Const PauseOnObjective TemporalState)
-> Getting PauseOnObjective GameState PauseOnObjective
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PauseOnObjective -> Const PauseOnObjective PauseOnObjective)
-> TemporalState -> Const PauseOnObjective TemporalState
Lens' TemporalState PauseOnObjective
pauseOnObjective

  let gameFinished :: Bool
gameFinished = WinStatus
newWinState WinStatus -> WinStatus -> Bool
forall a. Eq a => a -> a -> Bool
/= WinStatus
Ongoing
  let finishedObjectives :: Bool
finishedObjectives = Seq Announcement -> Bool
forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull Seq Announcement
queue
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
finishedObjectives Bool -> Bool -> Bool
&& (Bool
gameFinished Bool -> Bool -> Bool
|| PauseOnObjective
shouldPause PauseOnObjective -> PauseOnObjective -> Bool
forall a. Eq a => a -> a -> Bool
== PauseOnObjective
PauseOnAnyObjective)) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    (TemporalState -> Identity TemporalState)
-> GameState -> Identity GameState
Lens' GameState TemporalState
temporal ((TemporalState -> Identity TemporalState)
 -> GameState -> Identity GameState)
-> ((RunStatus -> Identity RunStatus)
    -> TemporalState -> Identity TemporalState)
-> (RunStatus -> Identity RunStatus)
-> GameState
-> Identity GameState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RunStatus -> Identity RunStatus)
-> TemporalState -> Identity TemporalState
Lens' TemporalState RunStatus
runStatus ((RunStatus -> Identity RunStatus)
 -> GameState -> Identity GameState)
-> RunStatus -> m ()
forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= RunStatus
AutoPause

  (Text -> m ()) -> [Text] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Text -> m ()
forall {sig :: (* -> *) -> * -> *} {m :: * -> *}.
(Member (State GameState) sig, Algebra sig m) =>
Text -> m ()
handleException ([Text] -> m ()) -> [Text] -> m ()
forall a b. (a -> b) -> a -> b
$ CompletionsWithExceptions -> [Text]
exceptions CompletionsWithExceptions
finalAccumulator
 where
  getNextWinState :: TickNumber -> ObjectiveCompletion -> WinStatus
getNextWinState TickNumber
ts ObjectiveCompletion
completedObjs
    | ObjectiveCompletion -> Bool
WC.didWin ObjectiveCompletion
completedObjs = Bool -> TickNumber -> WinStatus
Won Bool
False TickNumber
ts
    | 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 (ThrowC Exn m Value -> m (Either Exn Value))
-> (StateC GameState (ThrowC Exn m) Value -> ThrowC Exn m Value)
-> StateC GameState (ThrowC Exn m) Value
-> m (Either Exn Value)
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 (StateC GameState (ThrowC Exn m) Value -> m (Either Exn Value))
-> StateC GameState (ThrowC Exn m) Value -> m (Either Exn Value)
forall a b. (a -> b) -> a -> b
$ TSyntax -> StateC GameState (ThrowC Exn m) Value
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has Time sig m, Has (Throw Exn) sig m,
 Has (State GameState) sig m, Has (Lift IO) sig m) =>
TSyntax -> m Value
evalT (TSyntax -> StateC GameState (ThrowC Exn m) Value)
-> TSyntax -> StateC GameState (ThrowC Exn m) Value
forall a b. (a -> b) -> a -> b
$ Objective
obj Objective -> Getting TSyntax Objective TSyntax -> TSyntax
forall s a. s -> Getting a s a -> a
^. Getting TSyntax Objective TSyntax
Lens' Objective TSyntax
OB.objectiveCondition
        else Either Exn Value -> m (Either Exn Value)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Exn Value -> m (Either Exn Value))
-> Either Exn Value -> m (Either Exn Value)
forall a b. (a -> b) -> a -> b
$ Value -> Either Exn Value
forall a b. b -> Either a b
Right (Value -> Either Exn Value) -> Value -> Either Exn Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
VBool Bool
False
    CompletionsWithExceptions -> m CompletionsWithExceptions
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CompletionsWithExceptions -> m CompletionsWithExceptions)
-> CompletionsWithExceptions -> m CompletionsWithExceptions
forall a b. (a -> b) -> a -> b
$ case Either Exn Value -> Either Text Bool
simplifyResult Either Exn Value
v of
      Left Text
exnText ->
        [Text]
-> ObjectiveCompletion -> [Objective] -> CompletionsWithExceptions
CompletionsWithExceptions
          (Text
exnText Text -> [Text] -> [Text]
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 Objective -> [Objective] -> [Objective]
forall a. a -> [a] -> [a]
:))
          | ObjectiveCompletion -> Objective -> Bool
WC.isUnwinnable ObjectiveCompletion
currentCompletions Objective
obj = (Objective -> ObjectiveCompletion -> ObjectiveCompletion
OB.addUnwinnable, [Objective] -> [Objective]
forall a. a -> a
id)
          | Bool
otherwise = (Objective -> ObjectiveCompletion -> ObjectiveCompletion
OB.addIncomplete, [Objective] -> [Objective]
forall a. a -> a
id)

  simplifyResult :: Either Exn Value -> Either Text Bool
simplifyResult = \case
    Left Exn
exn -> Text -> Either Text Bool
forall a b. a -> Either a b
Left (Text -> Either Text Bool) -> Text -> Either Text Bool
forall a b. (a -> b) -> a -> b
$ EntityMap -> Exn -> Text
formatExn EntityMap
em Exn
exn
    Right (VBool Bool
x) -> Bool -> Either Text Bool
forall a b. b -> Either a b
Right Bool
x
    Right Value
val ->
      Text -> Either Text Bool
forall a b. a -> Either a b
Left (Text -> Either Text Bool) -> Text -> Either Text Bool
forall a b. (a -> b) -> a -> b
$
        [Text] -> Text
T.unwords
          [ Text
"Non boolean value:"
          , Value -> Text
prettyValue 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 (StateC Robot m LogEntry -> m LogEntry)
-> StateC Robot m LogEntry -> m LogEntry
forall a b. (a -> b) -> a -> b
$ RobotLogSource -> Severity -> Text -> StateC Robot m LogEntry
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
    LogEntry -> m ()
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

evalT ::
  ( Has Effect.Time sig m
  , Has (Throw Exn) sig m
  , Has (State GameState) sig m
  , Has (Lift IO) sig m
  ) =>
  TSyntax ->
  m Value
evalT :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has Time sig m, Has (Throw Exn) sig m,
 Has (State GameState) sig m, Has (Lift IO) sig m) =>
TSyntax -> m Value
evalT = CESK -> m Value
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has Time sig m, Has (Throw Exn) sig m,
 Has (State GameState) sig m, Has (Lift IO) sig m) =>
CESK -> m Value
evaluateCESK (CESK -> m Value) -> (TSyntax -> CESK) -> TSyntax -> m Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TSyntax -> CESK
initMachine

-- | 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
m =
  Maybe CESK -> RID -> TRobot -> Robot
instantiateRobot (CESK -> Maybe CESK
forall a. a -> Maybe a
Just CESK
m) (-RID
1)
    (TRobot -> Robot) -> (TimeSpec -> TRobot) -> TimeSpec -> Robot
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe RID
-> Text
-> Document Syntax
-> Maybe (Cosmic Location)
-> Heading
-> Display
-> Maybe TSyntax
-> [Entity]
-> [(RID, Entity)]
-> Bool
-> Bool
-> WalkabilityExceptions Text
-> TimeSpec
-> TRobot
mkRobot
      Maybe RID
forall a. Maybe a
Nothing
      Text
"hypothesis"
      Document Syntax
forall a. Monoid a => a
mempty
      Maybe (Cosmic Location)
forall a. Maybe a
Nothing
      Heading
forall a. Num a => V2 a
forall (f :: * -> *) a. (Additive f, Num a) => f a
zero
      Display
defaultRobotDisplay
      Maybe TSyntax
forall a. Maybe a
Nothing
      []
      []
      Bool
True
      Bool
False
      WalkabilityExceptions Text
forall a. Monoid a => Inclusions a
emptyExceptions

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

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

-- | 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 = m LogEntry -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m LogEntry -> m ()) -> (a -> m LogEntry) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RobotLogSource -> Severity -> Text -> m 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 -> m LogEntry) -> (a -> Text) -> a -> m LogEntry
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall source target. From source target => source -> target
from (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show

------------------------------------------------------------
-- 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 :: HasGameStepState sig m => Robot -> m Robot
tickRobot :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasGameStepState sig m =>
Robot -> m Robot
tickRobot Robot
r = do
  RID
steps <- Getting RID GameState RID -> m RID
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use (Getting RID GameState RID -> m RID)
-> Getting RID GameState RID -> m RID
forall a b. (a -> b) -> a -> b
$ (TemporalState -> Const RID TemporalState)
-> GameState -> Const RID GameState
Lens' GameState TemporalState
temporal ((TemporalState -> Const RID TemporalState)
 -> GameState -> Const RID GameState)
-> ((RID -> Const RID RID)
    -> TemporalState -> Const RID TemporalState)
-> Getting RID GameState RID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RID -> Const RID RID) -> TemporalState -> Const RID TemporalState
Lens' TemporalState RID
robotStepsPerTick
  Robot -> m Robot
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasGameStepState sig m =>
Robot -> m Robot
tickRobotRec (Robot
r Robot -> (Robot -> Robot) -> Robot
forall a b. a -> (a -> b) -> b
& (ActivityCounts -> Identity ActivityCounts)
-> Robot -> Identity Robot
Lens' Robot ActivityCounts
activityCounts ((ActivityCounts -> Identity ActivityCounts)
 -> Robot -> Identity Robot)
-> ((RID -> Identity RID)
    -> ActivityCounts -> Identity ActivityCounts)
-> (RID -> Identity RID)
-> Robot
-> Identity Robot
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RID -> Identity RID) -> ActivityCounts -> Identity ActivityCounts
Lens' ActivityCounts RID
tickStepBudget ((RID -> Identity RID) -> Robot -> Identity Robot)
-> RID -> Robot -> Robot
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 :: HasGameStepState sig m => Robot -> m Robot
tickRobotRec :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasGameStepState sig m =>
Robot -> m Robot
tickRobotRec Robot
r = do
  TickNumber
time <- Getting TickNumber GameState TickNumber -> m TickNumber
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use (Getting TickNumber GameState TickNumber -> m TickNumber)
-> Getting TickNumber GameState TickNumber -> m TickNumber
forall a b. (a -> b) -> a -> b
$ (TemporalState -> Const TickNumber TemporalState)
-> GameState -> Const TickNumber GameState
Lens' GameState TemporalState
temporal ((TemporalState -> Const TickNumber TemporalState)
 -> GameState -> Const TickNumber GameState)
-> ((TickNumber -> Const TickNumber TickNumber)
    -> TemporalState -> Const TickNumber TemporalState)
-> Getting TickNumber GameState TickNumber
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TickNumber -> Const TickNumber TickNumber)
-> TemporalState -> Const TickNumber TemporalState
Lens' TemporalState TickNumber
ticks
  case TickNumber -> Robot -> Bool
wantsToStep TickNumber
time Robot
r Bool -> Bool -> Bool
&& (Robot
r Robot -> Getting Bool Robot Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool Robot Bool
Lens' Robot Bool
runningAtomic Bool -> Bool -> Bool
|| Robot
r Robot -> Getting RID Robot RID -> RID
forall s a. s -> Getting a s a -> a
^. (ActivityCounts -> Const RID ActivityCounts)
-> Robot -> Const RID Robot
Lens' Robot ActivityCounts
activityCounts ((ActivityCounts -> Const RID ActivityCounts)
 -> Robot -> Const RID Robot)
-> ((RID -> Const RID RID)
    -> ActivityCounts -> Const RID ActivityCounts)
-> Getting RID Robot RID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RID -> Const RID RID)
-> ActivityCounts -> Const RID ActivityCounts
Lens' ActivityCounts RID
tickStepBudget RID -> RID -> Bool
forall a. Ord a => a -> a -> Bool
> RID
0) of
    Bool
True -> Robot -> m Robot
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasGameStepState sig m =>
Robot -> m Robot
stepRobot Robot
r m Robot -> (Robot -> m Robot) -> m Robot
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Robot -> m Robot
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasGameStepState sig m =>
Robot -> m Robot
tickRobotRec
    Bool
False -> Robot -> m Robot
forall a. a -> m a
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 :: HasGameStepState sig m => Robot -> m Robot
stepRobot :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasGameStepState sig m =>
Robot -> m Robot
stepRobot Robot
r = do
  (Robot
r', CESK
cesk') <- Robot -> StateC Robot m CESK -> m (Robot, CESK)
forall s (m :: * -> *) a. s -> StateC s m a -> m (s, a)
runState (Robot
r Robot -> (Robot -> Robot) -> Robot
forall a b. a -> (a -> b) -> b
& (ActivityCounts -> Identity ActivityCounts)
-> Robot -> Identity Robot
Lens' Robot ActivityCounts
activityCounts ((ActivityCounts -> Identity ActivityCounts)
 -> Robot -> Identity Robot)
-> ((RID -> Identity RID)
    -> ActivityCounts -> Identity ActivityCounts)
-> (RID -> Identity RID)
-> Robot
-> Identity Robot
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RID -> Identity RID) -> ActivityCounts -> Identity ActivityCounts
Lens' ActivityCounts RID
tickStepBudget ((RID -> Identity RID) -> Robot -> Identity Robot)
-> RID -> Robot -> Robot
forall a s t. Num a => ASetter s t a a -> a -> s -> t
-~ RID
1) (CESK -> StateC Robot m CESK
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m,
 Has (Lift IO) sig m, Has Time sig m) =>
CESK -> m CESK
stepCESK (Robot
r Robot -> Getting CESK Robot CESK -> CESK
forall s a. s -> Getting a s a -> a
^. Getting CESK Robot CESK
Lens' Robot CESK
machine))
  TickNumber
t <- Getting TickNumber GameState TickNumber -> m TickNumber
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use (Getting TickNumber GameState TickNumber -> m TickNumber)
-> Getting TickNumber GameState TickNumber -> m TickNumber
forall a b. (a -> b) -> a -> b
$ (TemporalState -> Const TickNumber TemporalState)
-> GameState -> Const TickNumber GameState
Lens' GameState TemporalState
temporal ((TemporalState -> Const TickNumber TemporalState)
 -> GameState -> Const TickNumber GameState)
-> ((TickNumber -> Const TickNumber TickNumber)
    -> TemporalState -> Const TickNumber TemporalState)
-> Getting TickNumber GameState TickNumber
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TickNumber -> Const TickNumber TickNumber)
-> TemporalState -> Const TickNumber TemporalState
Lens' TemporalState TickNumber
ticks

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

  Robot -> m Robot
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Robot -> m Robot) -> Robot -> m Robot
forall a b. (a -> b) -> a -> b
$
    Bool -> (Robot -> Robot) -> Robot -> Robot
forall a. Bool -> (a -> a) -> a -> a
applyWhen Bool
shouldTrackActivity (TickNumber -> Robot -> Robot
maintainActivityWindow TickNumber
t) (Robot -> Robot) -> Robot -> Robot
forall a b. (a -> b) -> a -> b
$
      Robot
r'
        Robot -> (Robot -> Robot) -> Robot
forall a b. a -> (a -> b) -> b
& (CESK -> Identity CESK) -> Robot -> Identity Robot
Lens' Robot CESK
machine ((CESK -> Identity CESK) -> Robot -> Identity Robot)
-> CESK -> Robot -> Robot
forall s t a b. ASetter s t a b -> b -> s -> t
.~ CESK
cesk'
        Robot -> (Robot -> Robot) -> Robot
forall a b. a -> (a -> b) -> b
& (ActivityCounts -> Identity ActivityCounts)
-> Robot -> Identity Robot
Lens' Robot ActivityCounts
activityCounts ((ActivityCounts -> Identity ActivityCounts)
 -> Robot -> Identity Robot)
-> ((RID -> Identity RID)
    -> ActivityCounts -> Identity ActivityCounts)
-> (RID -> Identity RID)
-> Robot
-> Identity Robot
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RID -> Identity RID) -> ActivityCounts -> Identity ActivityCounts
Lens' ActivityCounts RID
lifetimeStepCount ((RID -> Identity RID) -> Robot -> Identity Robot)
-> RID -> Robot -> Robot
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 Robot -> (Robot -> Robot) -> Robot
forall a b. a -> (a -> b) -> b
& ((ActivityCounts -> Identity ActivityCounts)
-> Robot -> Identity Robot
Lens' Robot ActivityCounts
activityCounts ((ActivityCounts -> Identity ActivityCounts)
 -> Robot -> Identity Robot)
-> ((WindowedCounter TickNumber
     -> Identity (WindowedCounter TickNumber))
    -> ActivityCounts -> Identity ActivityCounts)
-> (WindowedCounter TickNumber
    -> Identity (WindowedCounter TickNumber))
-> Robot
-> Identity Robot
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WindowedCounter TickNumber
 -> Identity (WindowedCounter TickNumber))
-> ActivityCounts -> Identity ActivityCounts
Lens' ActivityCounts (WindowedCounter TickNumber)
activityWindow ((WindowedCounter TickNumber
  -> Identity (WindowedCounter TickNumber))
 -> Robot -> Identity Robot)
-> (WindowedCounter TickNumber -> WindowedCounter TickNumber)
-> Robot
-> Robot
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ TickNumber
-> WindowedCounter TickNumber -> WindowedCounter TickNumber
forall a.
(Ord a, Offsettable a) =>
a -> WindowedCounter a -> WindowedCounter a
WC.insert TickNumber
t)

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, Has Effect.Time 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, Has Time 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 <- ErrorC Exn m () -> m (Either Exn ())
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 -> CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ Exn -> Store -> Cont -> CESK
Up Exn
exn Store
s Cont
k
    Right () -> CESK -> m CESK
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m,
 Has (Lift IO) sig m, Has Time sig m) =>
CESK -> m CESK
stepCESK (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
v Store
s Cont
k

-- | 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, Has Effect.Time sig m) => CESK -> m CESK
stepCESK :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m,
 Has (Lift IO) sig m, Has Time 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 <- Getting TickNumber GameState TickNumber -> m TickNumber
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use (Getting TickNumber GameState TickNumber -> m TickNumber)
-> Getting TickNumber GameState TickNumber -> m TickNumber
forall a b. (a -> b) -> a -> b
$ (TemporalState -> Const TickNumber TemporalState)
-> GameState -> Const TickNumber GameState
Lens' GameState TemporalState
temporal ((TemporalState -> Const TickNumber TemporalState)
 -> GameState -> Const TickNumber GameState)
-> ((TickNumber -> Const TickNumber TickNumber)
    -> TemporalState -> Const TickNumber TemporalState)
-> Getting TickNumber GameState TickNumber
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TickNumber -> Const TickNumber TickNumber)
-> TemporalState -> Const TickNumber TemporalState
Lens' TemporalState TickNumber
ticks
    if TickNumber
wakeupTime TickNumber -> TickNumber -> Bool
forall a. Ord a => a -> a -> Bool
<= TickNumber
time
      then CESK -> m CESK
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m,
 Has (Lift IO) sig m, Has Time sig m) =>
CESK -> m CESK
stepCESK CESK
cesk'
      else CESK -> m CESK
forall a. a -> m a
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) ->
    Value -> SKpair -> ErrorC Exn m () -> m CESK
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m,
 Has (Lift IO) sig m, Has Time sig m) =>
Value -> SKpair -> ErrorC Exn m () -> m CESK
processImmediateFrame Value
v (Store -> Cont -> SKpair
SKpair Store
s Cont
k) (ErrorC Exn m () -> m CESK) -> ErrorC Exn m () -> m CESK
forall a b. (a -> b) -> a -> b
$
      Const -> [WorldUpdate Entity] -> [RobotUpdate] -> ErrorC Exn m ()
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 -> CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s Cont
k
  In (TDir Direction
d) Env
_ Store
s Cont
k -> CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Direction -> Value
VDir Direction
d) Store
s Cont
k
  In (TInt Integer
n) Env
_ Store
s Cont
k -> CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Integer -> Value
VInt Integer
n) Store
s Cont
k
  In (TText Text
str) Env
_ Store
s Cont
k -> CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Text -> Value
VText Text
str) Store
s Cont
k
  In (TBool Bool
b) Env
_ Store
s Cont
k -> CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Bool -> Value
VBool Bool
b) Store
s Cont
k
  In (TType Type
ty) Env
_ Store
s Cont
k -> CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Type -> Value
VType Type
ty) Store
s Cont
k
  -- There should not be any antiquoted variables left at this point.
  In (TAntiText Text
v) Env
_ Store
s Cont
k ->
    CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ Exn -> Store -> Cont -> CESK
Up (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 ->
    CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ Exn -> Store -> Cont -> CESK
Up (Text -> Exn
Fatal (Text -> Text -> Text
T.append Text
"Antiquoted variable found at runtime: $int:" Text
v)) Store
s Cont
k
  -- Require and Stock just turn into no-ops.
  In (TRequire {}) Env
e Store
s Cont
k -> CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ Term' () -> Env -> Store -> Cont -> CESK
In (Const -> Term' ()
forall ty. Const -> Term' ty
TConst Const
Noop) Env
e Store
s Cont
k
  In (TStock {}) Env
e Store
s Cont
k -> CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ Term' () -> Env -> Store -> Cont -> CESK
In (Const -> Term' ()
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 -> CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ 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 RawPolytype
_) Env
e Store
s Cont
k -> CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ 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 -> CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ 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 RID -> RID -> Bool
forall a. Eq a => a -> a -> Bool
== RID
0 Bool -> Bool -> Bool
&& Bool -> Bool
not (Const -> Bool
isCmd Const
c) -> Const -> [Value] -> Store -> Cont -> m CESK
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m,
 Has Time sig m, Has (Lift IO) sig m) =>
Const -> [Value] -> Store -> Cont -> m CESK
evalConst Const
c [] Store
s Cont
k
    | Bool
otherwise -> CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ 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 -> Store -> Cont -> ThrowC Exn m CESK -> m CESK
forall (m :: * -> *).
Monad m =>
Store -> Cont -> ThrowC Exn m CESK -> m CESK
withExceptions Store
s Cont
k (ThrowC Exn m CESK -> m CESK) -> ThrowC Exn m CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ do
    Value
v <-
      Text -> Env -> Maybe Value
lookupValue Text
x Env
e
        Maybe Value -> Exn -> ThrowC Exn m Value
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."])

    -- Now look up any indirections and make sure it's not a blackhole.
    case Store -> Value -> Either RID Value
resolveValue Store
s Value
v of
      Left RID
loc -> Exn -> ThrowC Exn m CESK
forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError (Exn -> ThrowC Exn m CESK) -> Exn -> ThrowC Exn m CESK
forall a b. (a -> b) -> a -> b
$ Text -> Exn
Fatal (Text -> Exn) -> Text -> Exn
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text
T.append Text
"Reference to unknown memory cell " (String -> Text
forall source target. From source target => source -> target
from (RID -> String
forall a. Show a => a -> String
show RID
loc))
      Right Value
VBlackhole -> Exn -> ThrowC Exn m CESK
forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError Exn
InfiniteLoop
      Right Value
v' -> CESK -> ThrowC Exn m CESK
forall a. a -> ThrowC Exn m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> ThrowC Exn m CESK) -> CESK -> ThrowC Exn m CESK
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 -> CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ Term' () -> Env -> Store -> Cont -> CESK
In Term' ()
t1 Env
e Store
s (Term' () -> Env -> Frame
FSnd Term' ()
t2 Env
e Frame -> Cont -> Cont
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) -> CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ Term' () -> Env -> Store -> Cont -> CESK
In Term' ()
t2 Env
e Store
s (Value -> Frame
FFst Value
v1 Frame -> Cont -> Cont
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) -> CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ 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 -> CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Text -> Term' () -> Env -> Value
VClo Text
x Term' ()
t Env
e) Store
s Cont
k
  -- Special case for evaluating an application of Instant or Atomic:
  -- set the runningAtomic flag and push a stack frame to unset it
  -- when done evaluating.  We do this here so that even /evaluating/
  -- the argument to instant/atomic will happen atomically (#2270).
  -- Execution will also happen atomically; that is handled in
  -- execConst.
  In (TApp (TConst Const
c) Term' ()
t2) Env
e Store
s Cont
k
    | Const
c Const -> [Const] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Const
Atomic, Const
Instant] -> do
        (Bool -> Identity Bool) -> Robot -> Identity Robot
Lens' Robot Bool
runningAtomic ((Bool -> Identity Bool) -> Robot -> Identity Robot)
-> Bool -> m ()
forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= Bool
True
        case Cont
k of
          -- In the (common) special case that we will immediately
          -- execute the atomic/instant command next, don't bother
          -- pushing an FFinishAtomic frame. That way, runningAtomic
          -- will remain set, and evaluation + execution together will
          -- all happen in a single tick.
          Frame
FExec : Cont
_ -> CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ Term' () -> Env -> Store -> Cont -> CESK
In Term' ()
t2 Env
e Store
s (Value -> Frame
FApp (Const -> [Value] -> Value
VCApp Const
c []) Frame -> Cont -> Cont
forall a. a -> [a] -> [a]
: Cont
k)
          -- Otherwise, in general, other evaluation may take place in
          -- between evaluating the argument to atomic/instant and
          -- executing it, so we must push an FFinishAtomic frame so
          -- that intermediate evaluation will not happen atomically.
          -- For example, consider something like `f (instant c)`,
          -- where `f : Cmd Unit -> Cmd Unit`.  After evaluating `c`
          -- atomically, `instant c` is then passed to `f`, which may
          -- do some (non-atomic) computation before executing its
          -- argument (if it is executed at all).
          Cont
_ -> CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ Term' () -> Env -> Store -> Cont -> CESK
In Term' ()
t2 Env
e Store
s (Value -> Frame
FApp (Const -> [Value] -> Value
VCApp Const
c []) Frame -> Cont -> Cont
forall a. a -> [a] -> [a]
: Frame
FFinishAtomic Frame -> Cont -> Cont
forall a. a -> [a] -> [a]
: 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 -> CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ Term' () -> Env -> Store -> Cont -> CESK
In Term' ()
t1 Env
e Store
s (Term' () -> Env -> Frame
FArg Term' ()
t2 Env
e Frame -> Cont -> Cont
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) -> CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ Term' () -> Env -> Store -> Cont -> CESK
In Term' ()
t2 Env
e Store
s (Value -> Frame
FApp Value
v1 Frame -> Cont -> Cont
forall a. a -> [a] -> [a]
: Cont
k)
  -- Or, if there is an FVArg frame, the argument is already
  -- evaluated, so send it directly to an FApp.
  Out Value
v1 Store
s (FVArg Value
v2 : Cont
k) -> CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
v2 Store
s (Value -> Frame
FApp Value
v1 Frame -> Cont -> Cont
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) -> CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ Term' () -> Env -> Store -> Cont -> CESK
In Term' ()
t (Text -> Value -> Env -> Env
addValueBinding 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 RID -> RID -> Bool
forall a. Eq a => a -> a -> Bool
== [Value] -> RID
forall a. [a] -> RID
forall (t :: * -> *) a. Foldable t => t a -> RID
length [Value]
args RID -> RID -> RID
forall a. Num a => a -> a -> a
+ RID
1 ->
        Const -> [Value] -> Store -> Cont -> m CESK
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m,
 Has Time sig m, Has (Lift IO) sig m) =>
Const -> [Value] -> Store -> Cont -> m CESK
evalConst Const
c ([Value] -> [Value]
forall a. [a] -> [a]
reverse (Value
v2 Value -> [Value] -> [Value]
forall a. a -> [a] -> [a]
: [Value]
args)) Store
s Cont
k
    | Bool
otherwise -> CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Const -> [Value] -> Value
VCApp Const
c (Value
v2 Value -> [Value] -> [Value]
forall a. a -> [a] -> [a]
: [Value]
args)) Store
s Cont
k
  Out Value
_ Store
s (FApp Value
_ : Cont
_) -> Store -> Text -> m CESK
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 -> CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ case Map Text (Maybe (Term' ())) -> [(Text, Maybe (Term' ()))]
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 Map Text Value
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 (Term' () -> Maybe (Term' ()) -> Term' ()
forall a. a -> Maybe a -> a
fromMaybe (Text -> Term' ()
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 Frame -> Cont -> Cont
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) -> CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Map Text Value -> Value
VRcd ([(Text, Value)] -> Map Text Value
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ((Text
x, Value
v) (Text, Value) -> [(Text, Value)] -> [(Text, Value)]
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) ->
    CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ Term' () -> Env -> Store -> Cont -> CESK
In (Term' () -> Maybe (Term' ()) -> Term' ()
forall a. a -> Maybe a -> a
fromMaybe (Text -> Term' ()
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) (Text, Value) -> [(Text, Value)] -> [(Text, Value)]
forall a. a -> [a] -> [a]
: [(Text, Value)]
done) Text
y [(Text, Maybe (Term' ()))]
rest Frame -> Cont -> Cont
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 -> CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ Term' () -> Env -> Store -> Cont -> CESK
In Term' ()
t Env
e Store
s (Text -> Frame
FProj Text
x Frame -> Cont -> Cont
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 Text -> Map Text Value -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
x Map Text Value
m of
      Maybe Value
Nothing -> Store -> Text -> m CESK
forall {m :: * -> *}. Monad m => Store -> Text -> m CESK
badMachineState Store
s (Text -> m CESK) -> Text -> m CESK
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 -> CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
xv Store
s Cont
k
    Value
_ -> Store -> Text -> m CESK
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 LetSyntax
_ Bool
False Text
x Maybe RawPolytype
_ Maybe Polytype
mty Maybe Requirements
mreq Term' ()
t1 Term' ()
t2) Env
e Store
s Cont
k ->
    CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ Term' () -> Env -> Store -> Cont -> CESK
In Term' ()
t1 Env
e Store
s (Text -> Maybe (Polytype, Requirements) -> Term' () -> Env -> Frame
FLet Text
x ((,) (Polytype -> Requirements -> (Polytype, Requirements))
-> Maybe Polytype
-> Maybe (Requirements -> (Polytype, Requirements))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Polytype
mty Maybe (Requirements -> (Polytype, Requirements))
-> Maybe Requirements -> Maybe (Polytype, Requirements)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Requirements
mreq) Term' ()
t2 Env
e Frame -> Cont -> Cont
forall a. a -> [a] -> [a]
: Cont
k)
  -- To evaluate a recursive let binding:
  In (TLet LetSyntax
_ Bool
True Text
x Maybe RawPolytype
_ Maybe Polytype
mty Maybe Requirements
mreq Term' ()
t1 Term' ()
t2) Env
e Store
s Cont
k -> do
    -- First, allocate a cell for it in the store with the initial
    -- value of Blackhole.
    let (RID
loc, Store
s') = Value -> Store -> (RID, Store)
allocate Value
VBlackhole Store
s
    -- Now evaluate the definition with the variable bound to an
    -- indirection to the new cell, and push an FUpdate stack frame to
    -- update the cell with the value once we're done evaluating it,
    -- followed by an FLet frame to evaluate the body of the let.
    CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ Term' () -> Env -> Store -> Cont -> CESK
In Term' ()
t1 (Text -> Value -> Env -> Env
addValueBinding Text
x (RID -> Value
VIndir RID
loc) Env
e) Store
s' (RID -> Frame
FUpdate RID
loc Frame -> Cont -> Cont
forall a. a -> [a] -> [a]
: Text -> Maybe (Polytype, Requirements) -> Term' () -> Env -> Frame
FLet Text
x ((,) (Polytype -> Requirements -> (Polytype, Requirements))
-> Maybe Polytype
-> Maybe (Requirements -> (Polytype, Requirements))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Polytype
mty Maybe (Requirements -> (Polytype, Requirements))
-> Maybe Requirements -> Maybe (Polytype, Requirements)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Requirements
mreq) Term' ()
t2 Env
e Frame -> Cont -> Cont
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 Maybe (Polytype, Requirements)
mtr Term' ()
t2 Env
e : Cont
k) -> do
    let e' :: Env
e' = case Maybe (Polytype, Requirements)
mtr of
          Maybe (Polytype, Requirements)
Nothing -> Text -> Value -> Env -> Env
addValueBinding Text
x Value
v1 Env
e
          Just (Polytype
ty, Requirements
req) -> Text -> Typed Value -> Env -> Env
addBinding Text
x (Value -> Polytype -> Requirements -> Typed Value
forall v. v -> Polytype -> Requirements -> Typed v
Typed Value
v1 Polytype
ty Requirements
req) Env
e
    CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ Term' () -> Env -> Store -> Cont -> CESK
In Term' ()
t2 Env
e' Store
s Cont
k
  -- To evaluate a tydef, insert it into the context and proceed to
  -- evaluate the body.
  In (TTydef TDVar
x Polytype
_ Maybe TydefInfo
tdInfo Term' ()
t1) Env
e Store
s Cont
k -> CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ Term' () -> Env -> Store -> Cont -> CESK
In Term' ()
t1 ((Env -> Env)
-> (TydefInfo -> Env -> Env) -> Maybe TydefInfo -> Env -> Env
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Env -> Env
forall a. a -> a
id (Text -> TydefInfo -> Env -> Env
addTydef (TDVar -> Text
tdVarName TDVar
x)) Maybe TydefInfo
tdInfo 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 Maybe Polytype
mty Maybe Requirements
mreq Term' ()
t1 Term' ()
t2) Env
e Store
s Cont
k -> CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Maybe Text
-> Maybe Polytype
-> Maybe Requirements
-> Term' ()
-> Term' ()
-> Env
-> Value
VBind Maybe Text
mx Maybe Polytype
mty Maybe Requirements
mreq 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 Term' ()
t) Env
e Store
s Cont
k -> CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Term' () -> Env -> Value
VDelay Term' ()
t Env
e) 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) -> CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
v (RID -> Value -> Store -> Store
setStore RID
loc Value
v Store
s) Cont
k
  -- If we see a primitive application of suspend, package it up as
  -- a value until it's time to execute.
  In (TSuspend Term' ()
t) Env
e Store
s Cont
k -> CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Term' () -> Env -> Value
VSuspend Term' ()
t Env
e) Store
s Cont
k
  -- Ignore explicit parens.
  In (TParens Term' ()
t) Env
e Store
s Cont
k -> CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ Term' () -> Env -> Store -> Cont -> CESK
In Term' ()
t Env
e 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
e) Store
s (Frame
FExec : Cont
k) -> do
    EntityMap
em <- Getting EntityMap GameState EntityMap -> m EntityMap
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use (Getting EntityMap GameState EntityMap -> m EntityMap)
-> Getting EntityMap GameState EntityMap -> m EntityMap
forall a b. (a -> b) -> a -> b
$ (Landscape -> Const EntityMap Landscape)
-> GameState -> Const EntityMap GameState
Lens' GameState Landscape
landscape ((Landscape -> Const EntityMap Landscape)
 -> GameState -> Const EntityMap GameState)
-> ((EntityMap -> Const EntityMap EntityMap)
    -> Landscape -> Const EntityMap Landscape)
-> Getting EntityMap GameState EntityMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TerrainEntityMaps -> Const EntityMap TerrainEntityMaps)
-> Landscape -> Const EntityMap Landscape
Lens' Landscape TerrainEntityMaps
terrainAndEntities ((TerrainEntityMaps -> Const EntityMap TerrainEntityMaps)
 -> Landscape -> Const EntityMap Landscape)
-> ((EntityMap -> Const EntityMap EntityMap)
    -> TerrainEntityMaps -> Const EntityMap TerrainEntityMaps)
-> (EntityMap -> Const EntityMap EntityMap)
-> Landscape
-> Const EntityMap Landscape
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EntityMap -> Const EntityMap EntityMap)
-> TerrainEntityMaps -> Const EntityMap TerrainEntityMaps
Lens' TerrainEntityMaps EntityMap
entityMap
    let reqCtx :: ReqCtx
reqCtx = Env
e Env -> Getting ReqCtx Env ReqCtx -> ReqCtx
forall s a. s -> Getting a s a -> a
^. Getting ReqCtx Env ReqCtx
Lens' Env ReqCtx
envReqs
        tdCtx :: TDCtx
tdCtx = Env
e Env -> Getting TDCtx Env TDCtx -> TDCtx
forall s a. s -> Getting a s a -> a
^. Getting TDCtx Env TDCtx
Lens' Env TDCtx
envTydefs

        R.Requirements Set Capability
caps Set Text
devs Map Text RID
inv = TDCtx -> ReqCtx -> Term' () -> Requirements
R.requirements TDCtx
tdCtx ReqCtx
reqCtx Term' ()
t

        devicesForCaps, requiredDevices :: Set (Set Text)
        -- possible devices to provide each required capability
        devicesForCaps :: Set (Set Text)
devicesForCaps = (Capability -> Set Text) -> Set Capability -> Set (Set Text)
forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map ([Text] -> Set Text
forall a. Ord a => [a] -> Set a
S.fromList ([Text] -> Set Text)
-> (Capability -> [Text]) -> Capability -> Set Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Entity -> Text) -> [Entity] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Entity -> Getting Text Entity Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text Entity Text
Lens' Entity Text
entityName) ([Entity] -> [Text])
-> (Capability -> [Entity]) -> Capability -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Capability -> EntityMap -> [Entity]
`devicesForCap` EntityMap
em)) Set Capability
caps
        -- outright required devices
        requiredDevices :: Set (Set Text)
requiredDevices = (Text -> Set Text) -> Set Text -> Set (Set Text)
forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map Text -> Set Text
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.
          Set (Set Text) -> Set (Set Text)
forall a. Ord a => Set (Set a) -> Set (Set a)
removeSupersets (Set (Set Text) -> Set (Set Text))
-> Set (Set Text) -> Set (Set Text)
forall a b. (a -> b) -> a -> b
$ Set (Set Text)
devicesForCaps Set (Set Text) -> Set (Set Text) -> Set (Set Text)
forall a. Ord a => Set a -> Set a -> Set a
`S.union` Set (Set Text)
requiredDevices

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

    LogEntry
_ <- RobotLogSource -> Severity -> Text -> m 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
    CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
VUnit 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
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Const -> Bool
isTangible Const
c) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ (ActivityCounts -> Identity ActivityCounts)
-> Robot -> Identity Robot
Lens' Robot ActivityCounts
activityCounts ((ActivityCounts -> Identity ActivityCounts)
 -> Robot -> Identity Robot)
-> ((RID -> Identity RID)
    -> ActivityCounts -> Identity ActivityCounts)
-> (RID -> Identity RID)
-> Robot
-> Identity Robot
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RID -> Identity RID) -> ActivityCounts -> Identity ActivityCounts
Lens' ActivityCounts RID
tickStepBudget ((RID -> Identity RID) -> Robot -> Identity Robot) -> RID -> m ()
forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= RID
0
    Const -> [Value] -> Store -> Cont -> m CESK
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m,
 Has Time sig m, Has (Lift IO) sig m) =>
Const -> [Value] -> Store -> Cont -> m CESK
evalConst Const
c ([Value] -> [Value]
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
    (Bool -> Identity Bool) -> Robot -> Identity Robot
Lens' Robot Bool
runningAtomic ((Bool -> Identity Bool) -> Robot -> Identity Robot)
-> Bool -> m ()
forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= Bool
False
    CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
v Store
s 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 Maybe Polytype
mty Maybe Requirements
mreq Term' ()
c1 Term' ()
c2 Env
e) Store
s (Frame
FExec : Cont
k) -> CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ Term' () -> Env -> Store -> Cont -> CESK
In Term' ()
c1 Env
e Store
s (Frame
FExec Frame -> Cont -> Cont
forall a. a -> [a] -> [a]
: Maybe Text
-> Maybe (Polytype, Requirements) -> Term' () -> Env -> Frame
FBind Maybe Text
mx ((,) (Polytype -> Requirements -> (Polytype, Requirements))
-> Maybe Polytype
-> Maybe (Requirements -> (Polytype, Requirements))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Polytype
mty Maybe (Requirements -> (Polytype, Requirements))
-> Maybe Requirements -> Maybe (Polytype, Requirements)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Requirements
mreq) Term' ()
c2 Env
e Frame -> Cont -> Cont
forall a. a -> [a] -> [a]
: Cont
k)
  Out Value
_ Store
s (FBind Maybe Text
Nothing Maybe (Polytype, Requirements)
_ Term' ()
t2 Env
e : Cont
k) -> CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ Term' () -> Env -> Store -> Cont -> CESK
In Term' ()
t2 Env
e Store
s (Frame
FExec Frame -> Cont -> Cont
forall a. a -> [a] -> [a]
: Cont
k)
  Out Value
v Store
s (FBind (Just Text
x) Maybe (Polytype, Requirements)
mtr Term' ()
t2 Env
e : Cont
k) -> do
    let e' :: Env
e' = case Maybe (Polytype, Requirements)
mtr of
          Maybe (Polytype, Requirements)
Nothing -> Text -> Value -> Env -> Env
addValueBinding Text
x Value
v Env
e
          Just (Polytype
ty, Requirements
reqs) -> Text -> Typed Value -> Env -> Env
addBinding Text
x (Value -> Polytype -> Requirements -> Typed Value
forall v. v -> Polytype -> Requirements -> Typed v
Typed Value
v Polytype
ty Requirements
reqs) Env
e
    CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ Term' () -> Env -> Store -> Cont -> CESK
In Term' ()
t2 Env
e' Store
s (Frame
FExec Frame -> Cont -> Cont
forall a. a -> [a] -> [a]
: Cont
k)
  -- To execute a suspend instruction, evaluate its argument and then
  -- suspend.
  Out (VSuspend Term' ()
t Env
e) Store
s (Frame
FExec : Cont
k) -> CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ Term' () -> Env -> Store -> Cont -> CESK
In Term' ()
t Env
e Store
s (Env -> Frame
FSuspend Env
e Frame -> Cont -> Cont
forall a. a -> [a] -> [a]
: Cont
k)
  -- Once we've finished, enter the Suspended state.
  Out Value
v Store
s (FSuspend Env
e : Cont
k) -> CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ Value -> Env -> Store -> Cont -> CESK
Suspended Value
v Env
e 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
_) -> Store -> Text -> m CESK
forall {m :: * -> *}. Monad m => Store -> Text -> m CESK
badMachineState Store
s Text
"FExec frame with non-executable value"
  ------------------------------------------------------------
  -- Suspension
  ------------------------------------------------------------

  -- If we're suspended and see the env restore frame, we can discard
  -- it: it was only there in case an exception was thrown.
  Suspended Value
v Env
e Store
s (FRestoreEnv Env
_ : Cont
k) -> CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ Value -> Env -> Store -> Cont -> CESK
Suspended Value
v Env
e Store
s Cont
k
  -- We can also sometimes get a redundant FExec; discard it.
  Suspended Value
v Env
e Store
s (Frame
FExec : Cont
k) -> CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ Value -> Env -> Store -> Cont -> CESK
Suspended Value
v Env
e Store
s Cont
k
  -- If we're suspended but we were on the LHS of a bind, switch to
  -- evaluating that, except with the environment from the suspension
  -- instead of the environment stored in the FBind frame, as if the
  -- RHS of the bind had been grafted in right where the suspend was,
  -- i.e. the binds were reassociated.  For example
  --
  -- (x; z <- y; suspend z); q; r
  --
  -- should be equivalent to
  --
  -- x; z <- y; q; r
  --
  Suspended Value
_ Env
e Store
s (FBind Maybe Text
Nothing Maybe (Polytype, Requirements)
_ Term' ()
t2 Env
_ : Cont
k) -> CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ Term' () -> Env -> Store -> Cont -> CESK
In Term' ()
t2 Env
e Store
s (Frame
FExec Frame -> Cont -> Cont
forall a. a -> [a] -> [a]
: Cont
k)
  Suspended Value
v Env
e Store
s (FBind (Just Text
x) Maybe (Polytype, Requirements)
mtr Term' ()
t2 Env
_ : Cont
k) -> do
    let e' :: Env
e' = case Maybe (Polytype, Requirements)
mtr of
          Maybe (Polytype, Requirements)
Nothing -> Text -> Value -> Env -> Env
addValueBinding Text
x Value
v Env
e
          Just (Polytype
ty, Requirements
reqs) -> Text -> Typed Value -> Env -> Env
addBinding Text
x (Value -> Polytype -> Requirements -> Typed Value
forall v. v -> Polytype -> Requirements -> Typed v
Typed Value
v Polytype
ty Requirements
reqs) Env
e
    CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ Term' () -> Env -> Store -> Cont -> CESK
In Term' ()
t2 Env
e' Store
s (Frame
FExec Frame -> Cont -> Cont
forall a. a -> [a] -> [a]
: Cont
k)
  -- Otherwise, if we're suspended with nothing else left to do,
  -- return the machine unchanged (but throw away the rest of the
  -- continuation stack).
  Suspended Value
v Env
e Store
s Cont
_ -> CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ Value -> Env -> Store -> Cont -> CESK
Suspended Value
v Env
e Store
s []
  ------------------------------------------------------------
  -- 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) -> CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
v Store
s Cont
k
  -- Also ignore restore frames when returning normally.
  Out Value
v Store
s (FRestoreEnv {} : Cont
k) -> CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
v Store
s Cont
k
  -- If raising an exception up the stack and we reach the top, handle
  -- it appropriately.
  Up Exn
exn Store
s [] -> Exn -> Store -> Maybe Env -> m CESK
forall {m :: * -> *} {sig :: (* -> *) -> * -> *}.
(Algebra sig m, Member (Lift IO) sig, Member (State Robot) sig,
 Member (State GameState) sig) =>
Exn -> Store -> Maybe Env -> m CESK
handleException Exn
exn Store
s Maybe Env
forall a. Maybe a
Nothing
  -- If we are raising an exception up the stack and we see an
  -- FRestoreEnv frame, log the exception, switch into a suspended state,
  -- and discard the rest of the stack.
  Up Exn
exn Store
s (FRestoreEnv Env
e : Cont
_) -> Exn -> Store -> Maybe Env -> m CESK
forall {m :: * -> *} {sig :: (* -> *) -> * -> *}.
(Algebra sig m, Member (Lift IO) sig, Member (State Robot) sig,
 Member (State GameState) sig) =>
Exn -> Store -> Maybe Env -> m CESK
handleException Exn
exn Store
s (Env -> Maybe Env
forall a. a -> Maybe a
Just Env
e)
  -- If an atomic block threw an exception, we should terminate it.
  Up Exn
exn Store
s (Frame
FFinishAtomic : Cont
k) -> do
    (Bool -> Identity Bool) -> Robot -> Identity Robot
Lens' Robot Bool
runningAtomic ((Bool -> Identity Bool) -> Robot -> Identity Robot)
-> Bool -> m ()
forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= Bool
False
    CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ Exn -> Store -> Cont -> CESK
Up Exn
exn Store
s Cont
k
  -- If we are raising a catchable exception up the continuation
  -- stack and come to a Try frame, force and then execute the associated catch
  -- block.
  Up Exn
exn Store
s (FTry Value
c : Cont
k)
    | Exn -> Bool
isCatchable Exn
exn -> CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
c Store
s (Value -> Frame
FApp (Const -> [Value] -> Value
VCApp Const
Force []) Frame -> Cont -> Cont
forall a. a -> [a] -> [a]
: Frame
FExec Frame -> Cont -> Cont
forall a. a -> [a] -> [a]
: Cont
k)
  -- Otherwise, keep popping from the continuation stack.
  Up Exn
exn Store
s (Frame
_ : Cont
k) -> CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ Exn -> Store -> Cont -> CESK
Up Exn
exn Store
s Cont
k
  -- Finally, if we're done evaluating and the continuation stack is
  -- empty, return the machine unchanged.
  done :: CESK
done@(Out Value
_ Store
_ []) -> CESK -> m CESK
forall a. a -> m a
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
            , CESK -> Text
forall a. PrettyPrec a => a -> Text
prettyText CESK
cesk
            ]
     in CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ Exn -> Store -> Cont -> CESK
Up (Text -> Exn
Fatal Text
msg') Store
s []

  isCatchable :: Exn -> Bool
isCatchable = \case
    Fatal {} -> Bool
False
    Incapable {} -> Bool
False
    InfiniteLoop {} -> Bool
False
    Exn
_ -> Bool
True

  handleException :: Exn -> Store -> Maybe Env -> m CESK
handleException Exn
exn Store
s Maybe Env
menv = do
    case Exn
exn of
      CmdFailed Const
_ Text
_ (Just GameplayAchievement
a) -> do
        GameplayAchievement -> m ()
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (Lift IO) sig m) =>
GameplayAchievement -> m ()
grantAchievement GameplayAchievement
a
      Exn
_ -> () -> m ()
forall a. a -> m a
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.
    Bool
h <- Capability -> m Bool
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State Robot) sig m, Has (State GameState) sig m) =>
Capability -> m Bool
hasCapability (Capability -> m Bool) -> Capability -> m Bool
forall a b. (a -> b) -> a -> b
$ Const -> Capability
CExecute Const
Log
    EntityMap
em <- Getting EntityMap GameState EntityMap -> m EntityMap
forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use (Getting EntityMap GameState EntityMap -> m EntityMap)
-> Getting EntityMap GameState EntityMap -> m EntityMap
forall a b. (a -> b) -> a -> b
$ (Landscape -> Const EntityMap Landscape)
-> GameState -> Const EntityMap GameState
Lens' GameState Landscape
landscape ((Landscape -> Const EntityMap Landscape)
 -> GameState -> Const EntityMap GameState)
-> ((EntityMap -> Const EntityMap EntityMap)
    -> Landscape -> Const EntityMap Landscape)
-> Getting EntityMap GameState EntityMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TerrainEntityMaps -> Const EntityMap TerrainEntityMaps)
-> Landscape -> Const EntityMap Landscape
Lens' Landscape TerrainEntityMaps
terrainAndEntities ((TerrainEntityMaps -> Const EntityMap TerrainEntityMaps)
 -> Landscape -> Const EntityMap Landscape)
-> ((EntityMap -> Const EntityMap EntityMap)
    -> TerrainEntityMaps -> Const EntityMap TerrainEntityMaps)
-> (EntityMap -> Const EntityMap EntityMap)
-> Landscape
-> Const EntityMap Landscape
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EntityMap -> Const EntityMap EntityMap)
-> TerrainEntityMaps -> Const EntityMap TerrainEntityMaps
Lens' TerrainEntityMaps EntityMap
entityMap
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
h (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ m LogEntry -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m LogEntry -> m ()) -> m LogEntry -> m ()
forall a b. (a -> b) -> a -> b
$ RobotLogSource -> Severity -> Text -> m LogEntry
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m) =>
RobotLogSource -> Severity -> Text -> m LogEntry
traceLog RobotLogSource
RobotError (Exn -> Severity
exnSeverity Exn
exn) (EntityMap -> Exn -> Text
formatExn EntityMap
em Exn
exn)
    CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ case Maybe Env
menv of
      Maybe Env
Nothing -> Value -> Store -> Cont -> CESK
Out Value
VExc Store
s []
      Just Env
env -> Value -> Env -> Store -> Cont -> CESK
Suspended Value
VExc Env
env Store
s []

-- | 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.
runChildProg ::
  (HasRobotStepState sig m, Has Effect.Time sig m, Has (Lift IO) sig m) =>
  Store ->
  Robot ->
  Value ->
  m Value
runChildProg :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(HasRobotStepState sig m, Has Time sig m, Has (Lift IO) sig m) =>
Store -> Robot -> Value -> m Value
runChildProg Store
s Robot
r Value
prog = do
  GameState
g <- forall s (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
m s
get @GameState
  forall s (m :: * -> *) a. Functor m => s -> StateC s m a -> m a
evalState @Robot (Robot
r Robot -> (Robot -> Robot) -> Robot
forall a b. a -> (a -> b) -> b
& (Bool -> Identity Bool) -> Robot -> Identity Robot
Lens' Robot Bool
systemRobot ((Bool -> Identity Bool) -> Robot -> Identity Robot)
-> Bool -> Robot -> Robot
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
True) (StateC Robot m Value -> m Value)
-> (StateC GameState (StateC Robot m) Value
    -> StateC Robot m Value)
-> StateC GameState (StateC Robot m) Value
-> m Value
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 (StateC GameState (StateC Robot m) Value -> m Value)
-> StateC GameState (StateC Robot m) Value -> m Value
forall a b. (a -> b) -> a -> b
$
    CESK -> StateC GameState (StateC Robot m) Value
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has Time 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])

-- | Execute 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 Effect.Time 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 Time 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 <- ErrorC Exn m CESK -> m (Either Exn CESK)
forall exc (m :: * -> *) a. ErrorC exc m a -> m (Either exc a)
runError (ErrorC Exn m CESK -> m (Either Exn CESK))
-> ErrorC Exn m CESK -> m (Either Exn CESK)
forall a b. (a -> b) -> a -> b
$ (Store -> Robot -> Value -> ErrorC Exn m Value)
-> Const -> [Value] -> Store -> Cont -> ErrorC Exn m CESK
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(HasRobotStepState sig m, Has Time sig m, Has (Lift IO) sig m) =>
(Store -> Robot -> Value -> m Value)
-> Const -> [Value] -> Store -> Cont -> m CESK
execConst Store -> Robot -> Value -> ErrorC Exn m Value
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(HasRobotStepState sig m, Has Time sig m, Has (Lift IO) sig m) =>
Store -> Robot -> Value -> m Value
runChildProg Const
c [Value]
vs Store
s Cont
k
  case Either Exn CESK
res of
    Left Exn
exn -> CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CESK -> m CESK) -> CESK -> m CESK
forall a b. (a -> b) -> a -> b
$ Exn -> Store -> Cont -> CESK
Up Exn
exn Store
s Cont
k
    Right CESK
cek' -> CESK -> m CESK
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return CESK
cek'