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