{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
module Swarm.Game.Step.Combustion where
import Control.Applicative (Applicative (..))
import Control.Carrier.State.Lazy
import Control.Effect.Lens
import Control.Effect.Lift
import Control.Lens as Lens hiding (Const, distrib, from, parts, use, uses, view, (%=), (+=), (.=), (<+=), (<>=))
import Control.Monad (forM_, void, when)
import Data.Text qualified as T
import Linear (zero)
import Swarm.Game.CESK (emptyStore, initMachine)
import Swarm.Game.Display
import Swarm.Game.Entity hiding (empty, lookup, singleton, union)
import Swarm.Game.Entity qualified as E
import Swarm.Game.Location
import Swarm.Game.Robot
import Swarm.Game.State
import Swarm.Game.Step.Util
import Swarm.Game.Universe
import Swarm.Language.Context (empty)
import Swarm.Language.Pipeline (ProcessedTerm)
import Swarm.Language.Pipeline.QQ (tmQ)
import Swarm.Language.Syntax
import Swarm.Language.Text.Markdown qualified as Markdown
import Swarm.Util hiding (both)
import System.Clock (TimeSpec)
import Prelude hiding (Applicative (..), lookup)
igniteCommand :: (HasRobotStepState sig m, Has (Lift IO) sig m) => Const -> Direction -> m ()
igniteCommand :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(HasRobotStepState sig m, Has (Lift IO) sig m) =>
Const -> Direction -> m ()
igniteCommand Const
c Direction
d = do
(Cosmic Location
loc, Maybe Entity
me) <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
HasRobotStepState sig m =>
Direction -> m (Cosmic Location, Maybe Entity)
lookInDirection Direction
d
Entity
e <-
Maybe Entity
me forall {a}. Maybe a -> [Var] -> m a
`isJustOrFail` [Var
"There is nothing here to", Var
verb forall a. Semigroup a => a -> a -> a
<> Var
"."]
(Entity
e Entity -> EntityProperty -> Bool
`hasProperty` EntityProperty
Combustible)
Bool -> [Var] -> m ()
`holdsOrFail` [Var
"The", Entity
e forall s a. s -> Getting a s a -> a
^. Lens' Entity Var
entityName, Var
"here can't be", Var
verbed forall a. Semigroup a => a -> a -> a
<> Var
"."]
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
Cosmic Location -> (Maybe Entity -> Maybe Entity) -> m ()
updateEntityAt Cosmic Location
loc (forall a b. a -> b -> a
const forall a. Maybe a
Nothing)
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
m ()
flagRedraw
let selfCombustibility :: Combustibility
selfCombustibility = (Entity
e forall s a. s -> Getting a s a -> a
^. Lens' Entity (Maybe Combustibility)
entityCombustion) forall a. Maybe a -> a -> a
? Combustibility
defaultCombustibility
TimeSpec
createdAt <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Lift IO) sig m =>
m TimeSpec
getNow
Integer
combustionDurationRand <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
Entity
-> Combustibility -> TimeSpec -> Cosmic Location -> m Integer
addCombustionBot Entity
e Combustibility
selfCombustibility TimeSpec
createdAt Cosmic Location
loc
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Cosmic Location -> [Cosmic Location]
getNeighborLocs Cosmic Location
loc) forall a b. (a -> b) -> a -> b
$ forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
TimeSpec -> Integer -> Cosmic Location -> m ()
igniteNeighbor TimeSpec
createdAt Integer
combustionDurationRand
where
verb :: Var
verb = Var
"ignite"
verbed :: Var
verbed = Var
"ignited"
holdsOrFail :: Bool -> [Var] -> m ()
holdsOrFail = forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw Exn) sig m =>
Const -> Bool -> [Var] -> m ()
holdsOrFail' Const
c
isJustOrFail :: Maybe a -> [Var] -> m a
isJustOrFail = forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw Exn) sig m =>
Const -> Maybe a -> [Var] -> m a
isJustOrFail' Const
c
addCombustionBot ::
Has (State GameState) sig m =>
Entity ->
Combustibility ->
TimeSpec ->
Cosmic Location ->
m Integer
addCombustionBot :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
Entity
-> Combustibility -> TimeSpec -> Cosmic Location -> m Integer
addCombustionBot Entity
inputEntity Combustibility
combustibility TimeSpec
ts Cosmic Location
loc = do
[(Count, Entity)]
botInventory <- case Maybe Var
maybeCombustionProduct of
Maybe Var
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return []
Just Var
n -> do
Maybe Entity
maybeE <- forall s a b (f :: * -> *) (sig :: (* -> *) -> * -> *).
Has (State s) sig f =>
Getting a s a -> (a -> b) -> f b
uses (Lens' GameState Landscape
landscape forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Landscape EntityMap
entityMap) (Var -> EntityMap -> Maybe Entity
lookupEntityName Var
n)
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 [] (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Count
1,)) Maybe Entity
maybeE
Integer
combustionDurationRand <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(Has (State GameState) sig m, UniformRange a) =>
(a, a) -> m a
uniform (Integer, Integer)
durationRange
let combustionProg :: ProcessedTerm
combustionProg = Integer -> Combustibility -> ProcessedTerm
combustionProgram Integer
combustionDurationRand Combustibility
combustibility
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 Count
-> Var
-> Document Syntax
-> RobotLocation phase
-> Heading
-> Display
-> CESK
-> [Entity]
-> [(Count, Entity)]
-> Bool
-> Bool
-> Set Var
-> TimeSpec
-> RobotR phase
mkRobot
()
forall a. Maybe a
Nothing
Var
"fire"
(Var -> Document Syntax
Markdown.fromText forall a b. (a -> b) -> a -> b
$ [Var] -> Var
T.unwords [Var
"A burning", (Entity
inputEntity forall s a. s -> Getting a s a -> a
^. Lens' Entity Var
entityName) forall a. Semigroup a => a -> a -> a
<> Var
"."])
(forall a. a -> Maybe a
Just Cosmic Location
loc)
forall (f :: * -> *) a. (Additive f, Num a) => f a
zero
( Char -> Display
defaultEntityDisplay Char
'*'
forall a b. a -> (a -> b) -> b
& Lens' Display Attribute
displayAttr forall s t a b. ASetter s t a b -> b -> s -> t
.~ Var -> Attribute
AWorld Var
"fire"
forall a b. a -> (a -> b) -> b
& Lens' Display Count
displayPriority forall s t a b. ASetter s t a b -> b -> s -> t
.~ Count
0
)
(ProcessedTerm -> Env -> Store -> CESK
initMachine ProcessedTerm
combustionProg forall t. Ctx t
empty Store
emptyStore)
[]
[(Count, Entity)]
botInventory
Bool
True
Bool
False
forall a. Monoid a => a
mempty
TimeSpec
ts
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
combustionDurationRand
where
Combustibility Double
_ (Integer, Integer)
durationRange Maybe Var
maybeCombustionProduct = Combustibility
combustibility
ignitionProgram :: Integer -> ProcessedTerm
ignitionProgram :: Integer -> ProcessedTerm
ignitionProgram Integer
waitTime =
[tmQ|
wait $int:waitTime;
try {
ignite down;
noop;
} {};
selfdestruct
|]
combustionProgram :: Integer -> Combustibility -> ProcessedTerm
combustionProgram :: Integer -> Combustibility -> ProcessedTerm
combustionProgram Integer
combustionDuration (Combustibility Double
_ (Integer, Integer)
_ Maybe Var
maybeCombustionProduct) =
[tmQ|
wait $int:combustionDuration;
if ($int:invQuantity > 0) {
try {
place $str:combustionProduct;
} {};
} {};
selfdestruct
|]
where
(Integer
invQuantity, Var
combustionProduct) = case Maybe Var
maybeCombustionProduct of
Maybe Var
Nothing -> (Integer
0, Var
"")
Just Var
p -> (Integer
1, Var
p)
igniteNeighbor ::
Has (State GameState) sig m =>
TimeSpec ->
Integer ->
Cosmic Location ->
m ()
igniteNeighbor :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
TimeSpec -> Integer -> Cosmic Location -> m ()
igniteNeighbor TimeSpec
creationTime Integer
sourceDuration Cosmic Location
loc = do
Maybe Entity
maybeEnt <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
Cosmic Location -> m (Maybe Entity)
entityAt Cosmic Location
loc
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Entity
maybeEnt forall {sig :: (* -> *) -> * -> *} {f :: * -> *}.
(Algebra sig f, Member (State GameState) sig) =>
Entity -> f ()
igniteEntity
where
igniteEntity :: Entity -> f ()
igniteEntity Entity
e =
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Entity
e Entity -> EntityProperty -> Bool
`hasProperty` EntityProperty
Combustible) forall a b. (a -> b) -> a -> b
$ do
Double
threshold <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(Has (State GameState) sig m, UniformRange a) =>
(a, a) -> m a
uniform (Double
0, Double
1)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Double
probabilityOfIgnition forall a. Ord a => a -> a -> Bool
>= Double
threshold) forall a b. (a -> b) -> a -> b
$ do
Double
ignitionDelayRand <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(Has (State GameState) sig m, UniformRange a) =>
(a, a) -> m a
uniform (Double
0, Double
1)
let ignitionDelay :: Integer
ignitionDelay =
forall a b. (RealFrac a, Integral b) => a -> b
floor
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => a -> a -> a
min (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
sourceDuration)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a
negate
forall a b. (a -> b) -> a -> b
$ forall a. Floating a => a -> a
log Double
ignitionDelayRand forall a. Fractional a => a -> a -> a
/ Double
rate
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
Integer -> Entity -> TimeSpec -> Cosmic Location -> m ()
addIgnitionBot Integer
ignitionDelay Entity
e TimeSpec
creationTime Cosmic Location
loc
where
neighborCombustibility :: Combustibility
neighborCombustibility = (Entity
e forall s a. s -> Getting a s a -> a
^. Lens' Entity (Maybe Combustibility)
entityCombustion) forall a. Maybe a -> a -> a
? Combustibility
defaultCombustibility
rate :: Double
rate = Combustibility -> Double
E.ignition Combustibility
neighborCombustibility
probabilityOfIgnition :: Double
probabilityOfIgnition = Double
1 forall a. Num a => a -> a -> a
- forall a. Floating a => a -> a
exp (forall a. Num a => a -> a
negate forall a b. (a -> b) -> a -> b
$ Double
rate forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
sourceDuration)
addIgnitionBot ::
Has (State GameState) sig m =>
Integer ->
Entity ->
TimeSpec ->
Cosmic Location ->
m ()
addIgnitionBot :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State GameState) sig m =>
Integer -> Entity -> TimeSpec -> Cosmic Location -> m ()
addIgnitionBot Integer
ignitionDelay Entity
inputEntity TimeSpec
ts Cosmic Location
loc =
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 Count
-> Var
-> Document Syntax
-> RobotLocation phase
-> Heading
-> Display
-> CESK
-> [Entity]
-> [(Count, Entity)]
-> Bool
-> Bool
-> Set Var
-> TimeSpec
-> RobotR phase
mkRobot
()
forall a. Maybe a
Nothing
Var
"firestarter"
(Var -> Document Syntax
Markdown.fromText forall a b. (a -> b) -> a -> b
$ [Var] -> Var
T.unwords [Var
"Delayed ignition of", (Entity
inputEntity forall s a. s -> Getting a s a -> a
^. Lens' Entity Var
entityName) forall a. Semigroup a => a -> a -> a
<> Var
"."])
(forall a. a -> Maybe a
Just Cosmic Location
loc)
forall (f :: * -> *) a. (Additive f, Num a) => f a
zero
( Char -> Display
defaultEntityDisplay Char
'*'
forall a b. a -> (a -> b) -> b
& Lens' Display Bool
invisible forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
True
)
(ProcessedTerm -> Env -> Store -> CESK
initMachine (Integer -> ProcessedTerm
ignitionProgram Integer
ignitionDelay) forall t. Ctx t
empty Store
emptyStore)
[]
[]
Bool
True
Bool
False
forall a. Monoid a => a
mempty
TimeSpec
ts