{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
module Swarm.Game.Step where
import Control.Carrier.Error.Either (runError)
import Control.Carrier.State.Lazy
import Control.Carrier.Throw.Either (ThrowC, runThrow)
import Control.Effect.Error
import Control.Effect.Lens
import Control.Effect.Lift
import Control.Lens as Lens hiding (Const, from, parts, use, uses, view, (%=), (+=), (.=), (<+=), (<>=))
import Control.Monad (forM, forM_, guard, msum, unless, when)
import Data.Array (bounds, (!))
import Data.Bifunctor (second)
import Data.Bool (bool)
import Data.Containers.ListUtils (nubOrd)
import Data.Either (partitionEithers, rights)
import Data.Foldable (asum, traverse_)
import Data.Functor (void)
import Data.Int (Int64)
import Data.IntMap qualified as IM
import Data.IntSet qualified as IS
import Data.List (find)
import Data.List qualified as L
import Data.List.NonEmpty (NonEmpty ((:|)))
import Data.List.NonEmpty qualified as NE
import Data.Map qualified as M
import Data.Maybe (fromMaybe, isNothing, listToMaybe)
import Data.Sequence qualified as Seq
import Data.Set (Set)
import Data.Set qualified as S
import Data.Text (Text)
import Data.Text qualified as T
import Data.Tuple (swap)
import Linear (V2 (..), zero, (^+^))
import Swarm.Game.CESK
import Swarm.Game.Display
import Swarm.Game.Entity hiding (empty, lookup, singleton, union)
import Swarm.Game.Entity qualified as E
import Swarm.Game.Exception
import Swarm.Game.Recipe
import Swarm.Game.Robot
import Swarm.Game.Scenario (objectiveCondition)
import Swarm.Game.State
import Swarm.Game.Value
import Swarm.Game.World qualified as W
import Swarm.Language.Capability
import Swarm.Language.Context hiding (delete)
import Swarm.Language.Pipeline
import Swarm.Language.Pipeline.QQ (tmQ)
import Swarm.Language.Requirement qualified as R
import Swarm.Language.Syntax
import Swarm.Util
import System.Clock (TimeSpec)
import System.Clock qualified
import System.Random (UniformRange, uniformR)
import Witch (From (from), into)
import Prelude hiding (lookup)
gameTick :: (Has (State GameState) sig m, Has (Lift IO) sig m) => m ()
gameTick :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (Lift IO) sig m) =>
m ()
gameTick = do
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
m ()
wakeUpRobotsDoneSleeping
IntSet
robotNames <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter GameState IntSet
activeRobots
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (IntSet -> [RID]
IS.toList IntSet
robotNames) forall a b. (a -> b) -> a -> b
$ \RID
rn -> do
Maybe Robot
mr <- forall s a b (f :: * -> *) (sig :: (* -> *) -> * -> *).
Has (State s) sig f =>
Getting a s a -> (a -> b) -> f b
uses Lens' GameState (IntMap Robot)
robotMap (forall a. RID -> IntMap a -> Maybe a
IM.lookup RID
rn)
case Maybe Robot
mr of
Maybe Robot
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Robot
curRobot -> do
Robot
curRobot' <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (Lift IO) sig m) =>
Robot -> m Robot
tickRobot Robot
curRobot
if Robot
curRobot' forall s a. s -> Getting a s a -> a
^. Lens' Robot Bool
selfDestruct
then forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
RID -> m ()
deleteRobot RID
rn
else do
Lens' GameState (IntMap Robot)
robotMap forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= forall a. RID -> a -> IntMap a -> IntMap a
IM.insert RID
rn Robot
curRobot'
Integer
time <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' GameState Integer
ticks
case Robot -> Maybe Integer
waitingUntil Robot
curRobot' of
Just Integer
wakeUpTime
| Integer
wakeUpTime forall a. Num a => a -> a -> a
- Integer
2 forall a. Ord a => a -> a -> Bool
<= Integer
time -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
RID -> Integer -> m ()
sleepUntil RID
rn Integer
wakeUpTime
Maybe Integer
Nothing ->
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Robot -> Bool
isActive Robot
curRobot') (forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
RID -> m ()
sleepForever RID
rn)
Maybe Robot
mr <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use (Lens' GameState (IntMap Robot)
robotMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at RID
0)
case Maybe Robot
mr of
Just Robot
r -> do
REPLStatus
res <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' GameState REPLStatus
replStatus
case REPLStatus
res of
REPLWorking Polytype
ty Maybe Value
Nothing -> case Robot -> Maybe (Value, Store)
getResult Robot
r of
Just (Value
v, Store
s) -> do
Lens' GameState REPLStatus
replStatus 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 (forall a. a -> Maybe a
Just Value
v)
Lens' GameState (IntMap Robot)
robotMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix RID
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Robot RobotContext
robotContext forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' RobotContext Store
defStore forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= Store
s
Maybe (Value, Store)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
REPLStatus
_otherREPLStatus -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Maybe Robot
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
forall s (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
(s -> s) -> m ()
modify GameState -> GameState
recalcViewCenter
WinCondition
wc <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' GameState WinCondition
winCondition
case WinCondition
wc of
WinConditions (Objective
obj :| [Objective]
objs) -> do
GameState
g <- forall s (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
m s
get @GameState
Either Exn Value
v <- forall e (m :: * -> *) a. ThrowC e m a -> m (Either e a)
runThrow @Exn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. Functor m => s -> StateC s m a -> m a
evalState @GameState GameState
g forall a b. (a -> b) -> a -> b
$ forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Lift IO) sig m, Has (Throw Exn) sig m,
Has (State GameState) sig m) =>
ProcessedTerm -> m Value
evalPT (Objective
obj forall s a. s -> Getting a s a -> a
^. Lens' Objective ProcessedTerm
objectiveCondition)
case Either Exn Value
v of
Left Exn
exn -> do
EntityMap
em <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' GameState EntityMap
entityMap
Integer
time <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' GameState Integer
ticks
let h :: Robot
h = CESK -> TimeSpec -> Robot
hypotheticalRobot (Value -> Store -> Cont -> CESK
Out Value
VUnit Store
emptyStore []) TimeSpec
0
hid :: RID
hid = forall r a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Reader r) sig m =>
Getting a r a -> m a
view Getter Robot RID
robotID Robot
h
hn :: Text
hn = forall r a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Reader r) sig m =>
Getting a r a -> m a
view Lens' Robot Text
robotName Robot
h
farAway :: V2 Int64
farAway = forall a. a -> a -> V2 a
V2 forall a. Bounded a => a
maxBound forall a. Bounded a => a
maxBound
let m :: LogEntry
m = Integer -> LogSource -> Text -> RID -> V2 Int64 -> Text -> LogEntry
LogEntry Integer
time LogSource
ErrorTrace Text
hn RID
hid V2 Int64
farAway forall a b. (a -> b) -> a -> b
$ EntityMap -> Exn -> Text
formatExn EntityMap
em Exn
exn
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
LogEntry -> m ()
emitMessage LogEntry
m
Right (VBool Bool
True) -> Lens' GameState WinCondition
winCondition forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool -> WinCondition
Won Bool
False) NonEmpty Objective -> WinCondition
WinConditions (forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [Objective]
objs)
Either Exn Value
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
WinCondition
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Lens' GameState Integer
ticks forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State s) sig m, Num a) =>
ASetter' s a -> a -> m ()
+= Integer
1
evalPT ::
(Has (Lift IO) sig m, Has (Throw Exn) sig m, Has (State GameState) sig m) =>
ProcessedTerm ->
m Value
evalPT :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Lift IO) sig m, Has (Throw Exn) sig m,
Has (State GameState) sig m) =>
ProcessedTerm -> m Value
evalPT ProcessedTerm
t = forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Lift IO) sig m, Has (Throw Exn) sig m,
Has (State GameState) sig m) =>
CESK -> m Value
evaluateCESK (ProcessedTerm -> Env -> Store -> CESK
initMachine ProcessedTerm
t forall t. Ctx t
empty Store
emptyStore)
getNow :: Has (Lift IO) sig m => m TimeSpec
getNow :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Lift IO) sig m =>
m TimeSpec
getNow = forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Lift IO) sig m =>
IO a -> m a
sendIO forall a b. (a -> b) -> a -> b
$ Clock -> IO TimeSpec
System.Clock.getTime Clock
System.Clock.Monotonic
hypotheticalRobot :: CESK -> TimeSpec -> Robot
hypotheticalRobot :: CESK -> TimeSpec -> Robot
hypotheticalRobot CESK
c = forall (phase :: RobotPhase).
RobotID phase
-> Maybe RID
-> Text
-> [Text]
-> RobotLocation phase
-> V2 Int64
-> Display
-> CESK
-> [Entity]
-> [(RID, Entity)]
-> Bool
-> Bool
-> TimeSpec
-> RobotR phase
mkRobot (-RID
1) forall a. Maybe a
Nothing Text
"hypothesis" [] forall (f :: * -> *) a. (Additive f, Num a) => f a
zero forall (f :: * -> *) a. (Additive f, Num a) => f a
zero Display
defaultRobotDisplay CESK
c [] [] Bool
True Bool
False
evaluateCESK ::
(Has (Lift IO) sig m, Has (Throw Exn) sig m, Has (State GameState) sig m) =>
CESK ->
m Value
evaluateCESK :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Lift IO) sig m, Has (Throw Exn) sig m,
Has (State GameState) sig m) =>
CESK -> m Value
evaluateCESK CESK
cesk = do
TimeSpec
createdAt <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Lift IO) sig m =>
m TimeSpec
getNow
let r :: Robot
r = CESK -> TimeSpec -> Robot
hypotheticalRobot CESK
cesk TimeSpec
createdAt
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
Robot -> m ()
addRobot Robot
r
forall s (m :: * -> *) a. Functor m => s -> StateC s m a -> m a
evalState Robot
r forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Lift IO) sig m, Has (Throw Exn) sig m,
Has (State GameState) sig m, Has (State Robot) sig m) =>
CESK -> m Value
runCESK forall a b. (a -> b) -> a -> b
$ CESK
cesk
runCESK ::
( Has (Lift IO) sig m
, Has (Throw Exn) sig m
, Has (State GameState) sig m
, Has (State Robot) sig m
) =>
CESK ->
m Value
runCESK :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Lift IO) sig m, Has (Throw Exn) sig m,
Has (State GameState) sig m, Has (State Robot) sig m) =>
CESK -> m Value
runCESK (Up Exn
exn Store
_ []) = forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError Exn
exn
runCESK CESK
cesk = case CESK -> Maybe (Value, Store)
finalValue CESK
cesk of
Just (Value
v, Store
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return Value
v
Maybe (Value, Store)
Nothing -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m,
Has (Lift IO) sig m) =>
CESK -> m CESK
stepCESK CESK
cesk forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Lift IO) sig m, Has (Throw Exn) sig m,
Has (State GameState) sig m, Has (State Robot) sig m) =>
CESK -> m Value
runCESK
flagRedraw :: (Has (State GameState) sig m) => m ()
flagRedraw :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
m ()
flagRedraw = Lens' GameState Bool
needsRedraw forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= Bool
True
zoomWorld :: (Has (State GameState) sig m) => StateC (W.World Int Entity) Identity b -> m b
zoomWorld :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *) b.
Has (State GameState) sig m =>
StateC (World RID Entity) Identity b -> m b
zoomWorld StateC (World RID Entity) Identity b
n = do
World RID Entity
w <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' GameState (World RID Entity)
world
let (World RID Entity
w', b
a) = forall a. Identity a -> a
run (forall s (m :: * -> *) a. s -> StateC s m a -> m (s, a)
runState World RID Entity
w StateC (World RID Entity) Identity b
n)
Lens' GameState (World RID Entity)
world forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= World RID Entity
w'
forall (m :: * -> *) a. Monad m => a -> m a
return b
a
entityAt :: (Has (State GameState) sig m) => V2 Int64 -> m (Maybe Entity)
entityAt :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
V2 Int64 -> m (Maybe Entity)
entityAt V2 Int64
loc = forall (sig :: (* -> *) -> * -> *) (m :: * -> *) b.
Has (State GameState) sig m =>
StateC (World RID Entity) Identity b -> m b
zoomWorld (forall t e (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State (World t e)) sig m, IArray UArray t) =>
Coords -> m (Maybe e)
W.lookupEntityM @Int (V2 Int64 -> Coords
W.locToCoords V2 Int64
loc))
updateEntityAt ::
(Has (State GameState) sig m) => V2 Int64 -> (Maybe Entity -> Maybe Entity) -> m ()
updateEntityAt :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
V2 Int64 -> (Maybe Entity -> Maybe Entity) -> m ()
updateEntityAt V2 Int64
loc Maybe Entity -> Maybe Entity
upd = forall (sig :: (* -> *) -> * -> *) (m :: * -> *) b.
Has (State GameState) sig m =>
StateC (World RID Entity) Identity b -> m b
zoomWorld (forall t e (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State (World t e)) sig m, IArray UArray t) =>
Coords -> (Maybe e -> Maybe e) -> m ()
W.updateM @Int (V2 Int64 -> Coords
W.locToCoords V2 Int64
loc) Maybe Entity -> Maybe Entity
upd)
robotWithID :: (Has (State GameState) sig m) => RID -> m (Maybe Robot)
robotWithID :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
RID -> m (Maybe Robot)
robotWithID RID
rid = forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use (Lens' GameState (IntMap Robot)
robotMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at RID
rid)
robotWithName :: (Has (State GameState) sig m) => Text -> m (Maybe Robot)
robotWithName :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
Text -> m (Maybe Robot)
robotWithName Text
rname = forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use (Lens' GameState (IntMap Robot)
robotMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to forall a. IntMap a -> [a]
IM.elems forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find forall a b. (a -> b) -> a -> b
$ \Robot
r -> Robot
r forall s a. s -> Getting a s a -> a
^. Lens' Robot Text
robotName forall a. Eq a => a -> a -> Bool
== Text
rname))
uniform :: (Has (State GameState) sig m, UniformRange a) => (a, a) -> m a
uniform :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(Has (State GameState) sig m, UniformRange a) =>
(a, a) -> m a
uniform (a, a)
bnds = do
StdGen
rand <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' GameState StdGen
randGen
let (a
n, StdGen
g) = forall g a. (RandomGen g, UniformRange a) => (a, a) -> g -> (a, g)
uniformR (a, a)
bnds StdGen
rand
Lens' GameState StdGen
randGen forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= StdGen
g
forall (m :: * -> *) a. Monad m => a -> m a
return a
n
weightedChoice :: Has (State GameState) sig m => (a -> Integer) -> [a] -> m (Maybe a)
weightedChoice :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (State GameState) sig m =>
(a -> Integer) -> [a] -> m (Maybe a)
weightedChoice a -> Integer
weight [a]
as = do
Integer
r <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(Has (State GameState) sig m, UniformRange a) =>
(a, a) -> m a
uniform (Integer
0, Integer
total forall a. Num a => a -> a -> a
- Integer
1)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Integer -> [a] -> Maybe a
go Integer
r [a]
as
where
total :: Integer
total = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall a b. (a -> b) -> [a] -> [b]
map a -> Integer
weight [a]
as)
go :: Integer -> [a] -> Maybe a
go Integer
_ [] = forall a. Maybe a
Nothing
go !Integer
k (a
x : [a]
xs)
| Integer
k forall a. Ord a => a -> a -> Bool
< Integer
w = forall a. a -> Maybe a
Just a
x
| Bool
otherwise = Integer -> [a] -> Maybe a
go (Integer
k forall a. Num a => a -> a -> a
- Integer
w) [a]
xs
where
w :: Integer
w = a -> Integer
weight a
x
randomName :: Has (State GameState) sig m => m Text
randomName :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
m Text
randomName = do
Array RID Text
adjs <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use @GameState Getter GameState (Array RID Text)
adjList
Array RID Text
names <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use @GameState Getter GameState (Array RID Text)
nameList
RID
i <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(Has (State GameState) sig m, UniformRange a) =>
(a, a) -> m a
uniform (forall i e. Array i e -> (i, i)
bounds Array RID Text
adjs)
RID
j <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(Has (State GameState) sig m, UniformRange a) =>
(a, a) -> m a
uniform (forall i e. Array i e -> (i, i)
bounds Array RID Text
names)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [Array RID Text
adjs forall i e. Ix i => Array i e -> i -> e
! RID
i, Text
"_", Array RID Text
names forall i e. Ix i => Array i e -> i -> e
! RID
j]
createLogEntry :: (Has (State GameState) sig m, Has (State Robot) sig m) => LogSource -> Text -> m LogEntry
createLogEntry :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m) =>
LogSource -> Text -> m LogEntry
createLogEntry LogSource
source Text
msg = do
RID
rid <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot RID
robotID
Text
rn <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot Text
robotName
Integer
time <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' GameState Integer
ticks
V2 Int64
loc <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot (V2 Int64)
robotLocation
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Integer -> LogSource -> Text -> RID -> V2 Int64 -> Text -> LogEntry
LogEntry Integer
time LogSource
source Text
rn RID
rid V2 Int64
loc Text
msg
traceLog :: (Has (State GameState) sig m, Has (State Robot) sig m) => LogSource -> Text -> m LogEntry
traceLog :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m) =>
LogSource -> Text -> m LogEntry
traceLog LogSource
source Text
msg = do
LogEntry
m <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m) =>
LogSource -> Text -> m LogEntry
createLogEntry LogSource
source Text
msg
Lens' Robot (Seq LogEntry)
robotLog forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= (forall a. Seq a -> a -> Seq a
Seq.|> LogEntry
m)
forall (m :: * -> *) a. Monad m => a -> m a
return LogEntry
m
traceLogShow :: (Has (State GameState) sig m, Has (State Robot) sig m, Show a) => a -> m ()
traceLogShow :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(Has (State GameState) sig m, Has (State Robot) sig m, Show a) =>
a -> m ()
traceLogShow = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m) =>
LogSource -> Text -> m LogEntry
traceLog LogSource
Logged forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall source target. From source target => source -> target
from forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show
constCapsFor :: Const -> Robot -> Maybe Capability
constCapsFor :: Const -> Robot -> Maybe Capability
constCapsFor Const
Move Robot
r
| Robot
r forall s a. s -> Getting a s a -> a
^. Lens' Robot Bool
robotHeavy = forall a. a -> Maybe a
Just Capability
CMoveheavy
constCapsFor Const
c Robot
_ = Const -> Maybe Capability
constCaps Const
c
ensureCanExecute :: (Has (State Robot) sig m, Has (State GameState) sig m, Has (Throw Exn) sig m) => Const -> m ()
ensureCanExecute :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State Robot) sig m, Has (State GameState) sig m,
Has (Throw Exn) sig m) =>
Const -> m ()
ensureCanExecute Const
c =
forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (State s) sig m =>
(s -> a) -> m a
gets @Robot (Const -> Robot -> Maybe Capability
constCapsFor Const
c) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe Capability
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just Capability
cap -> do
Bool
creative <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' GameState Bool
creativeMode
Bool
sys <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot Bool
systemRobot
Set Capability
robotCaps <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot (Set Capability)
robotCapabilities
let hasCaps :: Bool
hasCaps = Capability
cap forall a. Ord a => a -> Set a -> Bool
`S.member` Set Capability
robotCaps
(Bool
sys Bool -> Bool -> Bool
|| Bool
creative Bool -> Bool -> Bool
|| Bool
hasCaps)
forall e (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw e) sig m =>
Bool -> e -> m ()
`holdsOr` IncapableFix -> Requirements -> Term -> Exn
Incapable IncapableFix
FixByInstall (Capability -> Requirements
R.singletonCap Capability
cap) (Const -> Term
TConst Const
c)
hasCapability :: (Has (State Robot) sig m, Has (State GameState) sig m) => Capability -> m Bool
hasCapability :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State Robot) sig m, Has (State GameState) sig m) =>
Capability -> m Bool
hasCapability Capability
cap = do
Bool
creative <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' GameState Bool
creativeMode
Bool
sys <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot Bool
systemRobot
Set Capability
caps <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot (Set Capability)
robotCapabilities
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
sys Bool -> Bool -> Bool
|| Bool
creative Bool -> Bool -> Bool
|| Capability
cap forall a. Ord a => a -> Set a -> Bool
`S.member` Set Capability
caps)
hasCapabilityFor ::
(Has (State Robot) sig m, Has (State GameState) sig m, Has (Throw Exn) sig m) => Capability -> Term -> m ()
hasCapabilityFor :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State Robot) sig m, Has (State GameState) sig m,
Has (Throw Exn) sig m) =>
Capability -> Term -> m ()
hasCapabilityFor Capability
cap Term
term = do
Bool
h <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State Robot) sig m, Has (State GameState) sig m) =>
Capability -> m Bool
hasCapability Capability
cap
Bool
h forall e (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw e) sig m =>
Bool -> e -> m ()
`holdsOr` IncapableFix -> Requirements -> Term -> Exn
Incapable IncapableFix
FixByInstall (Capability -> Requirements
R.singletonCap Capability
cap) Term
term
cmdExn :: Const -> [Text] -> Exn
cmdExn :: Const -> [Text] -> Exn
cmdExn Const
c [Text]
parts = Const -> Text -> Exn
CmdFailed Const
c ([Text] -> Text
T.unwords [Text]
parts)
raise :: (Has (Throw Exn) sig m) => Const -> [Text] -> m a
raise :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Const -> [Text] -> m a
raise Const
c [Text]
parts = forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError (Const -> [Text] -> Exn
cmdExn Const
c [Text]
parts)
withExceptions :: Monad m => Store -> Cont -> ThrowC Exn m CESK -> m CESK
withExceptions :: forall (m :: * -> *).
Monad m =>
Store -> Cont -> ThrowC Exn m CESK -> m CESK
withExceptions Store
s Cont
k ThrowC Exn m CESK
m = do
Either Exn CESK
res <- forall e (m :: * -> *) a. ThrowC e m a -> m (Either e a)
runThrow ThrowC Exn m CESK
m
case Either Exn CESK
res of
Left Exn
exn -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exn -> Store -> Cont -> CESK
Up Exn
exn Store
s Cont
k
Right CESK
a -> forall (m :: * -> *) a. Monad m => a -> m a
return CESK
a
tickRobot :: (Has (State GameState) sig m, Has (Lift IO) sig m) => Robot -> m Robot
tickRobot :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (Lift IO) sig m) =>
Robot -> m Robot
tickRobot Robot
r = do
RID
steps <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' GameState RID
robotStepsPerTick
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (Lift IO) sig m) =>
Robot -> m Robot
tickRobotRec (Robot
r forall a b. a -> (a -> b) -> b
& Lens' Robot RID
tickSteps forall s t a b. ASetter s t a b -> b -> s -> t
.~ RID
steps)
tickRobotRec :: (Has (State GameState) sig m, Has (Lift IO) sig m) => Robot -> m Robot
tickRobotRec :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (Lift IO) sig m) =>
Robot -> m Robot
tickRobotRec Robot
r
| Robot -> Bool
isActive Robot
r Bool -> Bool -> Bool
&& (Robot
r forall s a. s -> Getting a s a -> a
^. Lens' Robot Bool
runningAtomic Bool -> Bool -> Bool
|| Robot
r forall s a. s -> Getting a s a -> a
^. Lens' Robot RID
tickSteps forall a. Ord a => a -> a -> Bool
> RID
0) =
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (Lift IO) sig m) =>
Robot -> m Robot
stepRobot Robot
r forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (Lift IO) sig m) =>
Robot -> m Robot
tickRobotRec
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return Robot
r
stepRobot :: (Has (State GameState) sig m, Has (Lift IO) sig m) => Robot -> m Robot
stepRobot :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (Lift IO) sig m) =>
Robot -> m Robot
stepRobot Robot
r = do
(Robot
r', CESK
cesk') <- forall s (m :: * -> *) a. s -> StateC s m a -> m (s, a)
runState (Robot
r forall a b. a -> (a -> b) -> b
& Lens' Robot RID
tickSteps forall a s t. Num a => ASetter s t a a -> a -> s -> t
-~ RID
1) (forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m,
Has (Lift IO) sig m) =>
CESK -> m CESK
stepCESK (Robot
r forall s a. s -> Getting a s a -> a
^. Lens' Robot CESK
machine))
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Robot
r' forall a b. a -> (a -> b) -> b
& Lens' Robot CESK
machine forall s t a b. ASetter s t a b -> b -> s -> t
.~ CESK
cesk'
stepCESK :: (Has (State GameState) sig m, Has (State Robot) sig m, Has (Lift IO) sig m) => CESK -> m CESK
stepCESK :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m,
Has (Lift IO) sig m) =>
CESK -> m CESK
stepCESK CESK
cesk = case CESK
cesk of
Waiting Integer
wakeupTime CESK
cesk' -> do
Integer
time <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' GameState Integer
ticks
if Integer
wakeupTime forall a. Ord a => a -> a -> Bool
<= Integer
time
then forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m,
Has (Lift IO) sig m) =>
CESK -> m CESK
stepCESK CESK
cesk'
else forall (m :: * -> *) a. Monad m => a -> m a
return CESK
cesk
Out Value
v Store
s (FImmediate WorldUpdate
wf RobotUpdate
rf : Cont
k) -> do
Either Exn (World RID Entity)
wc <- WorldUpdate -> World RID Entity -> Either Exn (World RID Entity)
worldUpdate WorldUpdate
wf forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' GameState (World RID Entity)
world
case Either Exn (World RID Entity)
wc of
Left Exn
exn -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exn -> Store -> Cont -> CESK
Up Exn
exn Store
s Cont
k
Right World RID Entity
wo -> do
Lens' Robot Inventory
robotInventory forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= RobotUpdate -> Inventory -> Inventory
robotUpdateInventory RobotUpdate
rf
Lens' GameState (World RID Entity)
world forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= World RID Entity
wo
Lens' GameState Bool
needsRedraw forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= Bool
True
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m,
Has (Lift IO) sig m) =>
CESK -> m CESK
stepCESK (Value -> Store -> Cont -> CESK
Out Value
v Store
s Cont
k)
In Term
TUnit Env
_ Store
s Cont
k -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s Cont
k
In (TDir Direction
d) Env
_ Store
s Cont
k -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Direction -> Value
VDir Direction
d) Store
s Cont
k
In (TInt Integer
n) Env
_ Store
s Cont
k -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Integer -> Value
VInt Integer
n) Store
s Cont
k
In (TText Text
str) Env
_ Store
s Cont
k -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Text -> Value
VText Text
str) Store
s Cont
k
In (TBool Bool
b) Env
_ Store
s Cont
k -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Bool -> Value
VBool Bool
b) Store
s Cont
k
In (TAntiText Text
v) Env
_ Store
s Cont
k ->
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exn -> Store -> Cont -> CESK
Up (Text -> Exn
Fatal (Text -> Text -> Text
T.append Text
"Antiquoted variable found at runtime: $str:" Text
v)) Store
s Cont
k
In (TAntiInt Text
v) Env
_ Store
s Cont
k ->
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exn -> Store -> Cont -> CESK
Up (Text -> Exn
Fatal (Text -> Text -> Text
T.append Text
"Antiquoted variable found at runtime: $int:" Text
v)) Store
s Cont
k
In (TRequireDevice {}) Env
e Store
s Cont
k -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Term -> Env -> Store -> Cont -> CESK
In (Const -> Term
TConst Const
Noop) Env
e Store
s Cont
k
In (TRequire {}) Env
e Store
s Cont
k -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Term -> Env -> Store -> Cont -> CESK
In (Const -> Term
TConst Const
Noop) Env
e Store
s Cont
k
In (TRobot RID
rid) Env
_ Store
s Cont
k -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (RID -> Value
VRobot RID
rid) Store
s Cont
k
In (TConst Const
c) Env
_ Store
s Cont
k
| Const -> RID
arity Const
c forall a. Eq a => a -> a -> Bool
== RID
0 Bool -> Bool -> Bool
&& Bool -> Bool
not (Const -> Bool
isCmd Const
c) -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m,
Has (Lift IO) sig m) =>
Const -> [Value] -> Store -> Cont -> m CESK
evalConst Const
c [] Store
s Cont
k
| Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Const -> [Value] -> Value
VCApp Const
c []) Store
s Cont
k
In (TVar Text
x) Env
e Store
s Cont
k -> forall (m :: * -> *).
Monad m =>
Store -> Cont -> ThrowC Exn m CESK -> m CESK
withExceptions Store
s Cont
k forall a b. (a -> b) -> a -> b
$ do
Value
v <-
forall t. Text -> Ctx t -> Maybe t
lookup Text
x Env
e
forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
Maybe a -> e -> m a
`isJustOr` Text -> Exn
Fatal ([Text] -> Text
T.unwords [Text
"Undefined variable", Text
x, Text
"encountered while running the interpreter."])
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
v Store
s Cont
k
In (TPair Term
t1 Term
t2) Env
e Store
s Cont
k -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Term -> Env -> Store -> Cont -> CESK
In Term
t1 Env
e Store
s (Term -> Env -> Frame
FSnd Term
t2 Env
e forall a. a -> [a] -> [a]
: Cont
k)
Out Value
v1 Store
s (FSnd Term
t2 Env
e : Cont
k) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Term -> Env -> Store -> Cont -> CESK
In Term
t2 Env
e Store
s (Value -> Frame
FFst Value
v1 forall a. a -> [a] -> [a]
: Cont
k)
Out Value
v2 Store
s (FFst Value
v1 : Cont
k) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Value -> Value -> Value
VPair Value
v1 Value
v2) Store
s Cont
k
In (TLam Text
x Maybe Type
_ Term
t) Env
e Store
s Cont
k -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Text -> Term -> Env -> Value
VClo Text
x Term
t Env
e) Store
s Cont
k
In (TApp Term
t1 Term
t2) Env
e Store
s Cont
k -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Term -> Env -> Store -> Cont -> CESK
In Term
t1 Env
e Store
s (Term -> Env -> Frame
FArg Term
t2 Env
e forall a. a -> [a] -> [a]
: Cont
k)
Out Value
v1 Store
s (FArg Term
t2 Env
e : Cont
k) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Term -> Env -> Store -> Cont -> CESK
In Term
t2 Env
e Store
s (Value -> Frame
FApp Value
v1 forall a. a -> [a] -> [a]
: Cont
k)
Out Value
v2 Store
s (FApp (VClo Text
x Term
t Env
e) : Cont
k) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Term -> Env -> Store -> Cont -> CESK
In Term
t (forall t. Text -> t -> Ctx t -> Ctx t
addBinding Text
x Value
v2 Env
e) Store
s Cont
k
Out Value
v2 Store
s (FApp (VCApp Const
c [Value]
args) : Cont
k)
| Bool -> Bool
not (Const -> Bool
isCmd Const
c)
Bool -> Bool -> Bool
&& Const -> RID
arity Const
c forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> RID
length [Value]
args forall a. Num a => a -> a -> a
+ RID
1 ->
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m,
Has (Lift IO) sig m) =>
Const -> [Value] -> Store -> Cont -> m CESK
evalConst Const
c (forall a. [a] -> [a]
reverse (Value
v2 forall a. a -> [a] -> [a]
: [Value]
args)) Store
s Cont
k
| Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Const -> [Value] -> Value
VCApp Const
c (Value
v2 forall a. a -> [a] -> [a]
: [Value]
args)) Store
s Cont
k
Out Value
_ Store
s (FApp Value
_ : Cont
_) -> forall {m :: * -> *}. Monad m => Store -> Text -> m CESK
badMachineState Store
s Text
"FApp of non-function"
In (TLet Bool
False Text
x Maybe Polytype
_ Term
t1 Term
t2) Env
e Store
s Cont
k -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Term -> Env -> Store -> Cont -> CESK
In Term
t1 Env
e Store
s (Text -> Term -> Env -> Frame
FLet Text
x Term
t2 Env
e forall a. a -> [a] -> [a]
: Cont
k)
In (TLet Bool
True Text
x Maybe Polytype
_ Term
t1 Term
t2) Env
e Store
s Cont
k ->
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Term -> Env -> Store -> Cont -> CESK
In (DelayType -> Term -> Term
TDelay (Maybe Text -> DelayType
MemoizedDelay forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Text
x) Term
t1) Env
e Store
s (Text -> Term -> Env -> Frame
FLet Text
x Term
t2 Env
e forall a. a -> [a] -> [a]
: Cont
k)
Out Value
v1 Store
s (FLet Text
x Term
t2 Env
e : Cont
k) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Term -> Env -> Store -> Cont -> CESK
In Term
t2 (forall t. Text -> t -> Ctx t -> Ctx t
addBinding Text
x Value
v1 Env
e) Store
s Cont
k
In tm :: Term
tm@(TDef Bool
r Text
x Maybe Polytype
_ Term
t) Env
e Store
s Cont
k -> forall (m :: * -> *).
Monad m =>
Store -> Cont -> ThrowC Exn m CESK -> m CESK
withExceptions Store
s Cont
k forall a b. (a -> b) -> a -> b
$ do
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State Robot) sig m, Has (State GameState) sig m,
Has (Throw Exn) sig m) =>
Capability -> Term -> m ()
hasCapabilityFor Capability
CEnv Term
tm
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Bool -> Text -> Term -> Env -> Value
VDef Bool
r Text
x Term
t Env
e) Store
s Cont
k
In (TBind Maybe Text
mx Term
t1 Term
t2) Env
e Store
s Cont
k -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Maybe Text -> Term -> Term -> Env -> Value
VBind Maybe Text
mx Term
t1 Term
t2 Env
e) Store
s Cont
k
In (TDelay DelayType
SimpleDelay Term
t) Env
e Store
s Cont
k -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Term -> Env -> Value
VDelay Term
t Env
e) Store
s Cont
k
In (TDelay (MemoizedDelay Maybe Text
x) Term
t) Env
e Store
s Cont
k -> do
let (RID
loc, Store
s') = Env -> Term -> Store -> (RID, Store)
allocate (forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (forall t. Text -> t -> Ctx t -> Ctx t
`addBinding` RID -> Value
VRef RID
loc) Maybe Text
x Env
e) Term
t Store
s
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (RID -> Value
VRef RID
loc) Store
s' Cont
k
Out Value
v Store
s (FUpdate RID
loc : Cont
k) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
v (RID -> Cell -> Store -> Store
setCell RID
loc (Value -> Cell
V Value
v) Store
s) Cont
k
Out (VDef Bool
r Text
x Term
t Env
e) Store
s (Frame
FExec : Cont
k) ->
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Term -> Env -> Store -> Cont -> CESK
In (DelayType -> Term -> Term
TDelay (Maybe Text -> DelayType
MemoizedDelay forall a b. (a -> b) -> a -> b
$ forall a. a -> a -> Bool -> a
bool forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just Text
x) Bool
r) Term
t) Env
e Store
s (Text -> Frame
FDef Text
x forall a. a -> [a] -> [a]
: Cont
k)
Out Value
v Store
s (FDef Text
x : Cont
k) ->
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Value -> Env -> Value
VResult Value
VUnit (forall t. Text -> t -> Ctx t
singleton Text
x Value
v)) Store
s Cont
k
Out (VCApp Const
c [Value]
args) Store
s (Frame
FExec : Cont
k) -> do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Const -> Bool
isTangible Const
c) forall a b. (a -> b) -> a -> b
$ Lens' Robot RID
tickSteps forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= RID
0
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m,
Has (Lift IO) sig m) =>
Const -> [Value] -> Store -> Cont -> m CESK
evalConst Const
c (forall a. [a] -> [a]
reverse [Value]
args) Store
s Cont
k
Out Value
v Store
s (Frame
FFinishAtomic : Cont
k) -> do
Lens' Robot Bool
runningAtomic forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= Bool
False
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
v Store
s Cont
k
Out (VBind Maybe Text
mx Term
c1 Term
c2 Env
e) Store
s (Frame
FExec : Cont
k) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Term -> Env -> Store -> Cont -> CESK
In Term
c1 Env
e Store
s (Frame
FExec forall a. a -> [a] -> [a]
: Maybe Text -> Term -> Env -> Frame
FBind Maybe Text
mx Term
c2 Env
e forall a. a -> [a] -> [a]
: Cont
k)
Out (VResult Value
v Env
ve) Store
s (FBind Maybe Text
mx Term
t2 Env
e : Cont
k) -> do
let ve' :: Env
ve' = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (forall t. Text -> t -> Ctx t -> Ctx t
`addBinding` Value
v) Maybe Text
mx Env
ve
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Term -> Env -> Store -> Cont -> CESK
In Term
t2 (Env
e forall t. Ctx t -> Ctx t -> Ctx t
`union` Env
ve') Store
s (Frame
FExec forall a. a -> [a] -> [a]
: Env -> Cont -> Cont
fUnionEnv Env
ve' Cont
k)
Out Value
_ Store
s (FBind Maybe Text
Nothing Term
t2 Env
e : Cont
k) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Term -> Env -> Store -> Cont -> CESK
In Term
t2 Env
e Store
s (Frame
FExec forall a. a -> [a] -> [a]
: Cont
k)
Out Value
v Store
s (FBind (Just Text
x) Term
t2 Env
e : Cont
k) -> do
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Term -> Env -> Store -> Cont -> CESK
In Term
t2 (forall t. Text -> t -> Ctx t -> Ctx t
addBinding Text
x Value
v Env
e) Store
s (Frame
FExec forall a. a -> [a] -> [a]
: Env -> Cont -> Cont
fUnionEnv (forall t. Text -> t -> Ctx t
singleton Text
x Value
v) Cont
k)
Out (VResult Value
v Env
e2) Store
s (FUnionEnv Env
e1 : Cont
k) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Value -> Env -> Value
VResult Value
v (Env
e1 forall t. Ctx t -> Ctx t -> Ctx t
`union` Env
e2)) Store
s Cont
k
Out Value
v Store
s (FUnionEnv Env
e : Cont
k) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Value -> Env -> Value
VResult Value
v Env
e) Store
s Cont
k
Out (VResult Value
v Env
e) Store
s (FLoadEnv TCtx
ctx ReqCtx
rctx : Cont
k) -> do
Lens' Robot RobotContext
robotContext forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' RobotContext Env
defVals forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= (forall t. Ctx t -> Ctx t -> Ctx t
`union` Env
e)
Lens' Robot RobotContext
robotContext forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' RobotContext TCtx
defTypes forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= (forall t. Ctx t -> Ctx t -> Ctx t
`union` TCtx
ctx)
Lens' Robot RobotContext
robotContext forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' RobotContext ReqCtx
defReqs forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= (forall t. Ctx t -> Ctx t -> Ctx t
`union` ReqCtx
rctx)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
v Store
s Cont
k
Out Value
v Store
s (FLoadEnv {} : Cont
k) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
v Store
s Cont
k
Out Value
_ Store
s (Frame
FExec : Cont
_) -> forall {m :: * -> *}. Monad m => Store -> Text -> m CESK
badMachineState Store
s Text
"FExec frame with non-executable value"
Out (VResult Value
v Env
_) Store
s Cont
k -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
v Store
s Cont
k
Out Value
v Store
s (FTry {} : Cont
k) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
v Store
s Cont
k
Up Exn
exn Store
s [] -> do
let s' :: Store
s' = Store -> Store
resetBlackholes Store
s
Bool
h <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State Robot) sig m, Has (State GameState) sig m) =>
Capability -> m Bool
hasCapability Capability
CLog
EntityMap
em <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' GameState EntityMap
entityMap
if Bool
h
then do
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m) =>
LogSource -> Text -> m LogEntry
traceLog LogSource
ErrorTrace (EntityMap -> Exn -> Text
formatExn EntityMap
em Exn
exn)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s []
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s' []
Up exn :: Exn
exn@Fatal {} Store
s Cont
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exn -> Store -> Cont -> CESK
Up Exn
exn Store
s []
Up exn :: Exn
exn@Incapable {} Store
s Cont
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exn -> Store -> Cont -> CESK
Up Exn
exn Store
s []
Up exn :: Exn
exn@InfiniteLoop {} Store
s Cont
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exn -> Store -> Cont -> CESK
Up Exn
exn Store
s []
Up Exn
_ Store
s (FTry Value
c : Cont
k) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
c Store
s (Value -> Frame
FApp (Const -> [Value] -> Value
VCApp Const
Force []) forall a. a -> [a] -> [a]
: Frame
FExec forall a. a -> [a] -> [a]
: Cont
k)
Up Exn
exn Store
s (Frame
_ : Cont
k) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exn -> Store -> Cont -> CESK
Up Exn
exn Store
s Cont
k
done :: CESK
done@(Out Value
_ Store
_ []) -> forall (m :: * -> *) a. Monad m => a -> m a
return CESK
done
where
badMachineState :: Store -> Text -> m CESK
badMachineState Store
s Text
msg =
let msg' :: Text
msg' =
[Text] -> Text
T.unlines
[ Text -> Text -> Text
T.append Text
"Bad machine state in stepRobot: " Text
msg
, forall source target. From source target => source -> target
from (CESK -> String
prettyCESK CESK
cesk)
]
in forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exn -> Store -> Cont -> CESK
Up (Text -> Exn
Fatal Text
msg') Store
s []
fUnionEnv :: Env -> Cont -> Cont
fUnionEnv Env
e1 = \case
FUnionEnv Env
e2 : Cont
k -> Env -> Frame
FUnionEnv (Env
e2 forall t. Ctx t -> Ctx t -> Ctx t
`union` Env
e1) forall a. a -> [a] -> [a]
: Cont
k
Cont
k -> Env -> Frame
FUnionEnv Env
e1 forall a. a -> [a] -> [a]
: Cont
k
evalConst ::
(Has (State GameState) sig m, Has (State Robot) sig m, Has (Lift IO) sig m) => Const -> [Value] -> Store -> Cont -> m CESK
evalConst :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m,
Has (Lift IO) sig m) =>
Const -> [Value] -> Store -> Cont -> m CESK
evalConst Const
c [Value]
vs Store
s Cont
k = do
Either Exn CESK
res <- forall exc (m :: * -> *) a. ErrorC exc m a -> m (Either exc a)
runError forall a b. (a -> b) -> a -> b
$ forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(HasRobotStepState sig m, Has (Lift IO) sig m) =>
Const -> [Value] -> Store -> Cont -> m CESK
execConst Const
c [Value]
vs Store
s Cont
k
case Either Exn CESK
res of
Left Exn
exn -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exn -> Store -> Cont -> CESK
Up Exn
exn Store
s Cont
k
Right CESK
cek' -> forall (m :: * -> *) a. Monad m => a -> m a
return CESK
cek'
seedProgram :: Integer -> Integer -> Text -> ProcessedTerm
seedProgram :: Integer -> Integer -> Text -> ProcessedTerm
seedProgram Integer
minTime Integer
randTime Text
thing =
[tmQ|
try {
r <- random (1 + $int:randTime);
wait (r + $int:minTime);
appear "|";
r <- random (1 + $int:randTime);
wait (r + $int:minTime);
place $str:thing;
} {};
selfdestruct
|]
addSeedBot :: Has (State GameState) sig m => Entity -> (Integer, Integer) -> V2 Int64 -> TimeSpec -> m ()
addSeedBot :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
Entity -> (Integer, Integer) -> V2 Int64 -> TimeSpec -> m ()
addSeedBot Entity
e (Integer
minT, Integer
maxT) V2 Int64
loc TimeSpec
ts =
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
TRobot -> m Robot
addTRobot forall a b. (a -> b) -> a -> b
$
forall (phase :: RobotPhase).
RobotID phase
-> Maybe RID
-> Text
-> [Text]
-> RobotLocation phase
-> V2 Int64
-> Display
-> CESK
-> [Entity]
-> [(RID, Entity)]
-> Bool
-> Bool
-> TimeSpec
-> RobotR phase
mkRobot
()
forall a. Maybe a
Nothing
Text
"seed"
[Text
"A growing seed."]
(forall a. a -> Maybe a
Just V2 Int64
loc)
(forall a. a -> a -> V2 a
V2 Int64
0 Int64
0)
( Char -> Display
defaultEntityDisplay Char
'.'
forall a b. a -> (a -> b) -> b
& Lens' Display AttrName
displayAttr forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Entity
e forall s a. s -> Getting a s a -> a
^. Lens' Entity Display
entityDisplay forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Display AttrName
displayAttr)
forall a b. a -> (a -> b) -> b
& Lens' Display RID
displayPriority forall s t a b. ASetter s t a b -> b -> s -> t
.~ RID
0
)
(ProcessedTerm -> Env -> Store -> CESK
initMachine (Integer -> Integer -> Text -> ProcessedTerm
seedProgram Integer
minT (Integer
maxT forall a. Num a => a -> a -> a
- Integer
minT) (Entity
e forall s a. s -> Getting a s a -> a
^. Lens' Entity Text
entityName)) forall t. Ctx t
empty Store
emptyStore)
[]
[(RID
1, Entity
e)]
Bool
True
Bool
False
TimeSpec
ts
type HasRobotStepState sig m = (Has (State GameState) sig m, Has (State Robot) sig m, Has (Throw Exn) sig m)
execConst ::
(HasRobotStepState sig m, Has (Lift IO) sig m) =>
Const ->
[Value] ->
Store ->
Cont ->
m CESK
execConst :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(HasRobotStepState sig m, Has (Lift IO) sig m) =>
Const -> [Value] -> Store -> Cont -> m CESK
execConst Const
c [Value]
vs Store
s Cont
k = do
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State Robot) sig m, Has (State GameState) sig m,
Has (Throw Exn) sig m) =>
Const -> m ()
ensureCanExecute Const
c
case Const
c of
Const
Noop -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s Cont
k
Const
Return -> case [Value]
vs of
[Value
v] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
v Store
s Cont
k
[Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
Const
Wait -> case [Value]
vs of
[VInt Integer
d] -> do
Integer
time <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' GameState Integer
ticks
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Integer -> CESK -> CESK
Waiting (Integer
time forall a. Num a => a -> a -> a
+ Integer
d) (Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s Cont
k)
[Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
Const
Selfdestruct -> do
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
m ()
destroyIfNotBase
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
m ()
flagRedraw
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s Cont
k
Const
Move -> do
V2 Int64
loc <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot (V2 Int64)
robotLocation
Maybe (V2 Int64)
orient <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot (Maybe (V2 Int64))
robotOrientation
let nextLoc :: V2 Int64
nextLoc = V2 Int64
loc forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^ (Maybe (V2 Int64)
orient forall a. Maybe a -> a -> a
? forall (f :: * -> *) a. (Additive f, Num a) => f a
zero)
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
V2 Int64 -> MoveFailure -> m ()
checkMoveAhead V2 Int64
nextLoc forall a b. (a -> b) -> a -> b
$
MoveFailure
{ failIfBlocked :: RobotFailure
failIfBlocked = RobotFailure
ThrowExn
, failIfDrown :: RobotFailure
failIfDrown = RobotFailure
Destroy
}
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
V2 Int64 -> V2 Int64 -> m ()
updateRobotLocation V2 Int64
loc V2 Int64
nextLoc
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s Cont
k
Const
Teleport -> case [Value]
vs of
[VRobot RID
rid, VPair (VInt Integer
x) (VInt Integer
y)] -> do
Robot
target <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
RID -> m Robot
getRobotWithinTouch RID
rid
let oldLoc :: V2 Int64
oldLoc = Robot
target forall s a. s -> Getting a s a -> a
^. Getter Robot (V2 Int64)
robotLocation
nextLoc :: V2 Int64
nextLoc = forall a. a -> a -> V2 a
V2 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
x) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
y)
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
RID
-> (forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
m ())
-> m ()
onTarget RID
rid forall a b. (a -> b) -> a -> b
$ do
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
V2 Int64 -> MoveFailure -> m ()
checkMoveAhead V2 Int64
nextLoc forall a b. (a -> b) -> a -> b
$
MoveFailure
{ failIfBlocked :: RobotFailure
failIfBlocked = RobotFailure
Destroy
, failIfDrown :: RobotFailure
failIfDrown = RobotFailure
Destroy
}
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
V2 Int64 -> V2 Int64 -> m ()
updateRobotLocation V2 Int64
oldLoc V2 Int64
nextLoc
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s Cont
k
[Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
Const
Grab -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(HasRobotStepState sig m, Has (Lift IO) sig m) =>
GrabbingCmd -> m CESK
doGrab GrabbingCmd
Grab'
Const
Harvest -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(HasRobotStepState sig m, Has (Lift IO) sig m) =>
GrabbingCmd -> m CESK
doGrab GrabbingCmd
Harvest'
Const
Swap -> case [Value]
vs of
[VText Text
name] -> do
V2 Int64
loc <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot (V2 Int64)
robotLocation
Entity
e <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Text -> m Entity
hasInInventoryOrFail Text
name
CESK
r <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(HasRobotStepState sig m, Has (Lift IO) sig m) =>
GrabbingCmd -> m CESK
doGrab GrabbingCmd
Swap'
case CESK
r of
Out {} -> do
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
V2 Int64 -> (Maybe Entity -> Maybe Entity) -> m ()
updateEntityAt V2 Int64
loc (forall a b. a -> b -> a
const (forall a. a -> Maybe a
Just Entity
e))
Lens' Robot Inventory
robotInventory forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= Entity -> Inventory -> Inventory
delete Entity
e
CESK
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
forall (m :: * -> *) a. Monad m => a -> m a
return CESK
r
[Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
Const
Turn -> case [Value]
vs of
[VDir Direction
d] -> do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Direction -> Bool
isCardinal Direction
d) forall a b. (a -> b) -> a -> b
$ forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State Robot) sig m, Has (State GameState) sig m,
Has (Throw Exn) sig m) =>
Capability -> Term -> m ()
hasCapabilityFor Capability
COrient (Direction -> Term
TDir Direction
d)
Lens' Robot (Maybe (V2 Int64))
robotOrientation forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= Direction -> V2 Int64 -> V2 Int64
applyTurn Direction
d
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
m ()
flagRedraw
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s Cont
k
[Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
Const
Place -> case [Value]
vs of
[VText Text
name] -> do
V2 Int64
loc <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot (V2 Int64)
robotLocation
Bool
nothingHere <- forall a. Maybe a -> Bool
isNothing forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
V2 Int64 -> m (Maybe Entity)
entityAt V2 Int64
loc
Bool
nothingHere forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Bool -> [Text] -> m ()
`holdsOrFail` [Text
"There is already an entity here."]
Entity
e <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Text -> m Entity
hasInInventoryOrFail Text
name
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
V2 Int64 -> (Maybe Entity -> Maybe Entity) -> m ()
updateEntityAt V2 Int64
loc (forall a b. a -> b -> a
const (forall a. a -> Maybe a
Just Entity
e))
Lens' Robot Inventory
robotInventory forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= Entity -> Inventory -> Inventory
delete Entity
e
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
m ()
flagRedraw
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s Cont
k
[Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
Const
Give -> case [Value]
vs of
[VRobot RID
otherID, VText Text
itemName] -> do
Robot
_other <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
RID -> m Robot
getRobotWithinTouch RID
otherID
Entity
item <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Text -> Text -> m Entity
ensureItem Text
itemName Text
"give"
RID
myID <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot RID
robotID
RID
focusedID <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter GameState RID
focusedRobotID
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RID
otherID forall a. Eq a => a -> a -> Bool
/= RID
myID) forall a b. (a -> b) -> a -> b
$ do
Lens' GameState (IntMap Robot)
robotMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at RID
otherID forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Robot Inventory
robotInventory forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= Entity -> Inventory -> Inventory
insert Entity
item
Lens' Robot Inventory
robotInventory forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= Entity -> Inventory -> Inventory
delete Entity
item
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RID
focusedID forall a. Eq a => a -> a -> Bool
== RID
myID Bool -> Bool -> Bool
|| RID
focusedID forall a. Eq a => a -> a -> Bool
== RID
otherID) forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
m ()
flagRedraw
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s Cont
k
[Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
Const
Install -> case [Value]
vs of
[VRobot RID
otherID, VText Text
itemName] -> do
Robot
_other <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
RID -> m Robot
getRobotWithinTouch RID
otherID
Entity
item <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Text -> Text -> m Entity
ensureItem Text
itemName Text
"install"
RID
myID <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot RID
robotID
RID
focusedID <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter GameState RID
focusedRobotID
case RID
otherID forall a. Eq a => a -> a -> Bool
== RID
myID of
Bool
True -> do
Bool
already <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use (Lens' Robot Inventory
installedDevices forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to (Inventory -> Entity -> Bool
`E.contains` Entity
item))
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
already forall a b. (a -> b) -> a -> b
$ do
Lens' Robot Inventory
installedDevices forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= Entity -> Inventory -> Inventory
insert Entity
item
Lens' Robot Inventory
robotInventory forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= Entity -> Inventory -> Inventory
delete Entity
item
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RID
focusedID forall a. Eq a => a -> a -> Bool
== RID
myID) forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
m ()
flagRedraw
Bool
False -> do
let otherDevices :: (Inventory -> Const (First Bool) Inventory)
-> GameState -> Const (First Bool) GameState
otherDevices = Lens' GameState (IntMap Robot)
robotMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at RID
otherID forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Robot Inventory
installedDevices
Maybe Bool
already <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use forall a b. (a -> b) -> a -> b
$ forall a s.
Getting (First a) s a -> IndexPreservingGetter s (Maybe a)
pre ((Inventory -> Const (First Bool) Inventory)
-> GameState -> Const (First Bool) GameState
otherDevices forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to (Inventory -> Entity -> Bool
`E.contains` Entity
item))
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe Bool
already forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Bool
True) forall a b. (a -> b) -> a -> b
$ do
Lens' GameState (IntMap Robot)
robotMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at RID
otherID forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Robot Inventory
installedDevices forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= Entity -> Inventory -> Inventory
insert Entity
item
Lens' Robot Inventory
robotInventory forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= Entity -> Inventory -> Inventory
delete Entity
item
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RID
focusedID forall a. Eq a => a -> a -> Bool
== RID
myID Bool -> Bool -> Bool
|| RID
focusedID forall a. Eq a => a -> a -> Bool
== RID
otherID) forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
m ()
flagRedraw
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s Cont
k
[Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
Const
Make -> case [Value]
vs of
[VText Text
name] -> do
Inventory
inv <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot Inventory
robotInventory
Inventory
ins <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot Inventory
installedDevices
EntityMap
em <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' GameState EntityMap
entityMap
Entity
e <-
Text -> EntityMap -> Maybe Entity
lookupEntityName Text
name EntityMap
em
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Maybe a -> [Text] -> m a
`isJustOrFail` [Text
"I've never heard of", Text -> Text
indefiniteQ Text
name forall a. Semigroup a => a -> a -> a
<> Text
"."]
IntMap [Recipe Entity]
outRs <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' GameState (IntMap [Recipe Entity])
recipesOut
Bool
creative <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' GameState Bool
creativeMode
let create :: [Text] -> [Text]
create [Text]
l = [Text]
l forall a. Semigroup a => a -> a -> a
<> [Text
"You can use 'create \"" forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
"\"' instead." | Bool
creative]
let recipes :: [Recipe Entity]
recipes = forall a. (a -> Bool) -> [a] -> [a]
filter Recipe Entity -> Bool
increase (IntMap [Recipe Entity] -> Entity -> [Recipe Entity]
recipesFor IntMap [Recipe Entity]
outRs Entity
e)
increase :: Recipe Entity -> Bool
increase Recipe Entity
r = forall {b} {t :: * -> *}. (Num b, Foldable t) => t (b, Entity) -> b
countIn (Recipe Entity
r forall s a. s -> Getting a s a -> a
^. forall e. Lens' (Recipe e) (IngredientList e)
recipeOutputs) forall a. Ord a => a -> a -> Bool
> forall {b} {t :: * -> *}. (Num b, Foldable t) => t (b, Entity) -> b
countIn (Recipe Entity
r forall s a. s -> Getting a s a -> a
^. forall e. Lens' (Recipe e) (IngredientList e)
recipeInputs)
countIn :: t (b, Entity) -> b
countIn t (b, Entity)
xs = forall b a. b -> (a -> b) -> Maybe a -> b
maybe b
0 forall a b. (a, b) -> a
fst (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((forall a. Eq a => a -> a -> Bool
== Entity
e) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) t (b, Entity)
xs)
Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Recipe Entity]
recipes)
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Bool -> [Text] -> m ()
`holdsOrFail` [Text] -> [Text]
create [Text
"There is no known recipe for making", Text -> Text
indefinite Text
name forall a. Semigroup a => a -> a -> a
<> Text
"."]
let displayMissingCount :: a -> MissingType -> target
displayMissingCount a
mc = \case
MissingType
MissingInput -> forall source target. From source target => source -> target
from (forall a. Show a => a -> String
show a
mc)
MissingType
MissingCatalyst -> target
"not installed"
displayMissingIngredient :: MissingIngredient -> Text
displayMissingIngredient (MissingIngredient MissingType
mk RID
mc Entity
me) =
Text
" - " forall a. Semigroup a => a -> a -> a
<> Entity
me forall s a. s -> Getting a s a -> a
^. Lens' Entity Text
entityName forall a. Semigroup a => a -> a -> a
<> Text
" (" forall a. Semigroup a => a -> a -> a
<> forall {target} {a}.
(From String target, Show a, IsString target) =>
a -> MissingType -> target
displayMissingCount RID
mc MissingType
mk forall a. Semigroup a => a -> a -> a
<> Text
")"
displayMissingIngredients :: [[MissingIngredient]] -> [Text]
displayMissingIngredients [[MissingIngredient]]
xs = forall a. [a] -> [[a]] -> [a]
L.intercalate [Text
"OR"] (forall a b. (a -> b) -> [a] -> [b]
map MissingIngredient -> Text
displayMissingIngredient forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[MissingIngredient]]
xs)
let ([[MissingIngredient]]
badRecipes, [(Inventory, Inventory -> Inventory, Recipe Entity)]
goodRecipes) = forall a b. [Either a b] -> ([a], [b])
partitionEithers forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map ((Inventory, Inventory)
-> Recipe Entity
-> Either
[MissingIngredient]
(Inventory, Inventory -> Inventory, Recipe Entity)
make (Inventory
inv, Inventory
ins)) forall a b. (a -> b) -> a -> b
$ [Recipe Entity]
recipes
Maybe (Inventory, Inventory -> Inventory, Recipe Entity)
chosenRecipe <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (State GameState) sig m =>
(a -> Integer) -> [a] -> m (Maybe a)
weightedChoice (forall s a. s -> Getting a s a -> a
^. forall s t a b. Field3 s t a b => Lens s t a b
_3 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Lens' (Recipe e) Integer
recipeWeight) [(Inventory, Inventory -> Inventory, Recipe Entity)]
goodRecipes
(Inventory
invTaken, Inventory -> Inventory
changeInv, Recipe Entity
recipe) <-
Maybe (Inventory, Inventory -> Inventory, Recipe Entity)
chosenRecipe
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Maybe a -> [Text] -> m a
`isJustOrFail` [Text] -> [Text]
create
[ Text
"You don't have the ingredients to make"
, Text -> Text
indefinite Text
name forall a. Semigroup a => a -> a -> a
<> Text
"."
, Text
"Missing:\n" forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.unlines ([[MissingIngredient]] -> [Text]
displayMissingIngredients [[MissingIngredient]]
badRecipes)
]
Lens' Robot Inventory
robotInventory forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= Inventory
invTaken
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Entity -> m ()
updateDiscoveredEntities forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) (Recipe Entity
recipe forall s a. s -> Getting a s a -> a
^. forall e. Lens' (Recipe e) (IngredientList e)
recipeOutputs)
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) e.
HasRobotStepState sig m =>
Recipe e -> WorldUpdate -> RobotUpdate -> m CESK
finishCookingRecipe Recipe Entity
recipe ((World RID Entity -> Either Exn (World RID Entity)) -> WorldUpdate
WorldUpdate forall a b. b -> Either a b
Right) ((Inventory -> Inventory) -> RobotUpdate
RobotUpdate Inventory -> Inventory
changeInv)
[Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
Const
Has -> case [Value]
vs of
[VText Text
name] -> do
Inventory
inv <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot Inventory
robotInventory
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Bool -> Value
VBool ((forall a. Ord a => a -> a -> Bool
> RID
0) forall a b. (a -> b) -> a -> b
$ Text -> Inventory -> RID
countByName Text
name Inventory
inv)) Store
s Cont
k
[Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
Const
Installed -> case [Value]
vs of
[VText Text
name] -> do
Inventory
inv <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot Inventory
installedDevices
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Bool -> Value
VBool ((forall a. Ord a => a -> a -> Bool
> RID
0) forall a b. (a -> b) -> a -> b
$ Text -> Inventory -> RID
countByName Text
name Inventory
inv)) Store
s Cont
k
[Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
Const
Count -> case [Value]
vs of
[VText Text
name] -> do
Inventory
inv <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot Inventory
robotInventory
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Integer -> Value
VInt (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Text -> Inventory -> RID
countByName Text
name Inventory
inv)) Store
s Cont
k
[Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
Const
Whereami -> do
V2 Int64
x Int64
y <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot (V2 Int64)
robotLocation
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Value -> Value -> Value
VPair (Integer -> Value
VInt (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
x)) (Integer -> Value
VInt (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
y))) Store
s Cont
k
Const
Time -> do
Integer
t <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' GameState Integer
ticks
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Integer -> Value
VInt Integer
t) Store
s Cont
k
Const
Drill -> case [Value]
vs of
[VDir Direction
d] -> do
Text
rname <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot Text
robotName
Inventory
inv <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot Inventory
robotInventory
Inventory
ins <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot Inventory
installedDevices
let toyDrill :: [Entity]
toyDrill = Text -> Inventory -> [Entity]
lookupByName Text
"drill" Inventory
ins
metalDrill :: [Entity]
metalDrill = Text -> Inventory -> [Entity]
lookupByName Text
"metal drill" Inventory
ins
insDrill :: Maybe Entity
insDrill = forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ [Entity]
metalDrill forall a. Semigroup a => a -> a -> a
<> [Entity]
toyDrill
Entity
drill <- Maybe Entity
insDrill forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
Maybe a -> e -> m a
`isJustOr` Text -> Exn
Fatal Text
"Drill is required but not installed?!"
let directionText :: Text
directionText = case Direction
d of
Direction
DDown -> Text
"under"
Direction
DForward -> Text
"ahead of"
Direction
DBack -> Text
"behind"
Direction
_ -> DirInfo -> Text
dirSyntax (Direction -> DirInfo
dirInfo Direction
d) forall a. Semigroup a => a -> a -> a
<> Text
" of"
(V2 Int64
nextLoc, Maybe Entity
nextME) <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Direction -> m (V2 Int64, Maybe Entity)
lookInDirection Direction
d
Entity
nextE <-
Maybe Entity
nextME
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Maybe a -> [Text] -> m a
`isJustOrFail` [Text
"There is nothing to drill", Text
directionText, Text
"robot", Text
rname forall a. Semigroup a => a -> a -> a
<> Text
"."]
IntMap [Recipe Entity]
inRs <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' GameState (IntMap [Recipe Entity])
recipesIn
let recipes :: [Recipe Entity]
recipes = forall a. (a -> Bool) -> [a] -> [a]
filter Recipe Entity -> Bool
drilling (IntMap [Recipe Entity] -> Entity -> [Recipe Entity]
recipesFor IntMap [Recipe Entity]
inRs Entity
nextE)
drilling :: Recipe Entity -> Bool
drilling = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((forall a. Eq a => a -> a -> Bool
== Entity
drill) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Reader r) sig m =>
Getting a r a -> m a
view forall e. Lens' (Recipe e) (IngredientList e)
recipeRequirements
Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Recipe Entity]
recipes) forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Bool -> [Text] -> m ()
`holdsOrFail` [Text
"There is no way to drill", Text -> Text
indefinite (Entity
nextE forall s a. s -> Getting a s a -> a
^. Lens' Entity Text
entityName) forall a. Semigroup a => a -> a -> a
<> Text
"."]
let makeRecipe :: Recipe Entity
-> Either
[MissingIngredient] ((Inventory, [(RID, Entity)]), Recipe Entity)
makeRecipe Recipe Entity
r = (,Recipe Entity
r) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Inventory, Inventory)
-> Recipe Entity
-> Either [MissingIngredient] (Inventory, [(RID, Entity)])
make' (Entity -> Inventory -> Inventory
insert Entity
nextE Inventory
inv, Inventory
ins) Recipe Entity
r
Maybe ((Inventory, [(RID, Entity)]), Recipe Entity)
chosenRecipe <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (State GameState) sig m =>
(a -> Integer) -> [a] -> m (Maybe a)
weightedChoice (\((Inventory
_, [(RID, Entity)]
_), Recipe Entity
r) -> Recipe Entity
r forall s a. s -> Getting a s a -> a
^. forall e. Lens' (Recipe e) Integer
recipeWeight) (forall a b. [Either a b] -> [b]
rights (forall a b. (a -> b) -> [a] -> [b]
map Recipe Entity
-> Either
[MissingIngredient] ((Inventory, [(RID, Entity)]), Recipe Entity)
makeRecipe [Recipe Entity]
recipes))
((Inventory
invTaken, [(RID, Entity)]
outs), Recipe Entity
recipe) <-
Maybe ((Inventory, [(RID, Entity)]), Recipe Entity)
chosenRecipe
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Maybe a -> [Text] -> m a
`isJustOrFail` [Text
"You don't have the ingredients to drill", Text -> Text
indefinite (Entity
nextE forall s a. s -> Getting a s a -> a
^. Lens' Entity Text
entityName) forall a. Semigroup a => a -> a -> a
<> Text
"."]
let ([(RID, Entity)]
out, [(RID, Entity)]
down) = forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition ((Entity -> EntityProperty -> Bool
`hasProperty` EntityProperty
Portable) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(RID, Entity)]
outs
changeInv :: Inventory -> Inventory
changeInv =
forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry RID -> Entity -> Inventory -> Inventory
insertCount)) [(RID, Entity)]
out
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> a -> b
$ RID -> Entity -> Inventory -> Inventory
insertCount RID
0)) (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(RID, Entity)]
down)
changeWorld :: World RID Entity -> Either Exn (World RID Entity)
changeWorld = Entity
-> V2 Int64
-> [(RID, Entity)]
-> World RID Entity
-> Either Exn (World RID Entity)
changeWorld' Entity
nextE V2 Int64
nextLoc [(RID, Entity)]
down
Lens' Robot Inventory
robotInventory forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= Inventory
invTaken
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) e.
HasRobotStepState sig m =>
Recipe e -> WorldUpdate -> RobotUpdate -> m CESK
finishCookingRecipe Recipe Entity
recipe ((World RID Entity -> Either Exn (World RID Entity)) -> WorldUpdate
WorldUpdate World RID Entity -> Either Exn (World RID Entity)
changeWorld) ((Inventory -> Inventory) -> RobotUpdate
RobotUpdate Inventory -> Inventory
changeInv)
[Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
Const
Blocked -> do
V2 Int64
loc <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot (V2 Int64)
robotLocation
Maybe (V2 Int64)
orient <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot (Maybe (V2 Int64))
robotOrientation
let nextLoc :: V2 Int64
nextLoc = V2 Int64
loc forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^ (Maybe (V2 Int64)
orient forall a. Maybe a -> a -> a
? forall (f :: * -> *) a. (Additive f, Num a) => f a
zero)
Maybe Entity
me <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
V2 Int64 -> m (Maybe Entity)
entityAt V2 Int64
nextLoc
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Bool -> Value
VBool (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Entity -> EntityProperty -> Bool
`hasProperty` EntityProperty
Unwalkable) Maybe Entity
me)) Store
s Cont
k
Const
Scan -> case [Value]
vs of
[VDir Direction
d] -> do
(V2 Int64
_loc, Maybe Entity
me) <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Direction -> m (V2 Int64, Maybe Entity)
lookInDirection Direction
d
Value
res <- case Maybe Entity
me of
Maybe Entity
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool -> Value -> Value
VInj Bool
False Value
VUnit
Just Entity
e -> do
Lens' Robot Inventory
robotInventory forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= RID -> Entity -> Inventory -> Inventory
insertCount RID
0 Entity
e
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Entity -> m ()
updateDiscoveredEntities Entity
e
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool -> Value -> Value
VInj Bool
True (Text -> Value
VText (Entity
e forall s a. s -> Getting a s a -> a
^. Lens' Entity Text
entityName))
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
res Store
s Cont
k
[Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
Const
Knows -> case [Value]
vs of
[VText Text
name] -> do
Inventory
inv <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot Inventory
robotInventory
Inventory
ins <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot Inventory
installedDevices
let allKnown :: Inventory
allKnown = Inventory
inv Inventory -> Inventory -> Inventory
`E.union` Inventory
ins
let knows :: Bool
knows = case Text -> Inventory -> [Entity]
E.lookupByName Text
name Inventory
allKnown of
[] -> Bool
False
[Entity]
_ -> Bool
True
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Bool -> Value
VBool Bool
knows) Store
s Cont
k
[Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
Const
Upload -> case [Value]
vs of
[VRobot RID
otherID] -> do
Robot
_other <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
RID -> m Robot
getRobotWithinTouch RID
otherID
Inventory
inv <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot Inventory
robotInventory
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Inventory -> [(RID, Entity)]
elems Inventory
inv) forall a b. (a -> b) -> a -> b
$ \(RID
_, Entity
e) ->
Lens' GameState (IntMap Robot)
robotMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at RID
otherID forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Robot Inventory
robotInventory forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= RID -> Entity -> Inventory -> Inventory
insertCount RID
0 Entity
e
Seq LogEntry
rlog <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot (Seq LogEntry)
robotLog
Lens' GameState (IntMap Robot)
robotMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at RID
otherID forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Robot (Seq LogEntry)
robotLog forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(Has (State s) sig m, Semigroup a) =>
ASetter' s a -> a -> m ()
<>= Seq LogEntry
rlog
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s Cont
k
[Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
Const
Random -> case [Value]
vs of
[VInt Integer
hi] -> do
Integer
n <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(Has (State GameState) sig m, UniformRange a) =>
(a, a) -> m a
uniform (Integer
0, Integer
hi forall a. Num a => a -> a -> a
- Integer
1)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Integer -> Value
VInt Integer
n) Store
s Cont
k
[Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
Const
Atomic -> case [Value]
vs of
[Value
cmd] -> do
Lens' Robot Bool
runningAtomic forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= Bool
True
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
cmd Store
s (Frame
FExec forall a. a -> [a] -> [a]
: Frame
FFinishAtomic forall a. a -> [a] -> [a]
: Cont
k)
[Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
Const
As -> case [Value]
vs of
[VRobot RID
rid, Value
prog] -> do
Robot
r <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
RID -> m (Maybe Robot)
robotWithID RID
rid forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Maybe a -> [Text] -> m a
`isJustOrFail` [Text
"There is no robot with ID", forall source target. From source target => source -> target
from (forall a. Show a => a -> String
show RID
rid)])
GameState
g <- forall s (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
m s
get @GameState
Value
v <-
forall s (m :: * -> *) a. Functor m => s -> StateC s m a -> m a
evalState @Robot (Robot
r forall a b. a -> (a -> b) -> b
& Lens' Robot Bool
systemRobot forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
True) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. Functor m => s -> StateC s m a -> m a
evalState @GameState GameState
g forall a b. (a -> b) -> a -> b
$
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Lift IO) sig m, Has (Throw Exn) sig m,
Has (State GameState) sig m, Has (State Robot) sig m) =>
CESK -> m Value
runCESK (Value -> Store -> Cont -> CESK
Out Value
prog Store
s [Value -> Frame
FApp (Const -> [Value] -> Value
VCApp Const
Force []), Frame
FExec])
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
v Store
s Cont
k
[Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
Const
RobotNamed -> case [Value]
vs of
[VText Text
rname] -> do
Robot
r <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
Text -> m (Maybe Robot)
robotWithName Text
rname forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Maybe a -> [Text] -> m a
`isJustOrFail` [Text
"There is no robot named", Text
rname])
let robotValue :: Value
robotValue = RID -> Value
VRobot (Robot
r forall s a. s -> Getting a s a -> a
^. Getter Robot RID
robotID)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
robotValue Store
s Cont
k
[Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
Const
RobotNumbered -> case [Value]
vs of
[VInt Integer
rid] -> do
Robot
r <-
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
RID -> m (Maybe Robot)
robotWithID (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
rid)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Maybe a -> [Text] -> m a
`isJustOrFail` [Text
"There is no robot with number", forall source target. From source target => source -> target
from (forall a. Show a => a -> String
show Integer
rid)])
let robotValue :: Value
robotValue = RID -> Value
VRobot (Robot
r forall s a. s -> Getting a s a -> a
^. Getter Robot RID
robotID)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
robotValue Store
s Cont
k
[Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
Const
Say -> case [Value]
vs of
[VText Text
msg] -> do
Bool
creative <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' GameState Bool
creativeMode
Bool
system <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot Bool
systemRobot
V2 Int64
loc <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot (V2 Int64)
robotLocation
LogEntry
m <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m) =>
LogSource -> Text -> m LogEntry
traceLog LogSource
Said Text
msg
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
LogEntry -> m ()
emitMessage LogEntry
m
let addLatestClosest :: V2 Int64 -> Seq LogEntry -> Seq LogEntry
addLatestClosest V2 Int64
rl = \case
Seq LogEntry
Seq.Empty -> forall a. Seq a
Seq.Empty
Seq LogEntry
es Seq.:|> LogEntry
e
| LogEntry
e forall s a. s -> Getting a s a -> a
^. Lens' LogEntry Integer
leTime forall a. Ord a => a -> a -> Bool
< LogEntry
m forall s a. s -> Getting a s a -> a
^. Lens' LogEntry Integer
leTime -> Seq LogEntry
es forall s a. Snoc s s a a => s -> a -> s
|> LogEntry
e forall s a. Snoc s s a a => s -> a -> s
|> LogEntry
m
| V2 Int64 -> V2 Int64 -> Int64
manhattan V2 Int64
rl (LogEntry
e forall s a. s -> Getting a s a -> a
^. Lens' LogEntry (V2 Int64)
leLocation) forall a. Ord a => a -> a -> Bool
> V2 Int64 -> V2 Int64 -> Int64
manhattan V2 Int64
rl (LogEntry
m forall s a. s -> Getting a s a -> a
^. Lens' LogEntry (V2 Int64)
leLocation) -> Seq LogEntry
es forall s a. Snoc s s a a => s -> a -> s
|> LogEntry
m
| Bool
otherwise -> Seq LogEntry
es forall s a. Snoc s s a a => s -> a -> s
|> LogEntry
e
let addToRobotLog :: Has (State GameState) sgn m => Robot -> m ()
addToRobotLog :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
Robot -> m ()
addToRobotLog Robot
r = do
Robot
r' <- forall s (m :: * -> *) a. Functor m => s -> StateC s m a -> m s
execState Robot
r forall a b. (a -> b) -> a -> b
$ do
Bool
hasLog <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State Robot) sig m, Has (State GameState) sig m) =>
Capability -> m Bool
hasCapability Capability
CLog
Bool
hasListen <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State Robot) sig m, Has (State GameState) sig m) =>
Capability -> m Bool
hasCapability Capability
CListen
V2 Int64
loc' <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot (V2 Int64)
robotLocation
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
hasLog Bool -> Bool -> Bool
&& Bool
hasListen) (Lens' Robot (Seq LogEntry)
robotLog forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= V2 Int64 -> Seq LogEntry -> Seq LogEntry
addLatestClosest V2 Int64
loc')
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
Robot -> m ()
addRobot Robot
r'
[Robot]
robotsAround <-
if Bool
creative Bool -> Bool -> Bool
|| Bool
system
then forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use forall a b. (a -> b) -> a -> b
$ Lens' GameState (IntMap Robot)
robotMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to forall a. IntMap a -> [a]
IM.elems
else forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (State s) sig m =>
(s -> a) -> m a
gets forall a b. (a -> b) -> a -> b
$ V2 Int64 -> Int64 -> GameState -> [Robot]
robotsInArea V2 Int64
loc forall i. Num i => i
hearingDistance
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
Robot -> m ()
addToRobotLog [Robot]
robotsAround
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s Cont
k
[Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
Const
Listen -> do
GameState
gs <- forall s (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
m s
get @GameState
V2 Int64
loc <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot (V2 Int64)
robotLocation
Bool
creative <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' GameState Bool
creativeMode
Bool
system <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot Bool
systemRobot
Seq LogEntry
mq <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' GameState (Seq LogEntry)
messageQueue
let recentAndClose :: LogEntry -> Bool
recentAndClose LogEntry
e = Bool
system Bool -> Bool -> Bool
|| Bool
creative Bool -> Bool -> Bool
|| GameState -> LogEntry -> Bool
messageIsRecent GameState
gs LogEntry
e Bool -> Bool -> Bool
&& V2 Int64 -> LogEntry -> Bool
messageIsFromNearby V2 Int64
loc LogEntry
e
limitLast :: Seq LogEntry -> Maybe Text
limitLast = \case
Seq LogEntry
_s Seq.:|> LogEntry
l -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ LogEntry
l forall s a. s -> Getting a s a -> a
^. Lens' LogEntry Text
leText
Seq LogEntry
_ -> forall a. Maybe a
Nothing
mm :: Maybe Text
mm = Seq LogEntry -> Maybe Text
limitLast forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> Seq a -> Seq a
Seq.takeWhileR LogEntry -> Bool
recentAndClose Seq LogEntry
mq
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
(Term -> Env -> Store -> Cont -> CESK
In (Const -> Term
TConst Const
Listen) forall a. Monoid a => a
mempty Store
s (Frame
FExec forall a. a -> [a] -> [a]
: Cont
k))
(\Text
m -> Value -> Store -> Cont -> CESK
Out (Text -> Value
VText Text
m) Store
s Cont
k)
Maybe Text
mm
Const
Log -> case [Value]
vs of
[VText Text
msg] -> do
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State GameState) sig m, Has (State Robot) sig m) =>
LogSource -> Text -> m LogEntry
traceLog LogSource
Logged Text
msg
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s Cont
k
[Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
Const
View -> case [Value]
vs of
[VRobot RID
rid] -> do
Robot
_ <-
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
RID -> m (Maybe Robot)
robotWithID RID
rid
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Maybe a -> [Text] -> m a
`isJustOrFail` [Text
"There is no robot with ID", forall source target. From source target => source -> target
from (forall a. Show a => a -> String
show RID
rid), Text
"to view."])
RID
rn <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot RID
robotID
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RID
rn forall a. Eq a => a -> a -> Bool
== RID
0) forall a b. (a -> b) -> a -> b
$
Lens' GameState ViewCenterRule
viewCenterRule forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= RID -> ViewCenterRule
VCRobot RID
rid
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s Cont
k
[Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
Const
Appear -> case [Value]
vs of
[VText Text
app] -> do
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
m ()
flagRedraw
case forall target source. From source target => source -> target
into @String Text
app of
[Char
dc] -> do
Lens' Robot Display
robotDisplay forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Display Char
defaultChar forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= Char
dc
Lens' Robot Display
robotDisplay forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Display (Map Direction Char)
orientationMap forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= forall k a. Map k a
M.empty
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s Cont
k
[Char
dc, Char
nc, Char
ec, Char
sc, Char
wc] -> do
Lens' Robot Display
robotDisplay forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Display Char
defaultChar forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= Char
dc
Lens' Robot Display
robotDisplay forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Display (Map Direction Char)
orientationMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Direction
DNorth forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= Char
nc
Lens' Robot Display
robotDisplay forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Display (Map Direction Char)
orientationMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Direction
DEast forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= Char
ec
Lens' Robot Display
robotDisplay forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Display (Map Direction Char)
orientationMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Direction
DSouth forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= Char
sc
Lens' Robot Display
robotDisplay forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Display (Map Direction Char)
orientationMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Direction
DWest forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= Char
wc
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s Cont
k
String
_other -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Const -> [Text] -> m a
raise Const
Appear [Text -> Text
quote Text
app, Text
"is not a valid appearance string. 'appear' must be given a string with exactly 1 or 5 characters."]
[Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
Const
Create -> case [Value]
vs of
[VText Text
name] -> do
EntityMap
em <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' GameState EntityMap
entityMap
Entity
e <-
Text -> EntityMap -> Maybe Entity
lookupEntityName Text
name EntityMap
em
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Maybe a -> [Text] -> m a
`isJustOrFail` [Text
"I've never heard of", Text -> Text
indefiniteQ Text
name forall a. Semigroup a => a -> a -> a
<> Text
"."]
Lens' Robot Inventory
robotInventory forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= Entity -> Inventory -> Inventory
insert Entity
e
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Entity -> m ()
updateDiscoveredEntities Entity
e
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s Cont
k
[Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
Const
Ishere -> case [Value]
vs of
[VText Text
name] -> do
V2 Int64
loc <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot (V2 Int64)
robotLocation
Maybe Entity
me <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
V2 Int64 -> m (Maybe Entity)
entityAt V2 Int64
loc
case Maybe Entity
me of
Maybe Entity
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Bool -> Value
VBool Bool
False) Store
s Cont
k
Just Entity
e -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Bool -> Value
VBool (Text -> Text
T.toLower (Entity
e forall s a. s -> Getting a s a -> a
^. Lens' Entity Text
entityName) forall a. Eq a => a -> a -> Bool
== Text -> Text
T.toLower Text
name)) Store
s Cont
k
[Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
Const
Self -> do
RID
rid <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot RID
robotID
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (RID -> Value
VRobot RID
rid) Store
s Cont
k
Const
Parent -> do
Maybe RID
mp <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot (Maybe RID)
robotParentID
RID
rid <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot RID
robotID
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (RID -> Value
VRobot (forall a. a -> Maybe a -> a
fromMaybe RID
rid Maybe RID
mp)) Store
s Cont
k
Const
Base -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (RID -> Value
VRobot RID
0) Store
s Cont
k
Const
Whoami -> case [Value]
vs of
[] -> do
Text
name <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot Text
robotName
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Text -> Value
VText Text
name) Store
s Cont
k
[Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
Const
Setname -> case [Value]
vs of
[VText Text
name] -> do
Lens' Robot Text
robotName forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= Text
name
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s Cont
k
[Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
Const
Force -> case [Value]
vs of
[VDelay Term
t Env
e] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Term -> Env -> Store -> Cont -> CESK
In Term
t Env
e Store
s Cont
k
[VRef RID
loc] ->
case RID -> Store -> Maybe Cell
lookupCell RID
loc Store
s of
Maybe Cell
Nothing ->
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
Exn -> Store -> Cont -> CESK
Up (Text -> Exn
Fatal forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text
T.append Text
"Reference to unknown memory cell " (forall source target. From source target => source -> target
from (forall a. Show a => a -> String
show RID
loc))) Store
s Cont
k
Just (E Term
t Env
e') -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Term -> Env -> Store -> Cont -> CESK
In Term
t Env
e' (RID -> Cell -> Store -> Store
setCell RID
loc (Term -> Env -> Cell
Blackhole Term
t Env
e') Store
s) (RID -> Frame
FUpdate RID
loc forall a. a -> [a] -> [a]
: Cont
k)
Just Blackhole {} -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exn -> Store -> Cont -> CESK
Up Exn
InfiniteLoop Store
s Cont
k
Just (V Value
v) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
v Store
s Cont
k
[Value
v] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
v Store
s Cont
k
[Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
Const
If -> case [Value]
vs of
[VBool Bool
b, Value
thn, Value
els] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (forall a. a -> a -> Bool -> a
bool Value
els Value
thn Bool
b) Store
s (Value -> Frame
FApp (Const -> [Value] -> Value
VCApp Const
Force []) forall a. a -> [a] -> [a]
: Cont
k)
[Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
Const
Inl -> case [Value]
vs of
[Value
v] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Bool -> Value -> Value
VInj Bool
False Value
v) Store
s Cont
k
[Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
Const
Inr -> case [Value]
vs of
[Value
v] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Bool -> Value -> Value
VInj Bool
True Value
v) Store
s Cont
k
[Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
Const
Case -> case [Value]
vs of
[VInj Bool
side Value
v, Value
kl, Value
kr] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
v Store
s (Value -> Frame
FApp (forall a. a -> a -> Bool -> a
bool Value
kl Value
kr Bool
side) forall a. a -> [a] -> [a]
: Cont
k)
[Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
Const
Fst -> case [Value]
vs of
[VPair Value
v Value
_] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
v Store
s Cont
k
[Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
Const
Snd -> case [Value]
vs of
[VPair Value
_ Value
v] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
v Store
s Cont
k
[Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
Const
Try -> case [Value]
vs of
[Value
c1, Value
c2] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
c1 Store
s (Value -> Frame
FApp (Const -> [Value] -> Value
VCApp Const
Force []) forall a. a -> [a] -> [a]
: Frame
FExec forall a. a -> [a] -> [a]
: Value -> Frame
FTry Value
c2 forall a. a -> [a] -> [a]
: Cont
k)
[Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
Const
Undefined -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exn -> Store -> Cont -> CESK
Up (Text -> Exn
User Text
"undefined") Store
s Cont
k
Const
Fail -> case [Value]
vs of
[VText Text
msg] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exn -> Store -> Cont -> CESK
Up (Text -> Exn
User Text
msg) Store
s Cont
k
[Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
Const
Reprogram -> case [Value]
vs of
[VRobot RID
childRobotID, VDelay Term
cmd Env
e] -> do
Robot
r <- forall s (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
m s
get
Bool
creative <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' GameState Bool
creativeMode
Robot
childRobot <-
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
RID -> m (Maybe Robot)
robotWithID RID
childRobotID
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Maybe a -> [Text] -> m a
`isJustOrFail` [Text
"There is no robot with ID", forall source target. From source target => source -> target
from (forall a. Show a => a -> String
show RID
childRobotID) forall a. Semigroup a => a -> a -> a
<> Text
"."])
RID
myID <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot RID
robotID
(RID
childRobotID forall a. Eq a => a -> a -> Bool
/= RID
myID)
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Bool -> [Text] -> m ()
`holdsOrFail` [Text
"You cannot make a robot reprogram itself."]
(Value, Store)
_ <-
CESK -> Maybe (Value, Store)
finalValue (Robot
childRobot forall s a. s -> Getting a s a -> a
^. Lens' Robot CESK
machine)
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Maybe a -> [Text] -> m a
`isJustOrFail` [Text
"You cannot reprogram a robot that is actively running a program."]
V2 Int64
loc <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot (V2 Int64)
robotLocation
(Bool
creative Bool -> Bool -> Bool
|| (Robot
childRobot forall s a. s -> Getting a s a -> a
^. Getter Robot (V2 Int64)
robotLocation) V2 Int64 -> V2 Int64 -> Int64
`manhattan` V2 Int64
loc forall a. Ord a => a -> a -> Bool
<= Int64
1)
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Bool -> [Text] -> m ()
`holdsOrFail` [Text
"You can only reprogram an adjacent robot."]
(Set Entity
toInstall, Inventory
toGive) <-
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Inventory
-> Inventory
-> Inventory
-> Term
-> Text
-> IncapableFix
-> m (Set Entity, Inventory)
checkRequirements
(Robot
r forall s a. s -> Getting a s a -> a
^. Lens' Robot Inventory
robotInventory)
(Robot
childRobot forall s a. s -> Getting a s a -> a
^. Lens' Robot Inventory
robotInventory)
(Robot
childRobot forall s a. s -> Getting a s a -> a
^. Lens' Robot Inventory
installedDevices)
Term
cmd
Text
"The target robot"
IncapableFix
FixByObtain
Lens' GameState (IntMap Robot)
robotMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at RID
childRobotID forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Robot CESK
machine forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= Term -> Env -> Store -> Cont -> CESK
In Term
cmd Env
e Store
s [Frame
FExec]
Lens' GameState (IntMap Robot)
robotMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at RID
childRobotID forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Robot RobotContext
robotContext forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= Robot
r forall s a. s -> Getting a s a -> a
^. Lens' Robot RobotContext
robotContext
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
RID -> Inventory -> Inventory -> m ()
provisionChild RID
childRobotID ([Entity] -> Inventory
fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
S.toList forall a b. (a -> b) -> a -> b
$ Set Entity
toInstall) Inventory
toGive
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
RID -> m ()
activateRobot RID
childRobotID
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s Cont
k
[Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
Const
Build -> case [Value]
vs of
[VDelay Term
cmd Env
e] -> do
Robot
r <- forall s (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
m s
get @Robot
RID
pid <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot RID
robotID
(Set Entity
toInstall, Inventory
toGive) <-
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Inventory
-> Inventory
-> Inventory
-> Term
-> Text
-> IncapableFix
-> m (Set Entity, Inventory)
checkRequirements (Robot
r forall s a. s -> Getting a s a -> a
^. Lens' Robot Inventory
robotInventory) Inventory
E.empty Inventory
E.empty Term
cmd Text
"You" IncapableFix
FixByObtain
Text
displayName <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
m Text
randomName
TimeSpec
createdAt <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Lift IO) sig m =>
m TimeSpec
getNow
Robot
newRobot <-
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
TRobot -> m Robot
addTRobot forall a b. (a -> b) -> a -> b
$
forall (phase :: RobotPhase).
RobotID phase
-> Maybe RID
-> Text
-> [Text]
-> RobotLocation phase
-> V2 Int64
-> Display
-> CESK
-> [Entity]
-> [(RID, Entity)]
-> Bool
-> Bool
-> TimeSpec
-> RobotR phase
mkRobot
()
(forall a. a -> Maybe a
Just RID
pid)
Text
displayName
[Text
"A robot built by the robot named " forall a. Semigroup a => a -> a -> a
<> Robot
r forall s a. s -> Getting a s a -> a
^. Lens' Robot Text
robotName forall a. Semigroup a => a -> a -> a
<> Text
"."]
(forall a. a -> Maybe a
Just (Robot
r forall s a. s -> Getting a s a -> a
^. Getter Robot (V2 Int64)
robotLocation))
( ((Robot
r forall s a. s -> Getting a s a -> a
^. Lens' Robot (Maybe (V2 Int64))
robotOrientation) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \V2 Int64
dir -> forall (f :: * -> *). Alternative f => Bool -> f ()
guard (V2 Int64
dir forall a. Eq a => a -> a -> Bool
/= forall (f :: * -> *) a. (Additive f, Num a) => f a
zero) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return V2 Int64
dir)
forall a. Maybe a -> a -> a
? V2 Int64
east
)
Display
defaultRobotDisplay
(Term -> Env -> Store -> Cont -> CESK
In Term
cmd Env
e Store
s [Frame
FExec])
[]
[]
Bool
False
Bool
False
TimeSpec
createdAt
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
RID -> Inventory -> Inventory -> m ()
provisionChild (Robot
newRobot forall s a. s -> Getting a s a -> a
^. Getter Robot RID
robotID) ([Entity] -> Inventory
fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
S.toList forall a b. (a -> b) -> a -> b
$ Set Entity
toInstall) Inventory
toGive
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
m ()
flagRedraw
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (RID -> Value
VRobot (Robot
newRobot forall s a. s -> Getting a s a -> a
^. Getter Robot RID
robotID)) Store
s Cont
k
[Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
Const
Salvage -> case [Value]
vs of
[] -> do
V2 Int64
loc <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot (V2 Int64)
robotLocation
let okToSalvage :: Robot -> Bool
okToSalvage Robot
r = (Robot
r forall s a. s -> Getting a s a -> a
^. Getter Robot RID
robotID forall a. Eq a => a -> a -> Bool
/= RID
0) Bool -> Bool -> Bool
&& (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Robot -> Bool
isActive forall a b. (a -> b) -> a -> b
$ Robot
r)
Maybe Robot
mtarget <- forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (State s) sig m =>
(s -> a) -> m a
gets (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find Robot -> Bool
okToSalvage forall b c a. (b -> c) -> (a -> b) -> a -> c
. V2 Int64 -> GameState -> [Robot]
robotsAtLocation V2 Int64
loc)
case Maybe Robot
mtarget of
Maybe Robot
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s Cont
k
Just Robot
target -> do
let salvageInventory :: Inventory
salvageInventory = Inventory -> Inventory -> Inventory
E.union (Robot
target forall s a. s -> Getting a s a -> a
^. Lens' Robot Inventory
robotInventory) (Robot
target forall s a. s -> Getting a s a -> a
^. Lens' Robot Inventory
installedDevices)
Lens' GameState (IntMap Robot)
robotMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at (Robot
target forall s a. s -> Getting a s a -> a
^. Getter Robot RID
robotID) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Robot Inventory
robotInventory forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= Inventory
salvageInventory
let salvageItems :: [Text]
salvageItems = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(RID
n, Entity
e) -> forall a. RID -> a -> [a]
replicate RID
n (Entity
e forall s a. s -> Getting a s a -> a
^. Lens' Entity Text
entityName)) (Inventory -> [(RID, Entity)]
E.elems Inventory
salvageInventory)
numItems :: RID
numItems = forall (t :: * -> *) a. Foldable t => t a -> RID
length [Text]
salvageItems
Inventory
inst <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot Inventory
installedDevices
EntityMap
em <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' GameState EntityMap
entityMap
Bool
creative <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' GameState Bool
creativeMode
Entity
logger <-
Text -> EntityMap -> Maybe Entity
lookupEntityName Text
"logger" EntityMap
em
forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
Maybe a -> e -> m a
`isJustOr` Text -> Exn
Fatal Text
"While executing 'salvage': there's no such thing as a logger!?"
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
creative Bool -> Bool -> Bool
|| Inventory
inst Inventory -> Entity -> Bool
`E.contains` Entity
logger) forall a b. (a -> b) -> a -> b
$ Lens' Robot (Seq LogEntry)
robotLog forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(Has (State s) sig m, Semigroup a) =>
ASetter' s a -> a -> m ()
<>= Robot
target forall s a. s -> Getting a s a -> a
^. Lens' Robot (Seq LogEntry)
robotLog
let knownItems :: [Entity]
knownItems = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
== RID
0) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Inventory -> [(RID, Entity)]
elems forall a b. (a -> b) -> a -> b
$ Inventory
salvageInventory
Lens' Robot Inventory
robotInventory forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= \Inventory
i -> forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (RID -> Entity -> Inventory -> Inventory
insertCount RID
0) Inventory
i [Entity]
knownItems
Lens' GameState (IntMap Robot)
robotMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at (Robot
target forall s a. s -> Getting a s a -> a
^. Getter Robot RID
robotID) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Robot Bool
systemRobot forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= Bool
True
RID
ourID <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use @Robot Getter Robot RID
robotID
let giveInventory :: Term
giveInventory =
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Maybe Text -> Term -> Term -> Term
TBind forall a. Maybe a
Nothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Term
giveItem) (Const -> Term
TConst Const
Selfdestruct) [Text]
salvageItems
giveItem :: Text -> Term
giveItem Text
item = Term -> Term -> Term
TApp (Term -> Term -> Term
TApp (Const -> Term
TConst Const
Give) (RID -> Term
TRobot RID
ourID)) (Text -> Term
TText Text
item)
Lens' GameState (IntMap Robot)
robotMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at (Robot
target forall s a. s -> Getting a s a -> a
^. Getter Robot RID
robotID) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Robot CESK
machine
forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= Term -> Env -> Store -> Cont -> CESK
In Term
giveInventory forall t. Ctx t
empty Store
emptyStore [Frame
FExec]
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
RID -> m ()
activateRobot (Robot
target forall s a. s -> Getting a s a -> a
^. Getter Robot RID
robotID)
Integer
time <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' GameState Integer
ticks
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Integer -> CESK -> CESK
Waiting (Integer
time forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral RID
numItems forall a. Num a => a -> a -> a
+ Integer
1) (Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s Cont
k)
[Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
Const
Run -> case [Value]
vs of
[VText Text
fileName] -> do
[Maybe String]
mf <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Lift IO) sig m =>
IO a -> m a
sendIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO (Maybe String)
readFileMay [forall target source. From source target => source -> target
into Text
fileName, forall target source. From source target => source -> target
into forall a b. (a -> b) -> a -> b
$ Text
fileName forall a. Semigroup a => a -> a -> a
<> Text
".sw"]
String
f <- forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum [Maybe String]
mf forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Maybe a -> [Text] -> m a
`isJustOrFail` [Text
"File not found:", Text
fileName]
Maybe ProcessedTerm
mt <-
Text -> Either Text (Maybe ProcessedTerm)
processTerm (forall target source. From source target => source -> target
into @Text String
f) forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) b a.
Has (Throw e) sig m =>
Either b a -> (b -> e) -> m a
`isRightOr` \Text
err ->
Const -> [Text] -> Exn
cmdExn Const
Run [Text
"Error in", Text
fileName, Text
"\n", Text
err]
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Maybe ProcessedTerm
mt of
Maybe ProcessedTerm
Nothing -> Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s Cont
k
Just ProcessedTerm
t -> ProcessedTerm -> Env -> Store -> Cont -> CESK
initMachine' ProcessedTerm
t forall t. Ctx t
empty Store
s Cont
k
[Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
Const
Not -> case [Value]
vs of
[VBool Bool
b] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Bool -> Value
VBool (Bool -> Bool
not Bool
b)) Store
s Cont
k
[Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
Const
Neg -> case [Value]
vs of
[VInt Integer
n] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Integer -> Value
VInt (-Integer
n)) Store
s Cont
k
[Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
Const
Eq -> m CESK
returnEvalCmp
Const
Neq -> m CESK
returnEvalCmp
Const
Lt -> m CESK
returnEvalCmp
Const
Gt -> m CESK
returnEvalCmp
Const
Leq -> m CESK
returnEvalCmp
Const
Geq -> m CESK
returnEvalCmp
Const
And -> case [Value]
vs of
[VBool Bool
a, VBool Bool
b] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Bool -> Value
VBool (Bool
a Bool -> Bool -> Bool
&& Bool
b)) Store
s Cont
k
[Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
Const
Or -> case [Value]
vs of
[VBool Bool
a, VBool Bool
b] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Bool -> Value
VBool (Bool
a Bool -> Bool -> Bool
|| Bool
b)) Store
s Cont
k
[Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
Const
Add -> m CESK
returnEvalArith
Const
Sub -> m CESK
returnEvalArith
Const
Mul -> m CESK
returnEvalArith
Const
Div -> m CESK
returnEvalArith
Const
Exp -> m CESK
returnEvalArith
Const
Format -> case [Value]
vs of
[Value
v] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Text -> Value
VText (Value -> Text
prettyValue Value
v)) Store
s Cont
k
[Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
Const
Chars -> case [Value]
vs of
[VText Text
t] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Integer -> Value
VInt (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Text -> RID
T.length Text
t)) Store
s Cont
k
[Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
Const
Split -> case [Value]
vs of
[VInt Integer
i, VText Text
t] ->
let p :: (Text, Text)
p = RID -> Text -> (Text, Text)
T.splitAt (forall a. Num a => Integer -> a
fromInteger Integer
i) Text
t
t2 :: (Value, Value)
t2 = forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall (r :: * -> * -> *) a b.
Bitraversable r =>
Traversal (r a a) (r b b) a b
both Text -> Value
VText (Text, Text)
p
in forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Value -> Value -> Value
VPair (Value, Value)
t2) Store
s Cont
k
[Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
Const
Concat -> case [Value]
vs of
[VText Text
v1, VText Text
v2] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Text -> Value
VText (Text
v1 forall a. Semigroup a => a -> a -> a
<> Text
v2)) Store
s Cont
k
[Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
Const
AppF ->
let msg :: Text
msg = Text
"The operator '$' should only be a syntactic sugar and removed in elaboration:\n"
in forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Exn
Fatal forall a b. (a -> b) -> a -> b
$ Text
msg forall a. Semigroup a => a -> a -> a
<> Text
badConstMsg
where
badConst :: HasRobotStepState sig m => m a
badConst :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst = forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text -> Exn
Fatal Text
badConstMsg
badConstMsg :: Text
badConstMsg :: Text
badConstMsg =
[Text] -> Text
T.unlines
[ Text
"Bad application of execConst:"
, forall source target. From source target => source -> target
from (CESK -> String
prettyCESK (Value -> Store -> Cont -> CESK
Out (Const -> [Value] -> Value
VCApp Const
c (forall a. [a] -> [a]
reverse [Value]
vs)) Store
s Cont
k))
]
finishCookingRecipe :: HasRobotStepState sig m => Recipe e -> WorldUpdate -> RobotUpdate -> m CESK
finishCookingRecipe :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *) e.
HasRobotStepState sig m =>
Recipe e -> WorldUpdate -> RobotUpdate -> m CESK
finishCookingRecipe Recipe e
r WorldUpdate
wf RobotUpdate
rf = do
Integer
time <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' GameState Integer
ticks
let remTime :: Integer
remTime = Recipe e
r forall s a. s -> Getting a s a -> a
^. forall e. Lens' (Recipe e) Integer
recipeTime
forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Integer
remTime forall a. Ord a => a -> a -> Bool
<= Integer
1 then forall a. a -> a
id else Integer -> CESK -> CESK
Waiting (Integer
remTime forall a. Num a => a -> a -> a
+ Integer
time)) forall a b. (a -> b) -> a -> b
$
Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s (WorldUpdate -> RobotUpdate -> Frame
FImmediate WorldUpdate
wf RobotUpdate
rf forall a. a -> [a] -> [a]
: Cont
k)
lookInDirection :: HasRobotStepState sig m => Direction -> m (V2 Int64, Maybe Entity)
lookInDirection :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Direction -> m (V2 Int64, Maybe Entity)
lookInDirection Direction
d = do
V2 Int64
loc <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot (V2 Int64)
robotLocation
Maybe (V2 Int64)
orient <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot (Maybe (V2 Int64))
robotOrientation
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Direction -> Bool
isCardinal Direction
d) forall a b. (a -> b) -> a -> b
$ forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (State Robot) sig m, Has (State GameState) sig m,
Has (Throw Exn) sig m) =>
Capability -> Term -> m ()
hasCapabilityFor Capability
COrient (Direction -> Term
TDir Direction
d)
let nextLoc :: V2 Int64
nextLoc = V2 Int64
loc forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^ Direction -> V2 Int64 -> V2 Int64
applyTurn Direction
d (Maybe (V2 Int64)
orient forall a. Maybe a -> a -> a
? forall (f :: * -> *) a. (Additive f, Num a) => f a
zero)
(V2 Int64
nextLoc,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
V2 Int64 -> m (Maybe Entity)
entityAt V2 Int64
nextLoc
ensureItem :: HasRobotStepState sig m => Text -> Text -> m Entity
ensureItem :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Text -> Text -> m Entity
ensureItem Text
itemName Text
action = do
Inventory
inv <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot Inventory
robotInventory
Inventory
inst <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot Inventory
installedDevices
Entity
item <-
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum (forall a b. (a -> b) -> [a] -> [b]
map (forall a. [a] -> Maybe a
listToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Inventory -> [Entity]
lookupByName Text
itemName) [Inventory
inv, Inventory
inst])
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Maybe a -> [Text] -> m a
`isJustOrFail` [Text
"What is", Text -> Text
indefinite Text
itemName forall a. Semigroup a => a -> a -> a
<> Text
"?"]
Bool
creative <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' GameState Bool
creativeMode
let create :: [Text] -> [Text]
create [Text]
l = [Text]
l forall a. Semigroup a => a -> a -> a
<> [Text
"You can make one first with 'create \"" forall a. Semigroup a => a -> a -> a
<> Text
itemName forall a. Semigroup a => a -> a -> a
<> Text
"\"'." | Bool
creative]
(Entity -> Inventory -> RID
E.lookup Entity
item Inventory
inv forall a. Ord a => a -> a -> Bool
> RID
0)
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Bool -> [Text] -> m ()
`holdsOrFail` [Text] -> [Text]
create [Text
"You don't have", Text -> Text
indefinite Text
itemName, Text
"to", Text
action forall a. Semigroup a => a -> a -> a
<> Text
"."]
forall (m :: * -> *) a. Monad m => a -> m a
return Entity
item
checkRequirements ::
HasRobotStepState sig m =>
Inventory ->
Inventory ->
Inventory ->
Term ->
Text ->
IncapableFix ->
m (Set Entity, Inventory)
checkRequirements :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Inventory
-> Inventory
-> Inventory
-> Term
-> Text
-> IncapableFix
-> m (Set Entity, Inventory)
checkRequirements Inventory
parentInventory Inventory
childInventory Inventory
childDevices Term
cmd Text
subject IncapableFix
fixI = do
ReqCtx
currentContext <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use forall a b. (a -> b) -> a -> b
$ Lens' Robot RobotContext
robotContext forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' RobotContext ReqCtx
defReqs
EntityMap
em <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' GameState EntityMap
entityMap
Bool
creative <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' GameState Bool
creativeMode
let
(R.Requirements (forall a. Set a -> [a]
S.toList -> [Capability]
caps) (forall a. Set a -> [a]
S.toList -> [Text]
devNames) Map Text RID
reqInvNames, ReqCtx
_capCtx) = ReqCtx -> Term -> (Requirements, ReqCtx)
R.requirements ReqCtx
currentContext Term
cmd
[Entity]
devs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Text]
devNames forall a b. (a -> b) -> a -> b
$ \Text
devName ->
Text -> EntityMap -> Maybe Entity
E.lookupEntityName Text
devName EntityMap
em forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Maybe a -> [Text] -> m a
`isJustOrFail` [Text
"Unknown device required: " forall a. Semigroup a => a -> a -> a
<> Text
devName]
[(RID, Entity)]
reqElems <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall k a. Map k a -> [(k, a)]
M.assocs Map Text RID
reqInvNames) forall a b. (a -> b) -> a -> b
$ \(Text
eName, RID
n) ->
(RID
n,)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ( Text -> EntityMap -> Maybe Entity
E.lookupEntityName Text
eName EntityMap
em
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Maybe a -> [Text] -> m a
`isJustOrFail` [Text
"Unknown entity required: " forall a. Semigroup a => a -> a -> a
<> Text
eName]
)
let reqInv :: Inventory
reqInv = [(RID, Entity)] -> Inventory
E.fromElems [(RID, Entity)]
reqElems
let
capDevices :: [[Entity]]
capDevices = forall a b. (a -> b) -> [a] -> [b]
map (Capability -> EntityMap -> [Entity]
`deviceForCap` EntityMap
em) [Capability]
caps forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (forall a. a -> [a] -> [a]
: []) [Entity]
devs
deviceOK :: Entity -> Bool
deviceOK Entity
d = Inventory
parentInventory Inventory -> Entity -> Bool
`E.contains` Entity
d Bool -> Bool -> Bool
|| Inventory
childDevices Inventory -> Entity -> Bool
`E.contains` Entity
d
ignoreOK :: ([a], [a]) -> ([a], [a])
ignoreOK ([], [a]
miss) = ([], [a]
miss)
ignoreOK ([a]
ds, [a]
_miss) = ([a]
ds, [])
([Set Entity]
deviceSets, [Set Entity]
missingDeviceSets) =
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
Lens.over forall (r :: * -> * -> *) a b.
Bitraversable r =>
Traversal (r a a) (r b b) a b
both (forall a. Ord a => [a] -> [a]
nubOrd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Ord a => [a] -> Set a
S.fromList) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> [a] -> [b]
map (forall {a} {a}. ([a], [a]) -> ([a], [a])
ignoreOK forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition Entity -> Bool
deviceOK) [[Entity]]
capDevices
formatDevices :: Set Entity -> Text
formatDevices = Text -> [Text] -> Text
T.intercalate Text
" or " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall s a. s -> Getting a s a -> a
^. Lens' Entity Text
entityName) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
S.toList
missingCaps :: Set Capability
missingCaps = forall a. Ord a => [a] -> Set a
S.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Capability]
caps [Set Entity]
deviceSets
alreadyInstalled :: Set Entity
alreadyInstalled = forall a. Ord a => [a] -> Set a
S.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. Inventory -> [(RID, Entity)]
E.elems forall a b. (a -> b) -> a -> b
$ Inventory
childDevices
missingChildInv :: Inventory
missingChildInv = Inventory
reqInv Inventory -> Inventory -> Inventory
`E.difference` Inventory
childInventory
if Bool
creative
then
forall (m :: * -> *) a. Monad m => a -> m a
return (forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions (forall a b. (a -> b) -> [a] -> [b]
map forall a. Ord a => [a] -> Set a
S.fromList [[Entity]]
capDevices) forall a. Ord a => Set a -> Set a -> Set a
`S.difference` Set Entity
alreadyInstalled, Inventory
missingChildInv)
else do
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Set Entity]
missingDeviceSets
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Bool -> [Text] -> m ()
`holdsOrFail` ( Text -> Text -> Text
singularSubjectVerb Text
subject Text
"do" forall a. a -> [a] -> [a]
:
Text
"not have required devices, please" forall a. a -> [a] -> [a]
:
IncapableFix -> Text
formatIncapableFix IncapableFix
fixI forall a. Semigroup a => a -> a -> a
<> Text
":" forall a. a -> [a] -> [a]
:
((Text
"\n - " forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Entity -> Text
formatDevices forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [Set Entity]
missingDeviceSets)
)
Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Set Entity]
deviceSets) forall e (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw e) sig m =>
Bool -> e -> m ()
`holdsOr` IncapableFix -> Requirements -> Term -> Exn
Incapable IncapableFix
fixI (Set Capability -> Set Text -> Map Text RID -> Requirements
R.Requirements Set Capability
missingCaps forall a. Set a
S.empty forall k a. Map k a
M.empty) Term
cmd
let minimalInstallSet :: Set Entity
minimalInstallSet = forall a. Ord a => [Set a] -> Set a
smallHittingSet (forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Set a -> Bool
S.null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => Set a -> Set a -> Set a
S.intersection Set Entity
alreadyInstalled) [Set Entity]
deviceSets)
neededParentInv :: Inventory
neededParentInv =
Inventory
missingChildInv
Inventory -> Inventory -> Inventory
`E.union` ([Entity] -> Inventory
fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
S.toList forall a b. (a -> b) -> a -> b
$ Set Entity
minimalInstallSet)
missingParentInv :: Inventory
missingParentInv = Inventory
neededParentInv Inventory -> Inventory -> Inventory
`E.difference` Inventory
parentInventory
missingMap :: Map Text RID
missingMap =
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Ord a => a -> a -> Bool
> RID
0) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a, b) -> (b, a)
swap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall s a. s -> Getting a s a -> a
^. Lens' Entity Text
entityName))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Inventory -> [(RID, Entity)]
E.elems
forall a b. (a -> b) -> a -> b
$ Inventory
missingParentInv
Inventory -> Bool
E.isEmpty Inventory
missingParentInv
forall e (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw e) sig m =>
Bool -> e -> m ()
`holdsOr` IncapableFix -> Requirements -> Term -> Exn
Incapable IncapableFix
fixI (Set Capability -> Set Text -> Map Text RID -> Requirements
R.Requirements forall a. Set a
S.empty forall a. Set a
S.empty Map Text RID
missingMap) Term
cmd
forall (m :: * -> *) a. Monad m => a -> m a
return (Set Entity
minimalInstallSet, Inventory
missingChildInv)
changeWorld' ::
Entity ->
V2 Int64 ->
IngredientList Entity ->
W.World Int Entity ->
Either Exn (W.World Int Entity)
changeWorld' :: Entity
-> V2 Int64
-> [(RID, Entity)]
-> World RID Entity
-> Either Exn (World RID Entity)
changeWorld' Entity
eThen V2 Int64
loc [(RID, Entity)]
down World RID Entity
w =
let eNow :: Maybe Entity
eNow = forall t e. Coords -> World t e -> Maybe e
W.lookupEntity (V2 Int64 -> Coords
W.locToCoords V2 Int64
loc) World RID Entity
w
in if forall a. a -> Maybe a
Just Entity
eThen forall a. Eq a => a -> a -> Bool
/= Maybe Entity
eNow
then forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Const -> [Text] -> Exn
cmdExn Const
c [Text
"The", Entity
eThen forall s a. s -> Getting a s a -> a
^. Lens' Entity Text
entityName, Text
"is not there."]
else
World RID Entity
w forall {t} {e}. World t e -> V2 Int64 -> Maybe e -> World t e
`updateLoc` V2 Int64
loc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case [(RID, Entity)]
down of
[] -> forall a b. b -> Either a b
Right forall a. Maybe a
Nothing
[(RID, Entity)
de] -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd (RID, Entity)
de
[(RID, Entity)]
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> Exn
Fatal Text
"Bad recipe:\n more than one unmovable entity produced."
destroyIfNotBase :: HasRobotStepState sig m => m ()
destroyIfNotBase :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
m ()
destroyIfNotBase = do
RID
rid <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot RID
robotID
(RID
rid forall a. Eq a => a -> a -> Bool
/= RID
0) forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Bool -> [Text] -> m ()
`holdsOrFail` [Text
"You consider destroying your base, but decide not to do it after all."]
Lens' Robot Bool
selfDestruct forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= Bool
True
checkMoveAhead :: HasRobotStepState sig m => V2 Int64 -> MoveFailure -> m ()
checkMoveAhead :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
V2 Int64 -> MoveFailure -> m ()
checkMoveAhead V2 Int64
nextLoc MoveFailure {RobotFailure
failIfDrown :: RobotFailure
failIfBlocked :: RobotFailure
failIfDrown :: MoveFailure -> RobotFailure
failIfBlocked :: MoveFailure -> RobotFailure
..} = do
Maybe Entity
me <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
V2 Int64 -> m (Maybe Entity)
entityAt V2 Int64
nextLoc
Bool
systemRob <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot Bool
systemRobot
case Maybe Entity
me of
Maybe Entity
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Entity
e
| Bool
systemRob -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise -> do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Entity
e Entity -> EntityProperty -> Bool
`hasProperty` EntityProperty
Unwalkable) forall a b. (a -> b) -> a -> b
$
case RobotFailure
failIfBlocked of
RobotFailure
Destroy -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
m ()
destroyIfNotBase
RobotFailure
ThrowExn -> forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Const -> [Text] -> Exn
cmdExn Const
c [Text
"There is a", Entity
e forall s a. s -> Getting a s a -> a
^. Lens' Entity Text
entityName, Text
"in the way!"]
RobotFailure
IgnoreFail -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Set Capability
caps <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot (Set Capability)
robotCapabilities
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Entity
e Entity -> EntityProperty -> Bool
`hasProperty` EntityProperty
Liquid Bool -> Bool -> Bool
&& Capability
CFloat forall a. Ord a => a -> Set a -> Bool
`S.notMember` Set Capability
caps) forall a b. (a -> b) -> a -> b
$
case RobotFailure
failIfDrown of
RobotFailure
Destroy -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
m ()
destroyIfNotBase
RobotFailure
ThrowExn -> forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Const -> [Text] -> Exn
cmdExn Const
c [Text
"There is a dangerous liquid", Entity
e forall s a. s -> Getting a s a -> a
^. Lens' Entity Text
entityName, Text
"in the way!"]
RobotFailure
IgnoreFail -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
getRobotWithinTouch :: HasRobotStepState sig m => RID -> m Robot
getRobotWithinTouch :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
RID -> m Robot
getRobotWithinTouch RID
rid = do
RID
cid <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot RID
robotID
if RID
cid forall a. Eq a => a -> a -> Bool
== RID
rid
then forall s (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
m s
get @Robot
else do
Maybe Robot
mother <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
RID -> m (Maybe Robot)
robotWithID RID
rid
Robot
other <- Maybe Robot
mother forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Maybe a -> [Text] -> m a
`isJustOrFail` [Text
"There is no robot with ID", forall source target. From source target => source -> target
from (forall a. Show a => a -> String
show RID
rid) forall a. Semigroup a => a -> a -> a
<> Text
"."]
Bool
omni <- Bool -> Bool -> Bool
(||) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot Bool
systemRobot forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' GameState Bool
creativeMode
V2 Int64
loc <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot (V2 Int64)
robotLocation
(Bool
omni Bool -> Bool -> Bool
|| (Robot
other forall s a. s -> Getting a s a -> a
^. Getter Robot (V2 Int64)
robotLocation) V2 Int64 -> V2 Int64 -> Int64
`manhattan` V2 Int64
loc forall a. Ord a => a -> a -> Bool
<= Int64
1)
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Bool -> [Text] -> m ()
`holdsOrFail` [Text
"The robot with ID", forall source target. From source target => source -> target
from (forall a. Show a => a -> String
show RID
rid), Text
"is not close enough."]
forall (m :: * -> *) a. Monad m => a -> m a
return Robot
other
updateLoc :: World t e -> V2 Int64 -> Maybe e -> World t e
updateLoc World t e
w V2 Int64
loc Maybe e
res = forall e t.
Coords -> (Maybe e -> Maybe e) -> World t e -> World t e
W.update (V2 Int64 -> Coords
W.locToCoords V2 Int64
loc) (forall a b. a -> b -> a
const Maybe e
res) World t e
w
holdsOrFail :: (Has (Throw Exn) sig m) => Bool -> [Text] -> m ()
holdsOrFail :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Bool -> [Text] -> m ()
holdsOrFail Bool
a [Text]
ts = Bool
a forall e (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw e) sig m =>
Bool -> e -> m ()
`holdsOr` Const -> [Text] -> Exn
cmdExn Const
c [Text]
ts
isJustOrFail :: (Has (Throw Exn) sig m) => Maybe a -> [Text] -> m a
isJustOrFail :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Maybe a -> [Text] -> m a
isJustOrFail Maybe a
a [Text]
ts = Maybe a
a forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
Maybe a -> e -> m a
`isJustOr` Const -> [Text] -> Exn
cmdExn Const
c [Text]
ts
returnEvalCmp :: m CESK
returnEvalCmp = case [Value]
vs of
[Value
v1, Value
v2] -> (\Bool
b -> Value -> Store -> Cont -> CESK
Out (Bool -> Value
VBool Bool
b) Store
s Cont
k) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Const -> Value -> Value -> m Bool
evalCmp Const
c Value
v1 Value
v2
[Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
returnEvalArith :: m CESK
returnEvalArith = case [Value]
vs of
[VInt Integer
n1, VInt Integer
n2] -> (\Integer
r -> Value -> Store -> Cont -> CESK
Out (Integer -> Value
VInt Integer
r) Store
s Cont
k) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Const -> Integer -> Integer -> m Integer
evalArith Const
c Integer
n1 Integer
n2
[Value]
_ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
HasRobotStepState sig m =>
m a
badConst
hasInInventoryOrFail :: HasRobotStepState sig m => Text -> m Entity
hasInInventoryOrFail :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Text -> m Entity
hasInInventoryOrFail Text
eName = do
Inventory
inv <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot Inventory
robotInventory
Entity
e <-
forall a. [a] -> Maybe a
listToMaybe (Text -> Inventory -> [Entity]
lookupByName Text
eName Inventory
inv)
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Maybe a -> [Text] -> m a
`isJustOrFail` [Text
"What is", Text -> Text
indefinite Text
eName forall a. Semigroup a => a -> a -> a
<> Text
"?"]
let cmd :: Text
cmd = Text -> Text
T.toLower forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Const
c
(Entity -> Inventory -> RID
E.lookup Entity
e Inventory
inv forall a. Ord a => a -> a -> Bool
> RID
0)
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Bool -> [Text] -> m ()
`holdsOrFail` [Text
"You don't have", Text -> Text
indefinite Text
eName, Text
"to", Text
cmd forall a. Semigroup a => a -> a -> a
<> Text
"."]
forall (m :: * -> *) a. Monad m => a -> m a
return Entity
e
doGrab :: (HasRobotStepState sig m, Has (Lift IO) sig m) => GrabbingCmd -> m CESK
doGrab :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(HasRobotStepState sig m, Has (Lift IO) sig m) =>
GrabbingCmd -> m CESK
doGrab GrabbingCmd
cmd = do
let verb :: Text
verb = GrabbingCmd -> Text
verbGrabbingCmd GrabbingCmd
cmd
verbed :: Text
verbed = GrabbingCmd -> Text
verbedGrabbingCmd GrabbingCmd
cmd
V2 Int64
loc <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot (V2 Int64)
robotLocation
Entity
e <-
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
V2 Int64 -> m (Maybe Entity)
entityAt V2 Int64
loc
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Maybe a -> [Text] -> m a
`isJustOrFail` [Text
"There is nothing here to", Text
verb forall a. Semigroup a => a -> a -> a
<> Text
"."])
Bool
omni <- Bool -> Bool -> Bool
(||) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' Robot Bool
systemRobot forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' GameState Bool
creativeMode
(Bool
omni Bool -> Bool -> Bool
|| Entity
e Entity -> EntityProperty -> Bool
`hasProperty` EntityProperty
Portable)
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Bool -> [Text] -> m ()
`holdsOrFail` [Text
"The", Entity
e forall s a. s -> Getting a s a -> a
^. Lens' Entity Text
entityName, Text
"here can't be", Text
verbed forall a. Semigroup a => a -> a -> a
<> Text
"."]
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
V2 Int64 -> (Maybe Entity -> Maybe Entity) -> m ()
updateEntityAt V2 Int64
loc (forall a b. a -> b -> a
const forall a. Maybe a
Nothing)
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
m ()
flagRedraw
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Entity
e Entity -> EntityProperty -> Bool
`hasProperty` EntityProperty
Infinite) forall a b. (a -> b) -> a -> b
$
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
V2 Int64 -> (Maybe Entity -> Maybe Entity) -> m ()
updateEntityAt V2 Int64
loc (forall a b. a -> b -> a
const (forall a. a -> Maybe a
Just Entity
e))
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Entity
e Entity -> EntityProperty -> Bool
`hasProperty` EntityProperty
Growable) Bool -> Bool -> Bool
&& GrabbingCmd
cmd forall a. Eq a => a -> a -> Bool
== GrabbingCmd
Harvest') forall a b. (a -> b) -> a -> b
$ do
let GrowthTime (Integer
minT, Integer
maxT) = (Entity
e forall s a. s -> Getting a s a -> a
^. Lens' Entity (Maybe GrowthTime)
entityGrowth) forall a. Maybe a -> a -> a
? GrowthTime
defaultGrowthTime
TimeSpec
createdAt <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Lift IO) sig m =>
m TimeSpec
getNow
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
Entity -> (Integer, Integer) -> V2 Int64 -> TimeSpec -> m ()
addSeedBot Entity
e (Integer
minT, Integer
maxT) V2 Int64
loc TimeSpec
createdAt
let yieldName :: Maybe Text
yieldName = Entity
e forall s a. s -> Getting a s a -> a
^. Lens' Entity (Maybe Text)
entityYields
Entity
e' <- case Maybe Text
yieldName of
Maybe Text
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Entity
e
Just Text
n -> forall a. a -> Maybe a -> a
fromMaybe Entity
e forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s a b (f :: * -> *) (sig :: (* -> *) -> * -> *).
Has (State s) sig f =>
Getting a s a -> (a -> b) -> f b
uses Lens' GameState EntityMap
entityMap (Text -> EntityMap -> Maybe Entity
lookupEntityName Text
n)
Lens' Robot Inventory
robotInventory forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= Entity -> Inventory -> Inventory
insert Entity
e'
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Entity -> m ()
updateDiscoveredEntities Entity
e'
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Value -> Store -> Cont -> CESK
Out (Text -> Value
VText (Entity
e' forall s a. s -> Getting a s a -> a
^. Lens' Entity Text
entityName)) Store
s Cont
k
data RobotFailure = ThrowExn | Destroy | IgnoreFail
data MoveFailure = MoveFailure
{ MoveFailure -> RobotFailure
failIfBlocked :: RobotFailure
, MoveFailure -> RobotFailure
failIfDrown :: RobotFailure
}
data GrabbingCmd = Grab' | Harvest' | Swap' deriving (GrabbingCmd -> GrabbingCmd -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GrabbingCmd -> GrabbingCmd -> Bool
$c/= :: GrabbingCmd -> GrabbingCmd -> Bool
== :: GrabbingCmd -> GrabbingCmd -> Bool
$c== :: GrabbingCmd -> GrabbingCmd -> Bool
Eq, RID -> GrabbingCmd -> ShowS
[GrabbingCmd] -> ShowS
GrabbingCmd -> String
forall a.
(RID -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GrabbingCmd] -> ShowS
$cshowList :: [GrabbingCmd] -> ShowS
show :: GrabbingCmd -> String
$cshow :: GrabbingCmd -> String
showsPrec :: RID -> GrabbingCmd -> ShowS
$cshowsPrec :: RID -> GrabbingCmd -> ShowS
Show)
verbGrabbingCmd :: GrabbingCmd -> Text
verbGrabbingCmd :: GrabbingCmd -> Text
verbGrabbingCmd = \case
GrabbingCmd
Harvest' -> Text
"harvest"
GrabbingCmd
Grab' -> Text
"grab"
GrabbingCmd
Swap' -> Text
"swap"
verbedGrabbingCmd :: GrabbingCmd -> Text
verbedGrabbingCmd :: GrabbingCmd -> Text
verbedGrabbingCmd = \case
GrabbingCmd
Harvest' -> Text
"harvested"
GrabbingCmd
Grab' -> Text
"grabbed"
GrabbingCmd
Swap' -> Text
"swapped"
provisionChild ::
(HasRobotStepState sig m) =>
RID ->
Inventory ->
Inventory ->
m ()
provisionChild :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
RID -> Inventory -> Inventory -> m ()
provisionChild RID
childID Inventory
toInstall Inventory
toGive = do
Lens' GameState (IntMap Robot)
robotMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix RID
childID forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Robot Inventory
installedDevices forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= Inventory -> Inventory -> Inventory
E.union Inventory
toInstall
Lens' GameState (IntMap Robot)
robotMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix RID
childID forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Robot Inventory
robotInventory forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= Inventory -> Inventory -> Inventory
E.union Inventory
toGive
Bool
creative <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' GameState Bool
creativeMode
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
creative forall a b. (a -> b) -> a -> b
$
Lens' Robot Inventory
robotInventory forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= (Inventory -> Inventory -> Inventory
`E.difference` (Inventory
toInstall Inventory -> Inventory -> Inventory
`E.union` Inventory
toGive))
updateRobotLocation ::
(HasRobotStepState sig m) =>
V2 Int64 ->
V2 Int64 ->
m ()
updateRobotLocation :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
V2 Int64 -> V2 Int64 -> m ()
updateRobotLocation V2 Int64
oldLoc V2 Int64
newLoc
| V2 Int64
oldLoc forall a. Eq a => a -> a -> Bool
== V2 Int64
newLoc = forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = do
RID
rid <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot RID
robotID
Lens' GameState (Map (V2 Int64) IntSet)
robotsByLocation forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at V2 Int64
oldLoc forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= RID -> Maybe IntSet -> Maybe IntSet
deleteOne RID
rid
Lens' GameState (Map (V2 Int64) IntSet)
robotsByLocation forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at V2 Int64
newLoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => a -> Iso' (Maybe a) a
non forall s. AsEmpty s => s
Empty forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= RID -> IntSet -> IntSet
IS.insert RID
rid
forall s (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
(s -> s) -> m ()
modify (V2 Int64 -> Robot -> Robot
unsafeSetRobotLocation V2 Int64
newLoc)
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
m ()
flagRedraw
where
deleteOne :: RID -> Maybe IntSet -> Maybe IntSet
deleteOne RID
_ Maybe IntSet
Nothing = forall a. Maybe a
Nothing
deleteOne RID
x (Just IntSet
s)
| IntSet -> Bool
IS.null IntSet
s' = forall a. Maybe a
Nothing
| Bool
otherwise = forall a. a -> Maybe a
Just IntSet
s'
where
s' :: IntSet
s' = RID -> IntSet -> IntSet
IS.delete RID
x IntSet
s
onTarget ::
HasRobotStepState sig m =>
RID ->
(forall sig' m'. (HasRobotStepState sig' m') => m' ()) ->
m ()
onTarget :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
RID
-> (forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
m ())
-> m ()
onTarget RID
rid forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
m ()
act = do
RID
myID <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Getter Robot RID
robotID
case RID
myID forall a. Eq a => a -> a -> Bool
== RID
rid of
Bool
True -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
m ()
act
Bool
False -> do
Maybe Robot
mtgt <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use (Lens' GameState (IntMap Robot)
robotMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at RID
rid)
case Maybe Robot
mtgt of
Maybe Robot
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Robot
tgt -> do
Robot
tgt' <- forall s (m :: * -> *) a. Functor m => s -> StateC s m a -> m s
execState @Robot Robot
tgt forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
m ()
act
if Robot
tgt' forall s a. s -> Getting a s a -> a
^. Lens' Robot Bool
selfDestruct
then forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
RID -> m ()
deleteRobot RID
rid
else Lens' GameState (IntMap Robot)
robotMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix RID
rid forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= Robot
tgt'
evalCmp :: Has (Throw Exn) sig m => Const -> Value -> Value -> m Bool
evalCmp :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Const -> Value -> Value -> m Bool
evalCmp Const
c Value
v1 Value
v2 = Const -> m Ordering -> m Bool
decideCmp Const
c forall a b. (a -> b) -> a -> b
$ forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Value -> Value -> m Ordering
compareValues Value
v1 Value
v2
where
decideCmp :: Const -> m Ordering -> m Bool
decideCmp = \case
Const
Eq -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Eq a => a -> a -> Bool
== Ordering
EQ)
Const
Neq -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Eq a => a -> a -> Bool
/= Ordering
EQ)
Const
Lt -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Eq a => a -> a -> Bool
== Ordering
LT)
Const
Gt -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Eq a => a -> a -> Bool
== Ordering
GT)
Const
Leq -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Eq a => a -> a -> Bool
/= Ordering
GT)
Const
Geq -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Eq a => a -> a -> Bool
/= Ordering
LT)
Const
_ -> forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text -> Exn
Fatal forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text
T.append Text
"evalCmp called on bad constant " (forall source target. From source target => source -> target
from (forall a. Show a => a -> String
show Const
c))
compareValues :: Has (Throw Exn) sig m => Value -> Value -> m Ordering
compareValues :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Value -> Value -> m Ordering
compareValues Value
v1 = case Value
v1 of
Value
VUnit -> \case Value
VUnit -> forall (m :: * -> *) a. Monad m => a -> m a
return Ordering
EQ; Value
v2 -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Value -> Value -> m a
incompatCmp Value
VUnit Value
v2
VInt Integer
n1 -> \case VInt Integer
n2 -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Ord a => a -> a -> Ordering
compare Integer
n1 Integer
n2); Value
v2 -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Value -> Value -> m a
incompatCmp Value
v1 Value
v2
VText Text
t1 -> \case VText Text
t2 -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Ord a => a -> a -> Ordering
compare Text
t1 Text
t2); Value
v2 -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Value -> Value -> m a
incompatCmp Value
v1 Value
v2
VDir Direction
d1 -> \case VDir Direction
d2 -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Ord a => a -> a -> Ordering
compare Direction
d1 Direction
d2); Value
v2 -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Value -> Value -> m a
incompatCmp Value
v1 Value
v2
VBool Bool
b1 -> \case VBool Bool
b2 -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Ord a => a -> a -> Ordering
compare Bool
b1 Bool
b2); Value
v2 -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Value -> Value -> m a
incompatCmp Value
v1 Value
v2
VRobot RID
r1 -> \case VRobot RID
r2 -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Ord a => a -> a -> Ordering
compare RID
r1 RID
r2); Value
v2 -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Value -> Value -> m a
incompatCmp Value
v1 Value
v2
VInj Bool
s1 Value
v1' -> \case
VInj Bool
s2 Value
v2' ->
case forall a. Ord a => a -> a -> Ordering
compare Bool
s1 Bool
s2 of
Ordering
EQ -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Value -> Value -> m Ordering
compareValues Value
v1' Value
v2'
Ordering
o -> forall (m :: * -> *) a. Monad m => a -> m a
return Ordering
o
Value
v2 -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Value -> Value -> m a
incompatCmp Value
v1 Value
v2
VPair Value
v11 Value
v12 -> \case
VPair Value
v21 Value
v22 ->
forall a. Semigroup a => a -> a -> a
(<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Value -> Value -> m Ordering
compareValues Value
v11 Value
v21 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Value -> Value -> m Ordering
compareValues Value
v12 Value
v22
Value
v2 -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Value -> Value -> m a
incompatCmp Value
v1 Value
v2
VClo {} -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Value -> Value -> m a
incomparable Value
v1
VCApp {} -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Value -> Value -> m a
incomparable Value
v1
VDef {} -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Value -> Value -> m a
incomparable Value
v1
VResult {} -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Value -> Value -> m a
incomparable Value
v1
VBind {} -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Value -> Value -> m a
incomparable Value
v1
VDelay {} -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Value -> Value -> m a
incomparable Value
v1
VRef {} -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Value -> Value -> m a
incomparable Value
v1
incompatCmp :: Has (Throw Exn) sig m => Value -> Value -> m a
incompatCmp :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Value -> Value -> m a
incompatCmp Value
v1 Value
v2 =
forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError forall a b. (a -> b) -> a -> b
$
Text -> Exn
Fatal forall a b. (a -> b) -> a -> b
$
[Text] -> Text
T.unwords [Text
"Incompatible comparison of ", Value -> Text
prettyValue Value
v1, Text
"and", Value -> Text
prettyValue Value
v2]
incomparable :: Has (Throw Exn) sig m => Value -> Value -> m a
incomparable :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Value -> Value -> m a
incomparable Value
v1 Value
v2 =
forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError forall a b. (a -> b) -> a -> b
$
Const -> Text -> Exn
CmdFailed Const
Lt forall a b. (a -> b) -> a -> b
$
[Text] -> Text
T.unwords [Text
"Comparison is undefined for ", Value -> Text
prettyValue Value
v1, Text
"and", Value -> Text
prettyValue Value
v2]
evalArith :: Has (Throw Exn) sig m => Const -> Integer -> Integer -> m Integer
evalArith :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Const -> Integer -> Integer -> m Integer
evalArith = \case
Const
Add -> forall {m :: * -> *} {t} {t} {a}.
Monad m =>
(t -> t -> a) -> t -> t -> m a
ok forall a. Num a => a -> a -> a
(+)
Const
Sub -> forall {m :: * -> *} {t} {t} {a}.
Monad m =>
(t -> t -> a) -> t -> t -> m a
ok (-)
Const
Mul -> forall {m :: * -> *} {t} {t} {a}.
Monad m =>
(t -> t -> a) -> t -> t -> m a
ok forall a. Num a => a -> a -> a
(*)
Const
Div -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Integer -> Integer -> m Integer
safeDiv
Const
Exp -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Integer -> Integer -> m Integer
safeExp
Const
c -> \Integer
_ Integer
_ -> forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text -> Exn
Fatal forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text
T.append Text
"evalArith called on bad constant " (forall source target. From source target => source -> target
from (forall a. Show a => a -> String
show Const
c))
where
ok :: (t -> t -> a) -> t -> t -> m a
ok t -> t -> a
f t
x t
y = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ t -> t -> a
f t
x t
y
safeDiv :: Has (Throw Exn) sig m => Integer -> Integer -> m Integer
safeDiv :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Integer -> Integer -> m Integer
safeDiv Integer
_ Integer
0 = forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Const -> Text -> Exn
CmdFailed Const
Div Text
"Division by zero"
safeDiv Integer
a Integer
b = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Integer
a forall a. Integral a => a -> a -> a
`div` Integer
b
safeExp :: Has (Throw Exn) sig m => Integer -> Integer -> m Integer
safeExp :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Integer -> Integer -> m Integer
safeExp Integer
a Integer
b
| Integer
b forall a. Ord a => a -> a -> Bool
< Integer
0 = forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Const -> Text -> Exn
CmdFailed Const
Exp Text
"Negative exponent"
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Integer
a forall a b. (Num a, Integral b) => a -> b -> a
^ Integer
b
updateDiscoveredEntities :: (HasRobotStepState sig m) => Entity -> m ()
updateDiscoveredEntities :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Entity -> m ()
updateDiscoveredEntities Entity
e = do
Inventory
allDiscovered <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' GameState Inventory
allDiscoveredEntities
if Entity -> Inventory -> Bool
E.contains0plus Entity
e Inventory
allDiscovered
then forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
else do
let newAllDiscovered :: Inventory
newAllDiscovered = RID -> Entity -> Inventory -> Inventory
E.insertCount RID
1 Entity
e Inventory
allDiscovered
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
(Inventory, Inventory) -> Entity -> m ()
updateAvailableRecipes (Inventory
newAllDiscovered, Inventory
newAllDiscovered) Entity
e
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
Entity -> m ()
updateAvailableCommands Entity
e
Lens' GameState Inventory
allDiscoveredEntities forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> b -> m ()
.= Inventory
newAllDiscovered
updateAvailableRecipes :: Has (State GameState) sig m => (Inventory, Inventory) -> Entity -> m ()
updateAvailableRecipes :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
(Inventory, Inventory) -> Entity -> m ()
updateAvailableRecipes (Inventory, Inventory)
invs Entity
e = do
IntMap [Recipe Entity]
allInRecipes <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use Lens' GameState (IntMap [Recipe Entity])
recipesIn
let entityRecipes :: [Recipe Entity]
entityRecipes = IntMap [Recipe Entity] -> Entity -> [Recipe Entity]
recipesFor IntMap [Recipe Entity]
allInRecipes Entity
e
usableRecipes :: [Recipe Entity]
usableRecipes = forall a. (a -> Bool) -> [a] -> [a]
filter ((Inventory, Inventory) -> Recipe Entity -> Bool
knowsIngredientsFor (Inventory, Inventory)
invs) [Recipe Entity]
entityRecipes
[Recipe Entity]
knownRecipes <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use (Lens' GameState (Notifications (Recipe Entity))
availableRecipes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a1 a2. Lens (Notifications a1) (Notifications a2) [a1] [a2]
notificationsContent)
let newRecipes :: [Recipe Entity]
newRecipes = forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Recipe Entity]
knownRecipes) [Recipe Entity]
usableRecipes
newCount :: RID
newCount = forall (t :: * -> *) a. Foldable t => t a -> RID
length [Recipe Entity]
newRecipes
Lens' GameState (Notifications (Recipe Entity))
availableRecipes forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= forall a. Monoid a => a -> a -> a
mappend (forall a. RID -> [a] -> Notifications a
Notifications RID
newCount [Recipe Entity]
newRecipes)
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
Entity -> m ()
updateAvailableCommands Entity
e
updateAvailableCommands :: Has (State GameState) sig m => Entity -> m ()
updateAvailableCommands :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
Entity -> m ()
updateAvailableCommands Entity
e = do
let newCaps :: Set Capability
newCaps = forall a. Ord a => [a] -> Set a
S.fromList (Entity
e forall s a. s -> Getting a s a -> a
^. Lens' Entity [Capability]
entityCapabilities)
keepConsts :: Maybe Capability -> Bool
keepConsts = \case
Just Capability
cap -> Capability
cap forall a. Ord a => a -> Set a -> Bool
`S.member` Set Capability
newCaps
Maybe Capability
Nothing -> Bool
False
entityConsts :: [Const]
entityConsts = forall a. (a -> Bool) -> [a] -> [a]
filter (Maybe Capability -> Bool
keepConsts forall b c a. (b -> c) -> (a -> b) -> a -> c
. Const -> Maybe Capability
constCaps) [Const]
allConst
[Const]
knownCommands <- forall s a (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
Getting a s a -> m a
use (Lens' GameState (Notifications Const)
availableCommands forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a1 a2. Lens (Notifications a1) (Notifications a2) [a1] [a2]
notificationsContent)
let newCommands :: [Const]
newCommands = forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Const]
knownCommands) [Const]
entityConsts
newCount :: RID
newCount = forall (t :: * -> *) a. Foldable t => t a -> RID
length [Const]
newCommands
Lens' GameState (Notifications Const)
availableCommands forall s a b (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
ASetter s s a b -> (a -> b) -> m ()
%= forall a. Monoid a => a -> a -> a
mappend (forall a. RID -> [a] -> Notifications a
Notifications RID
newCount [Const]
newCommands)