mirror of
https://github.com/swarm-game/swarm.git
synced 2025-01-07 16:55:59 +03:00
combustion (#1432)
Closes #1355 # Demo scripts/play.sh -i data/scenarios/Testing/1355-combustion.yaml --autoplay 
This commit is contained in:
Karl Ostmo
GitHub
parent
0bed202e82
commit
da6ad0c874
@ -7,8 +7,21 @@
|
||||
A tall, living entity made of a tough cellular material called "wood".
|
||||
They regrow after being harvested and are an important raw ingredient used
|
||||
in making many different devices.
|
||||
properties: [portable, growable, opaque]
|
||||
properties: [portable, growable, opaque, combustible]
|
||||
growth: [500, 600]
|
||||
combustion:
|
||||
ignition: 0.01
|
||||
duration: [80, 120]
|
||||
product: ash
|
||||
|
||||
- name: ash
|
||||
display:
|
||||
attr: rock
|
||||
char: '#'
|
||||
description:
|
||||
- |
|
||||
Burned-out remnants of combustion.
|
||||
properties: [portable]
|
||||
|
||||
- name: branch
|
||||
display:
|
||||
@ -25,7 +38,11 @@
|
||||
char: 'l'
|
||||
description:
|
||||
- A wooden log, obtained by harvesting a tree and cutting off its branches.
|
||||
properties: [portable]
|
||||
properties: [portable, combustible]
|
||||
combustion:
|
||||
ignition: 0.05
|
||||
duration: [40, 80]
|
||||
product: ash
|
||||
|
||||
- name: board
|
||||
display:
|
||||
@ -33,7 +50,11 @@
|
||||
char: 'w'
|
||||
description:
|
||||
- A wooden board, made by cutting a log into pieces.
|
||||
properties: [portable]
|
||||
properties: [portable, combustible]
|
||||
combustion:
|
||||
ignition: 0.2
|
||||
duration: [20, 40]
|
||||
product: ash
|
||||
|
||||
- name: workbench
|
||||
display:
|
||||
@ -57,7 +78,11 @@
|
||||
description:
|
||||
- A flat material made of pressed and dried wood fibers,
|
||||
used as a surface on which to inscribe symbols.
|
||||
properties: [portable]
|
||||
properties: [portable, combustible]
|
||||
combustion:
|
||||
ignition: 0.5
|
||||
duration: [10, 20]
|
||||
product: ash
|
||||
|
||||
- name: PhD thesis
|
||||
display:
|
||||
@ -336,8 +361,12 @@
|
||||
- A plant with tufts of soft fibers that can be harvested and used
|
||||
to make things, including sheets of material that the local
|
||||
aliens like to drape over their bodies.
|
||||
properties: [portable, growable]
|
||||
properties: [portable, growable, combustible]
|
||||
growth: [100, 800]
|
||||
combustion:
|
||||
ignition: 0.1
|
||||
duration: [20, 40]
|
||||
product: ash
|
||||
|
||||
- name: linotype
|
||||
display:
|
||||
|
||||
@ -149,6 +149,7 @@ table.
|
||||
| `description` | | `string list` | A description of the entity, as a list of paragraphs. |
|
||||
| `orientation` | `null` | `int × int` | A 2-tuple of integers specifying an orientation vector for the entity. Currently unused. |
|
||||
| `growth` | `null` | `int × int` | For growable entities, a 2-tuple of integers specifying the minimum and maximum amount of time taken for one growth stage. The actual time for one growth stage will be chosen uniformly at random from this range; it takes two growth stages for an entity to be fully grown. |
|
||||
| `combustion` | | `object` | [Combustion](#combustion) information for the entity. |
|
||||
| `yields` | `null` | `string` | The name of the entity which will be added to a robot's inventory when it executes `grab` or `harvest` on this entity. If omitted, the entity will simply yield itself. |
|
||||
| `properties` | `[]` | `string list` | A list of properties of this entity. See [Entity properties](#entity-properties). |
|
||||
| `capabilities` | `[]` | `string list` | A list of capabilities provided by entity, when it is equipped as a device. See [Capabilities](#capabilities). |
|
||||
@ -182,6 +183,16 @@ capabilities here, which would be annoying to keep up-to-date, see the
|
||||
sheet](https://github.com/swarm-game/swarm/wiki/Commands-Cheat-Sheet)
|
||||
on the Swarm wiki.
|
||||
|
||||
### Combustion
|
||||
|
||||
The *combustion* property specifies whether and how an entity may combust, described by the following table.
|
||||
|
||||
| Key | Default? | Type | Description |
|
||||
|------------------|----------|-----------|--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------|
|
||||
| `ignition` | `0.5` | `number` | The rate of ignition by a neighbor, per tick. |
|
||||
| `duration` | `null` | `int × int` | For combustible entities, a 2-tuple of integers specifying the minimum and maximum amount of time taken for combustion. |
|
||||
| `product` | `ash` | `string` | What entity, if any, is left over after combustion |
|
||||
|
||||
### Display
|
||||
|
||||
A *display* specifies how an entity or a robot (robots are essentially
|
||||
|
||||
@ -40,5 +40,6 @@
|
||||
1320-world-DSL
|
||||
1356-portals
|
||||
144-subworlds
|
||||
1355-combustion.yaml
|
||||
1379-single-world-portal-reorientation.yaml
|
||||
1399-backup-command.yaml
|
||||
133
data/scenarios/Testing/1355-combustion.yaml
Normal file
133
data/scenarios/Testing/1355-combustion.yaml
Normal file
@ -0,0 +1,133 @@
|
||||
version: 1
|
||||
name: Combustion
|
||||
creative: false
|
||||
seed: 0
|
||||
description: Demo of spreading fire
|
||||
objectives:
|
||||
- goal:
|
||||
- Blow up the dynamite
|
||||
condition: |
|
||||
j <- robotnamed "judge";
|
||||
as j {
|
||||
ishere "crater";
|
||||
};
|
||||
solution: |
|
||||
def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end;
|
||||
|
||||
move;
|
||||
ignite forward;
|
||||
turn right;
|
||||
move;
|
||||
ignite forward;
|
||||
turn right;
|
||||
move; move; move;
|
||||
turn right;
|
||||
move;
|
||||
ignite left;
|
||||
move;
|
||||
turn right;
|
||||
doN 2 (move; ignite left);
|
||||
doN 14 move;
|
||||
turn left;
|
||||
doN 5 move;
|
||||
turn left;
|
||||
ignite right;
|
||||
doN 8 move;
|
||||
ignite right;
|
||||
doN 10 move;
|
||||
ignite right;
|
||||
doN 8 move;
|
||||
ignite right;
|
||||
robots:
|
||||
- name: base
|
||||
dir: [1, 0]
|
||||
devices:
|
||||
- branch predictor
|
||||
- calculator
|
||||
- dictionary
|
||||
- comparator
|
||||
- logger
|
||||
- treads
|
||||
- torch
|
||||
- name: judge
|
||||
dir: [1, 0]
|
||||
system: true
|
||||
display:
|
||||
invisible: true
|
||||
char: J
|
||||
entities:
|
||||
- name: torch
|
||||
display:
|
||||
attr: wood
|
||||
char: 't'
|
||||
description:
|
||||
- Can set things on fire
|
||||
properties: [known, portable]
|
||||
capabilities: [ignite]
|
||||
- name: fuse
|
||||
display:
|
||||
attr: wood
|
||||
char: '~'
|
||||
description:
|
||||
- Reliably combustible
|
||||
combustion:
|
||||
ignition: 1
|
||||
duration: [8, 8]
|
||||
product: null
|
||||
properties: [known, portable, combustible]
|
||||
- name: dynamite
|
||||
display:
|
||||
attr: red
|
||||
char: '!'
|
||||
description:
|
||||
- Explosive material
|
||||
combustion:
|
||||
ignition: 1
|
||||
duration: [2, 2]
|
||||
product: crater
|
||||
properties: [known, portable, combustible]
|
||||
- name: crater
|
||||
display:
|
||||
attr: rock
|
||||
char: '@'
|
||||
description:
|
||||
- Result of explosive excavation
|
||||
properties: [known]
|
||||
known: [ash, tree, log, board, paper, cotton]
|
||||
world:
|
||||
palette:
|
||||
'Ω': [grass, null, base]
|
||||
'T': [grass, tree]
|
||||
'q': [grass, paper]
|
||||
'l': [grass, log]
|
||||
'b': [grass, board]
|
||||
'i': [grass, cotton]
|
||||
'F': [grass, fuse]
|
||||
'd': [grass, dynamite, judge]
|
||||
'.': [grass]
|
||||
upperleft: [0, 0]
|
||||
map: |
|
||||
..iiii....bbbb..TT..llll....iiii.....
|
||||
..iiii....bbbb..TT..llll....iiii.....
|
||||
..iiii....bbbb..TT..llll....iiii.....
|
||||
..iiii....bbbb..TT..llll....iiii.....
|
||||
..iiii....bbbb..TT..llll....iiii.....
|
||||
..iiii....bbbb..TT..llll....iiii.....
|
||||
..TTTT....TTTT..TT..TTTT....TTTT.....
|
||||
..TTTT....TTTT..TT..TTTT....TTTT.....
|
||||
................TT...................
|
||||
................TT...................
|
||||
iiiiiiiiiii.....TT....FFFFF...FFFFF..
|
||||
......iiiiii....TT....F...F...F...F..
|
||||
iiiiiiiiiiiii...TT....F...F...F...F..
|
||||
......iiiiiiii........F...F...F...F..
|
||||
iiiiiiiiiiiiiii..Ω.FFFF...FFFFF...d..
|
||||
......iiiiiiii.......................
|
||||
iiiiiiiiiiiii.....qqqqqqqqqqqqqqqq...
|
||||
......iiiiii......qqqqqqqqqqqqqqqq...
|
||||
iiiiiiiiiii.......qqqqqqqqqqqqqqqq...
|
||||
..................qqqqqqqqqqqqqqqq...
|
||||
..................qqqqqqqqqqqqqqqq...
|
||||
..................qqqqqqqqqqqqqqqq...
|
||||
..................qqqqqqqqqqqqqqqq...
|
||||
..................qqqqqqqqqqqqqqqq...
|
||||
33
data/schema/combustion.json
Normal file
33
data/schema/combustion.json
Normal file
@ -0,0 +1,33 @@
|
||||
{
|
||||
"$schema": "http://json-schema.org/draft-07/schema#",
|
||||
"$id": "https://raw.githubusercontent.com/swarm-game/swarm/main/data/schema/combustion.json",
|
||||
"title": "Swarm entity combustion",
|
||||
"description": "Properties of combustion",
|
||||
"type": "object",
|
||||
"properties": {
|
||||
"ignition": {
|
||||
"default": 0.5,
|
||||
"type": "number",
|
||||
"description": "Rate of ignition by a neighbor, per tick."
|
||||
},
|
||||
"duration": {
|
||||
"type": "array",
|
||||
"items": [
|
||||
{
|
||||
"name": "minimum",
|
||||
"type": "number"
|
||||
},
|
||||
{
|
||||
"name": "maximum",
|
||||
"type": "number"
|
||||
}
|
||||
],
|
||||
"description": "For combustible entities, a 2-tuple of integers specifying the minimum and maximum amount of time that the combustion shall persist."
|
||||
},
|
||||
"product": {
|
||||
"default": "ash",
|
||||
"type": "string",
|
||||
"description": "What entity, if any, is left over after combustion"
|
||||
}
|
||||
}
|
||||
}
|
||||
@ -61,6 +61,11 @@
|
||||
],
|
||||
"description": "For growable entities, a 2-tuple of integers specifying the minimum and maximum amount of time taken for one growth stage. The actual time for one growth stage will be chosen uniformly at random from this range; it takes two growth stages for an entity to be fully grown."
|
||||
},
|
||||
"combustion": {
|
||||
"type": "object",
|
||||
"$ref": "https://raw.githubusercontent.com/swarm-game/swarm/main/data/schema/combustion.json",
|
||||
"description": "Properties of combustion."
|
||||
},
|
||||
"yields": {
|
||||
"default": "null",
|
||||
"type": "string",
|
||||
|
||||
@ -60,6 +60,7 @@
|
||||
"turn"
|
||||
"grab"
|
||||
"harvest"
|
||||
"ignite"
|
||||
"place"
|
||||
"give"
|
||||
"equip"
|
||||
|
||||
@ -58,7 +58,7 @@
|
||||
},
|
||||
{
|
||||
"name": "keyword.other",
|
||||
"match": "\\b(?i)(self|parent|base|if|inl|inr|case|fst|snd|force|undefined|fail|not|format|chars|split|charat|tochar|key|noop|wait|selfdestruct|move|backup|push|stride|turn|grab|harvest|place|give|equip|unequip|make|has|equipped|count|drill|use|build|salvage|reprogram|say|listen|log|view|appear|create|halt|time|scout|whereami|waypoint|detect|resonate|density|sniff|chirp|watch|surveil|heading|blocked|scan|upload|ishere|isempty|meet|meetall|whoami|setname|random|run|return|try|swap|atomic|instant|installkeyhandler|teleport|as|robotnamed|robotnumbered|knows)\\b"
|
||||
"match": "\\b(?i)(self|parent|base|if|inl|inr|case|fst|snd|force|undefined|fail|not|format|chars|split|charat|tochar|key|noop|wait|selfdestruct|move|backup|push|stride|turn|grab|harvest|ignite|place|give|equip|unequip|make|has|equipped|count|drill|use|build|salvage|reprogram|say|listen|log|view|appear|create|halt|time|scout|whereami|waypoint|detect|resonate|density|sniff|chirp|watch|surveil|heading|blocked|scan|upload|ishere|isempty|meet|meetall|whoami|setname|random|run|return|try|swap|atomic|instant|installkeyhandler|teleport|as|robotnamed|robotnumbered|knows)\\b"
|
||||
}
|
||||
]
|
||||
},
|
||||
|
||||
@ -13,10 +13,14 @@
|
||||
-- are mutually recursive (an inventory contains entities, which can
|
||||
-- have inventories).
|
||||
module Swarm.Game.Entity (
|
||||
EntityName,
|
||||
|
||||
-- * Properties
|
||||
EntityProperty (..),
|
||||
GrowthTime (..),
|
||||
defaultGrowthTime,
|
||||
Combustibility (..),
|
||||
defaultCombustibility,
|
||||
|
||||
-- * Entities
|
||||
Entity,
|
||||
@ -31,6 +35,7 @@ module Swarm.Game.Entity (
|
||||
entityDescription,
|
||||
entityOrientation,
|
||||
entityGrowth,
|
||||
entityCombustion,
|
||||
entityYields,
|
||||
entityProperties,
|
||||
hasProperty,
|
||||
@ -118,6 +123,8 @@ import Text.Read (readMaybe)
|
||||
import Witch
|
||||
import Prelude hiding (lookup)
|
||||
|
||||
type EntityName = Text
|
||||
|
||||
------------------------------------------------------------
|
||||
-- Properties
|
||||
------------------------------------------------------------
|
||||
@ -133,6 +140,8 @@ data EntityProperty
|
||||
Opaque
|
||||
| -- | Regrows from a seed after it is harvested.
|
||||
Growable
|
||||
| -- | Can use the Ignite command on it
|
||||
Combustible
|
||||
| -- | Regenerates infinitely when grabbed or harvested.
|
||||
Infinite
|
||||
| -- | Robots drown if they walk on this without a boat.
|
||||
@ -162,6 +171,24 @@ newtype GrowthTime = GrowthTime (Integer, Integer)
|
||||
defaultGrowthTime :: GrowthTime
|
||||
defaultGrowthTime = GrowthTime (100, 200)
|
||||
|
||||
-- | Properties of combustion
|
||||
data Combustibility = Combustibility
|
||||
{ ignition :: Double
|
||||
-- ^ Rate of ignition by a neighbor, per tick.
|
||||
-- When denoted as "lambda",
|
||||
-- probability of ignition over a period "t" is:
|
||||
-- 1 - e^(-(lambda * t))
|
||||
-- See: https://math.stackexchange.com/a/1243629
|
||||
, duration :: (Integer, Integer)
|
||||
-- ^ min and max tick counts for combustion to persist
|
||||
, product :: Maybe EntityName
|
||||
-- ^ what entity, if any, is left over after combustion
|
||||
}
|
||||
deriving (Eq, Ord, Show, Read, Generic, Hashable, FromJSON, ToJSON)
|
||||
|
||||
defaultCombustibility :: Combustibility
|
||||
defaultCombustibility = Combustibility 0.5 (100, 200) (Just "ash")
|
||||
|
||||
------------------------------------------------------------
|
||||
-- Entity
|
||||
------------------------------------------------------------
|
||||
@ -224,6 +251,8 @@ data Entity = Entity
|
||||
-- a robot moves, it moves in the direction of its orientation.
|
||||
, _entityGrowth :: Maybe GrowthTime
|
||||
-- ^ If this entity grows, how long does it take?
|
||||
, _entityCombustion :: Maybe Combustibility
|
||||
-- ^ If this entity is combustible, how spreadable is it?
|
||||
, _entityYields :: Maybe Text
|
||||
-- ^ The name of a different entity obtained when this entity is
|
||||
-- grabbed.
|
||||
@ -243,7 +272,7 @@ data Entity = Entity
|
||||
-- | The @Hashable@ instance for @Entity@ ignores the cached hash
|
||||
-- value and simply combines the other fields.
|
||||
instance Hashable Entity where
|
||||
hashWithSalt s (Entity _ disp nm pl descr orient grow yld props caps inv) =
|
||||
hashWithSalt s (Entity _ disp nm pl descr orient grow combust yld props caps inv) =
|
||||
s
|
||||
`hashWithSalt` disp
|
||||
`hashWithSalt` nm
|
||||
@ -251,6 +280,7 @@ instance Hashable Entity where
|
||||
`hashWithSalt` docToText descr
|
||||
`hashWithSalt` orient
|
||||
`hashWithSalt` grow
|
||||
`hashWithSalt` combust
|
||||
`hashWithSalt` yld
|
||||
`hashWithSalt` props
|
||||
`hashWithSalt` caps
|
||||
@ -284,7 +314,20 @@ mkEntity ::
|
||||
[Capability] ->
|
||||
Entity
|
||||
mkEntity disp nm descr props caps =
|
||||
rehashEntity $ Entity 0 disp nm Nothing descr Nothing Nothing Nothing (Set.fromList props) (Set.fromList caps) empty
|
||||
rehashEntity $
|
||||
Entity
|
||||
0
|
||||
disp
|
||||
nm
|
||||
Nothing
|
||||
descr
|
||||
Nothing
|
||||
Nothing
|
||||
Nothing
|
||||
Nothing
|
||||
(Set.fromList props)
|
||||
(Set.fromList caps)
|
||||
empty
|
||||
|
||||
------------------------------------------------------------
|
||||
-- Entity map
|
||||
@ -345,6 +388,7 @@ instance FromJSON Entity where
|
||||
<*> (v .: "description")
|
||||
<*> v .:? "orientation"
|
||||
<*> v .:? "growth"
|
||||
<*> v .:? "combustion"
|
||||
<*> v .:? "yields"
|
||||
<*> v .:? "properties" .!= mempty
|
||||
<*> v .:? "capabilities" .!= mempty
|
||||
@ -445,6 +489,10 @@ entityOrientation = hashedLens _entityOrientation (\e x -> e {_entityOrientation
|
||||
entityGrowth :: Lens' Entity (Maybe GrowthTime)
|
||||
entityGrowth = hashedLens _entityGrowth (\e x -> e {_entityGrowth = x})
|
||||
|
||||
-- | Susceptibility to and duration of combustion
|
||||
entityCombustion :: Lens' Entity (Maybe Combustibility)
|
||||
entityCombustion = hashedLens _entityCombustion (\e x -> e {_entityCombustion = x})
|
||||
|
||||
-- | The name of a different entity yielded when this entity is
|
||||
-- grabbed, if any.
|
||||
entityYields :: Lens' Entity (Maybe Text)
|
||||
|
||||
@ -9,19 +9,16 @@
|
||||
module Swarm.Game.Scenario.Topography.EntityFacade where
|
||||
|
||||
import Control.Lens ((^.))
|
||||
import Data.Text (Text)
|
||||
import Data.Yaml as Y (ToJSON (toJSON))
|
||||
import Swarm.Game.Display (Display)
|
||||
import Swarm.Game.Entity qualified as E
|
||||
|
||||
type EntityName = Text
|
||||
|
||||
-- | This datatype is a lightweight stand-in for the
|
||||
-- full-fledged "Entity" type without the baggage of all
|
||||
-- of its other fields.
|
||||
-- It contains the bare minimum display information
|
||||
-- for rendering.
|
||||
data EntityFacade = EntityFacade EntityName Display
|
||||
data EntityFacade = EntityFacade E.EntityName Display
|
||||
deriving (Eq)
|
||||
|
||||
-- Note: This instance is used only for the purpose of WorldPalette
|
||||
|
||||
@ -30,8 +30,7 @@ import Control.Effect.Error
|
||||
import Control.Effect.Lens
|
||||
import Control.Effect.Lift
|
||||
import Control.Lens as Lens hiding (Const, distrib, from, parts, use, uses, view, (%=), (+=), (.=), (<+=), (<>=))
|
||||
import Control.Monad (foldM, forM, forM_, guard, join, msum, unless, when, zipWithM)
|
||||
import Data.Array (bounds, (!))
|
||||
import Control.Monad (foldM, forM, forM_, guard, msum, unless, when, zipWithM)
|
||||
import Data.Bifunctor (second)
|
||||
import Data.Bool (bool)
|
||||
import Data.Char (chr, ord)
|
||||
@ -76,6 +75,8 @@ import Swarm.Game.Scenario.Objective.WinCheck qualified as WC
|
||||
import Swarm.Game.Scenario.Topography.Navigation.Portal (Navigation (..), destination, reorientation)
|
||||
import Swarm.Game.Scenario.Topography.Navigation.Waypoint (WaypointName (..))
|
||||
import Swarm.Game.State
|
||||
import Swarm.Game.Step.Combustion qualified as Combustion
|
||||
import Swarm.Game.Step.Util
|
||||
import Swarm.Game.Universe
|
||||
import Swarm.Game.Value
|
||||
import Swarm.Game.World qualified as W
|
||||
@ -94,8 +95,6 @@ import Swarm.Language.Value
|
||||
import Swarm.Util hiding (both)
|
||||
import Swarm.Util.Effect (throwToMaybe)
|
||||
import System.Clock (TimeSpec)
|
||||
import System.Clock qualified
|
||||
import System.Random (UniformRange, uniformR)
|
||||
import Witch (From (from), into)
|
||||
import Prelude hiding (Applicative (..), lookup)
|
||||
|
||||
@ -372,9 +371,6 @@ evalPT ::
|
||||
m Value
|
||||
evalPT t = evaluateCESK (initMachine t empty emptyStore)
|
||||
|
||||
getNow :: Has (Lift IO) sig m => m TimeSpec
|
||||
getNow = sendIO $ System.Clock.getTime System.Clock.Monotonic
|
||||
|
||||
-- | Create a special robot to check some hypothetical, for example the win condition.
|
||||
--
|
||||
-- Use ID (-1) so it won't conflict with any robots currently in the robot map.
|
||||
@ -417,91 +413,6 @@ runCESK cesk = case finalValue cesk of
|
||||
Just (v, _) -> return v
|
||||
Nothing -> stepCESK cesk >>= runCESK
|
||||
|
||||
------------------------------------------------------------
|
||||
-- Some utility functions
|
||||
------------------------------------------------------------
|
||||
|
||||
-- | Set a flag telling the UI that the world needs to be redrawn.
|
||||
flagRedraw :: (Has (State GameState) sig m) => m ()
|
||||
flagRedraw = needsRedraw .= True
|
||||
|
||||
-- | Perform an action requiring a 'W.World' state component in a
|
||||
-- larger context with a 'GameState'.
|
||||
zoomWorld ::
|
||||
(Has (State GameState) sig m) =>
|
||||
SubworldName ->
|
||||
StateC (W.World Int Entity) Identity b ->
|
||||
m (Maybe b)
|
||||
zoomWorld swName n = do
|
||||
mw <- use multiWorld
|
||||
forM (M.lookup swName mw) $ \w -> do
|
||||
let (w', a) = run (runState w n)
|
||||
multiWorld %= M.insert swName w'
|
||||
return a
|
||||
|
||||
-- | Get the entity (if any) at a given location.
|
||||
entityAt :: (Has (State GameState) sig m) => Cosmic Location -> m (Maybe Entity)
|
||||
entityAt (Cosmic subworldName loc) =
|
||||
join <$> zoomWorld subworldName (W.lookupEntityM @Int (W.locToCoords loc))
|
||||
|
||||
-- | Modify the entity (if any) at a given location.
|
||||
updateEntityAt ::
|
||||
(Has (State GameState) sig m) =>
|
||||
Cosmic Location ->
|
||||
(Maybe Entity -> Maybe Entity) ->
|
||||
m ()
|
||||
updateEntityAt cLoc@(Cosmic subworldName loc) upd = do
|
||||
didChange <-
|
||||
fmap (fromMaybe False) $
|
||||
zoomWorld subworldName $
|
||||
W.updateM @Int (W.locToCoords loc) upd
|
||||
when didChange $
|
||||
wakeWatchingRobots cLoc
|
||||
|
||||
-- | Get the robot with a given ID.
|
||||
robotWithID :: (Has (State GameState) sig m) => RID -> m (Maybe Robot)
|
||||
robotWithID rid = use (robotMap . at rid)
|
||||
|
||||
-- | Get the robot with a given name.
|
||||
robotWithName :: (Has (State GameState) sig m) => Text -> m (Maybe Robot)
|
||||
robotWithName rname = use (robotMap . to IM.elems . to (find $ \r -> r ^. robotName == rname))
|
||||
|
||||
-- | Generate a uniformly random number using the random generator in
|
||||
-- the game state.
|
||||
uniform :: (Has (State GameState) sig m, UniformRange a) => (a, a) -> m a
|
||||
uniform bnds = do
|
||||
rand <- use randGen
|
||||
let (n, g) = uniformR bnds rand
|
||||
randGen .= g
|
||||
return n
|
||||
|
||||
-- | Given a weighting function and a list of values, choose one of
|
||||
-- the values randomly (using the random generator in the game
|
||||
-- state), with the probability of each being proportional to its
|
||||
-- weight. Return @Nothing@ if the list is empty.
|
||||
weightedChoice :: Has (State GameState) sig m => (a -> Integer) -> [a] -> m (Maybe a)
|
||||
weightedChoice weight as = do
|
||||
r <- uniform (0, total - 1)
|
||||
return $ go r as
|
||||
where
|
||||
total = sum (map weight as)
|
||||
|
||||
go _ [] = Nothing
|
||||
go !k (x : xs)
|
||||
| k < w = Just x
|
||||
| otherwise = go (k - w) xs
|
||||
where
|
||||
w = weight x
|
||||
|
||||
-- | Generate a random robot name in the form adjective_name.
|
||||
randomName :: Has (State GameState) sig m => m Text
|
||||
randomName = do
|
||||
adjs <- use @GameState adjList
|
||||
names <- use @GameState nameList
|
||||
i <- uniform (bounds adjs)
|
||||
j <- uniform (bounds names)
|
||||
return $ T.concat [adjs ! i, "_", names ! j]
|
||||
|
||||
------------------------------------------------------------
|
||||
-- Debugging
|
||||
------------------------------------------------------------
|
||||
@ -565,27 +476,6 @@ ensureCanExecute c =
|
||||
(isPrivileged || hasCaps)
|
||||
`holdsOr` Incapable FixByEquip (R.singletonCap cap) (TConst c)
|
||||
|
||||
-- | Test whether the current robot has a given capability (either
|
||||
-- because it has a device which gives it that capability, or it is a
|
||||
-- system robot, or we are in creative mode).
|
||||
hasCapability :: (Has (State Robot) sig m, Has (State GameState) sig m) => Capability -> m Bool
|
||||
hasCapability cap = do
|
||||
isPrivileged <- isPrivilegedBot
|
||||
caps <- use robotCapabilities
|
||||
return (isPrivileged || cap `S.member` caps)
|
||||
|
||||
-- | Ensure that either a robot has a given capability, OR we are in creative
|
||||
-- mode.
|
||||
hasCapabilityFor ::
|
||||
(Has (State Robot) sig m, Has (State GameState) sig m, Has (Throw Exn) sig m) => Capability -> Term -> m ()
|
||||
hasCapabilityFor cap term = do
|
||||
h <- hasCapability cap
|
||||
h `holdsOr` Incapable FixByEquip (R.singletonCap cap) term
|
||||
|
||||
-- | Create an exception about a command failing.
|
||||
cmdExn :: Const -> [Text] -> Exn
|
||||
cmdExn c parts = CmdFailed c (T.unwords parts) Nothing
|
||||
|
||||
-- | Create an exception about a command failing, with an achievement
|
||||
cmdExnWithAchievement :: Const -> [Text] -> GameplayAchievement -> Exn
|
||||
cmdExnWithAchievement c parts a = CmdFailed c (T.unwords parts) $ Just a
|
||||
@ -1082,7 +972,7 @@ addSeedBot e (minT, maxT) loc ts =
|
||||
()
|
||||
Nothing
|
||||
"seed"
|
||||
"A growing seed."
|
||||
(Markdown.fromText $ T.unwords ["A growing", e ^. entityName, "seed."])
|
||||
(Just loc)
|
||||
zero
|
||||
( defaultEntityDisplay '.'
|
||||
@ -1096,12 +986,6 @@ addSeedBot e (minT, maxT) loc ts =
|
||||
False
|
||||
ts
|
||||
|
||||
-- | All functions that are used for robot step can access 'GameState' and the current 'Robot'.
|
||||
--
|
||||
-- They can also throw exception of our custom type, which is handled elsewhere.
|
||||
-- Because of that the constraint is only 'Throw', but not 'Catch'/'Error'.
|
||||
type HasRobotStepState sig m = (Has (State GameState) sig m, Has (State Robot) sig m, Has (Throw Exn) sig m)
|
||||
|
||||
-- | Interpret the execution (or evaluation) of a constant application
|
||||
-- to some values.
|
||||
execConst ::
|
||||
@ -1230,6 +1114,11 @@ execConst c vs s k = do
|
||||
_ -> badConst
|
||||
Grab -> doGrab Grab'
|
||||
Harvest -> doGrab Harvest'
|
||||
Ignite -> case vs of
|
||||
[VDir d] -> do
|
||||
Combustion.igniteCommand c d
|
||||
return $ Out VUnit s k
|
||||
_ -> badConst
|
||||
Swap -> case vs of
|
||||
[VText name] -> do
|
||||
loc <- use robotLocation
|
||||
@ -2280,19 +2169,6 @@ execConst c vs s k = do
|
||||
where
|
||||
remTime = r ^. recipeTime
|
||||
|
||||
deriveHeading :: HasRobotStepState sig m => Direction -> m Heading
|
||||
deriveHeading d = do
|
||||
orient <- use robotOrientation
|
||||
when (isCardinal d) $ hasCapabilityFor COrient $ TDir d
|
||||
return $ applyTurn d $ orient ? zero
|
||||
|
||||
lookInDirection :: HasRobotStepState sig m => Direction -> m (Cosmic Location, Maybe Entity)
|
||||
lookInDirection d = do
|
||||
newHeading <- deriveHeading d
|
||||
loc <- use robotLocation
|
||||
let nextLoc = loc `offsetBy` newHeading
|
||||
(nextLoc,) <$> entityAt nextLoc
|
||||
|
||||
ensureEquipped :: HasRobotStepState sig m => Text -> m Entity
|
||||
ensureEquipped itemName = do
|
||||
inst <- use equippedDevices
|
||||
@ -2547,7 +2423,7 @@ execConst c vs s k = do
|
||||
return other
|
||||
|
||||
holdsOrFail :: (Has (Throw Exn) sig m) => Bool -> [Text] -> m ()
|
||||
holdsOrFail a ts = a `holdsOr` cmdExn c ts
|
||||
holdsOrFail = holdsOrFail' c
|
||||
|
||||
holdsOrFailWithAchievement :: (Has (Throw Exn) sig m) => Bool -> [Text] -> Maybe GameplayAchievement -> m ()
|
||||
holdsOrFailWithAchievement a ts mAch = case mAch of
|
||||
@ -2555,7 +2431,7 @@ execConst c vs s k = do
|
||||
Just ach -> a `holdsOr` cmdExnWithAchievement c ts ach
|
||||
|
||||
isJustOrFail :: (Has (Throw Exn) sig m) => Maybe a -> [Text] -> m a
|
||||
isJustOrFail a ts = a `isJustOr` cmdExn c ts
|
||||
isJustOrFail = isJustOrFail' c
|
||||
|
||||
returnEvalCmp = case vs of
|
||||
[v1, v2] -> (\b -> Out (VBool b) s k) <$> evalCmp c v1 v2
|
||||
@ -2657,11 +2533,6 @@ purgeFarAwayWatches = do
|
||||
-- Some utility functions
|
||||
------------------------------------------------------------
|
||||
|
||||
-- | Exempts the robot from various command constraints
|
||||
-- when it is either a system robot or playing in creative mode
|
||||
isPrivilegedBot :: (Has (State GameState) sig m, Has (State Robot) sig m) => m Bool
|
||||
isPrivilegedBot = (||) <$> use systemRobot <*> use creativeMode
|
||||
|
||||
-- | Requires that the target location is within one cell.
|
||||
-- Requirement is waived if the bot is privileged.
|
||||
isNearbyOrExempt :: Bool -> Cosmic Location -> Cosmic Location -> Bool
|
||||
|
||||
227
src/Swarm/Game/Step/Combustion.hs
Normal file
227
src/Swarm/Game/Step/Combustion.hs
Normal file
@ -0,0 +1,227 @@
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
-- |
|
||||
-- SPDX-License-Identifier: BSD-3-Clause
|
||||
--
|
||||
-- Some entities are "combustible". A command, `ignite`, will
|
||||
-- initiate combustion on such an entity.
|
||||
-- Furthermore, combustion can spread to (4-)adjacent entities, depending
|
||||
-- on the 'ignition' property of that entity.
|
||||
--
|
||||
-- Short-lived robots are used to illustrate the combusting entity as
|
||||
-- well as to initiate the delayed combustion of its neighbors.
|
||||
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 c d = do
|
||||
(loc, me) <- lookInDirection d
|
||||
-- Ensure there is an entity here.
|
||||
e <-
|
||||
me `isJustOrFail` ["There is nothing here to", verb <> "."]
|
||||
|
||||
-- Ensure it can be ignited.
|
||||
(e `hasProperty` Combustible)
|
||||
`holdsOrFail` ["The", e ^. entityName, "here can't be", verbed <> "."]
|
||||
|
||||
-- Remove the entity from the world.
|
||||
updateEntityAt loc (const Nothing)
|
||||
flagRedraw
|
||||
|
||||
-- Start burning process
|
||||
let selfCombustibility = (e ^. entityCombustion) ? defaultCombustibility
|
||||
createdAt <- getNow
|
||||
combustionDurationRand <- addCombustionBot e selfCombustibility createdAt loc
|
||||
|
||||
let neighborLocs = map (offsetBy loc . flip applyTurn north . DRelative . DPlanar) listEnums
|
||||
forM_ neighborLocs $ igniteNeighbor createdAt combustionDurationRand
|
||||
where
|
||||
verb = "ignite"
|
||||
verbed = "ignited"
|
||||
|
||||
holdsOrFail = holdsOrFail' c
|
||||
isJustOrFail = isJustOrFail' c
|
||||
|
||||
-- | Construct a "combustion robot" from entity and position
|
||||
-- and add it to the world.
|
||||
-- It has low priority and will be covered
|
||||
-- by placed entities.
|
||||
-- The "combustion bot" represents the burning of a single
|
||||
-- entity; propagating the fire to neighbors is handled upstream,
|
||||
-- within the `ignite` command.
|
||||
addCombustionBot ::
|
||||
Has (State GameState) sig m =>
|
||||
Entity ->
|
||||
Combustibility ->
|
||||
TimeSpec ->
|
||||
Cosmic Location ->
|
||||
m Integer
|
||||
addCombustionBot inputEntity combustibility ts loc = do
|
||||
botInventory <- case maybeCombustionProduct of
|
||||
Nothing -> return []
|
||||
Just n -> do
|
||||
maybeE <- uses entityMap (lookupEntityName n)
|
||||
return $ maybe [] (pure . (1,)) maybeE
|
||||
combustionDurationRand <- uniform durationRange
|
||||
let combustionProg = combustionProgram combustionDurationRand combustibility
|
||||
void $
|
||||
addTRobot $
|
||||
mkRobot
|
||||
()
|
||||
Nothing
|
||||
"fire"
|
||||
(Markdown.fromText $ T.unwords ["A burning", (inputEntity ^. entityName) <> "."])
|
||||
(Just loc)
|
||||
zero
|
||||
( defaultEntityDisplay '*'
|
||||
& displayAttr .~ AWorld "fire"
|
||||
& displayPriority .~ 0
|
||||
)
|
||||
(initMachine combustionProg empty emptyStore)
|
||||
[]
|
||||
botInventory
|
||||
True
|
||||
False
|
||||
ts
|
||||
return combustionDurationRand
|
||||
where
|
||||
Combustibility _ durationRange maybeCombustionProduct = combustibility
|
||||
|
||||
-- Triggers the ignition of the entity underfoot with some delay.
|
||||
ignitionProgram :: Integer -> ProcessedTerm
|
||||
ignitionProgram waitTime =
|
||||
[tmQ|
|
||||
wait $int:waitTime;
|
||||
try {
|
||||
ignite down;
|
||||
noop;
|
||||
} {};
|
||||
selfdestruct
|
||||
|]
|
||||
|
||||
-- | A system program for a "combustion robot", to burn an entity
|
||||
-- after it is ignited.
|
||||
--
|
||||
-- For efficiency, we determine a priori (i.e. the instant
|
||||
-- the combustion robot is spawned) whether any neighbors will eventually
|
||||
-- be burned, based on probabilities.
|
||||
--
|
||||
-- Note that it is possible that new neighbors may be introduced while
|
||||
-- combustion is in progress. Although it may be more realistic to subject
|
||||
-- these to possible combustion as well, we do not bother.
|
||||
--
|
||||
-- Though if we did actually want to do that, some options are:
|
||||
--
|
||||
-- 1. Create sub-partitions (of say, 10-tick duration) of the combustion duration
|
||||
-- to re-evaluate opportunities to light adjacent entities on fire.
|
||||
-- 2. Use the `watch` command to observe for changes to adjacent entities.
|
||||
-- Note that if we "wake" from our `wait` due to the `watch` being triggered,
|
||||
-- we would need to maintain bookkeeping of how much time is left.
|
||||
-- 3. Spawn more robots whose sole purpose is to observe for changes to neighbor
|
||||
-- cells. This would avoid polluting the logic of the currently burning cell
|
||||
-- with logic to manage probabilities of combustion propagation.
|
||||
combustionProgram :: Integer -> Combustibility -> ProcessedTerm
|
||||
combustionProgram combustionDuration (Combustibility _ _ maybeCombustionProduct) =
|
||||
[tmQ|
|
||||
wait $int:combustionDuration;
|
||||
if ($int:invQuantity > 0) {
|
||||
try {
|
||||
place $str:combustionProduct;
|
||||
} {};
|
||||
} {};
|
||||
selfdestruct
|
||||
|]
|
||||
where
|
||||
(invQuantity, combustionProduct) = case maybeCombustionProduct of
|
||||
Nothing -> (0, "")
|
||||
Just p -> (1, p)
|
||||
|
||||
-- | We treat the 'ignition' field in the 'Combustion' record
|
||||
-- as a /rate/ in a Poisson distribution.
|
||||
-- Ignition of neighbors depends on that particular neighbor entity's
|
||||
-- combustion /rate/, but also on the duration
|
||||
-- that the current entity will burn.
|
||||
igniteNeighbor ::
|
||||
Has (State GameState) sig m =>
|
||||
TimeSpec ->
|
||||
Integer ->
|
||||
Cosmic Location ->
|
||||
m ()
|
||||
igniteNeighbor creationTime sourceDuration loc = do
|
||||
maybeEnt <- entityAt loc
|
||||
forM_ maybeEnt igniteEntity
|
||||
where
|
||||
igniteEntity e =
|
||||
when (e `hasProperty` Combustible) $ do
|
||||
threshold <- uniform (0, 1)
|
||||
when (probabilityOfIgnition >= threshold) $ do
|
||||
ignitionDelayRand <- uniform (0, 1)
|
||||
let ignitionDelay =
|
||||
floor
|
||||
. min (fromIntegral sourceDuration)
|
||||
. negate
|
||||
$ log ignitionDelayRand / rate
|
||||
addIgnitionBot ignitionDelay e creationTime loc
|
||||
where
|
||||
neighborCombustibility = (e ^. entityCombustion) ? defaultCombustibility
|
||||
rate = E.ignition neighborCombustibility
|
||||
probabilityOfIgnition = 1 - exp (negate $ rate * fromIntegral sourceDuration)
|
||||
|
||||
-- | Construct an invisible "ignition robot" and add it to the world.
|
||||
-- Its sole purpose is to delay the `ignite` command for a neighbor
|
||||
-- that has been a priori determined that it shall be ignited.
|
||||
addIgnitionBot ::
|
||||
Has (State GameState) sig m =>
|
||||
Integer ->
|
||||
Entity ->
|
||||
TimeSpec ->
|
||||
Cosmic Location ->
|
||||
m ()
|
||||
addIgnitionBot ignitionDelay inputEntity ts loc =
|
||||
void $
|
||||
addTRobot $
|
||||
mkRobot
|
||||
()
|
||||
Nothing
|
||||
"firestarter"
|
||||
(Markdown.fromText $ T.unwords ["Delayed ignition of", (inputEntity ^. entityName) <> "."])
|
||||
(Just loc)
|
||||
zero
|
||||
( defaultEntityDisplay '*'
|
||||
& invisible .~ True
|
||||
)
|
||||
(initMachine (ignitionProgram ignitionDelay) empty emptyStore)
|
||||
[]
|
||||
[]
|
||||
True
|
||||
False
|
||||
ts
|
||||
181
src/Swarm/Game/Step/Util.hs
Normal file
181
src/Swarm/Game/Step/Util.hs
Normal file
@ -0,0 +1,181 @@
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
-- |
|
||||
-- SPDX-License-Identifier: BSD-3-Clause
|
||||
module Swarm.Game.Step.Util where
|
||||
|
||||
import Control.Applicative (Applicative (..))
|
||||
import Control.Carrier.State.Lazy
|
||||
import Control.Effect.Error
|
||||
import Control.Effect.Lens
|
||||
import Control.Effect.Lift
|
||||
import Control.Lens as Lens hiding (Const, distrib, from, parts, use, uses, view, (%=), (+=), (.=), (<+=), (<>=))
|
||||
import Control.Monad (forM, join, when)
|
||||
import Data.Array (bounds, (!))
|
||||
import Data.IntMap qualified as IM
|
||||
import Data.List (find)
|
||||
import Data.Map qualified as M
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Set qualified as S
|
||||
import Data.Text (Text)
|
||||
import Data.Text qualified as T
|
||||
import Linear (zero)
|
||||
import Swarm.Game.Entity hiding (empty, lookup, singleton, union)
|
||||
import Swarm.Game.Exception
|
||||
import Swarm.Game.Location
|
||||
import Swarm.Game.Robot
|
||||
import Swarm.Game.State
|
||||
import Swarm.Game.Universe
|
||||
import Swarm.Game.World qualified as W
|
||||
import Swarm.Language.Capability
|
||||
import Swarm.Language.Requirement qualified as R
|
||||
import Swarm.Language.Syntax
|
||||
import Swarm.Util hiding (both)
|
||||
import System.Clock (TimeSpec)
|
||||
import System.Clock qualified
|
||||
import System.Random (UniformRange, uniformR)
|
||||
import Prelude hiding (Applicative (..), lookup)
|
||||
|
||||
-- | All functions that are used for robot step can access 'GameState' and the current 'Robot'.
|
||||
--
|
||||
-- They can also throw exception of our custom type, which is handled elsewhere.
|
||||
-- Because of that the constraint is only 'Throw', but not 'Catch'/'Error'.
|
||||
type HasRobotStepState sig m = (Has (State GameState) sig m, Has (State Robot) sig m, Has (Throw Exn) sig m)
|
||||
|
||||
deriveHeading :: HasRobotStepState sig m => Direction -> m Heading
|
||||
deriveHeading d = do
|
||||
orient <- use robotOrientation
|
||||
when (isCardinal d) $ hasCapabilityFor COrient $ TDir d
|
||||
return $ applyTurn d $ orient ? zero
|
||||
|
||||
lookInDirection :: HasRobotStepState sig m => Direction -> m (Cosmic Location, Maybe Entity)
|
||||
lookInDirection d = do
|
||||
newHeading <- deriveHeading d
|
||||
loc <- use robotLocation
|
||||
let nextLoc = loc `offsetBy` newHeading
|
||||
(nextLoc,) <$> entityAt nextLoc
|
||||
|
||||
-- | Modify the entity (if any) at a given location.
|
||||
updateEntityAt ::
|
||||
(Has (State GameState) sig m) =>
|
||||
Cosmic Location ->
|
||||
(Maybe Entity -> Maybe Entity) ->
|
||||
m ()
|
||||
updateEntityAt cLoc@(Cosmic subworldName loc) upd = do
|
||||
didChange <-
|
||||
fmap (fromMaybe False) $
|
||||
zoomWorld subworldName $
|
||||
W.updateM @Int (W.locToCoords loc) upd
|
||||
when didChange $
|
||||
wakeWatchingRobots cLoc
|
||||
|
||||
-- | Exempts the robot from various command constraints
|
||||
-- when it is either a system robot or playing in creative mode
|
||||
isPrivilegedBot :: (Has (State GameState) sig m, Has (State Robot) sig m) => m Bool
|
||||
isPrivilegedBot = (||) <$> use systemRobot <*> use creativeMode
|
||||
|
||||
-- * Exceptions
|
||||
|
||||
-- | Test whether the current robot has a given capability (either
|
||||
-- because it has a device which gives it that capability, or it is a
|
||||
-- system robot, or we are in creative mode).
|
||||
hasCapability :: (Has (State Robot) sig m, Has (State GameState) sig m) => Capability -> m Bool
|
||||
hasCapability cap = do
|
||||
isPrivileged <- isPrivilegedBot
|
||||
caps <- use robotCapabilities
|
||||
return (isPrivileged || cap `S.member` caps)
|
||||
|
||||
-- | Ensure that either a robot has a given capability, OR we are in creative
|
||||
-- mode.
|
||||
hasCapabilityFor ::
|
||||
(Has (State Robot) sig m, Has (State GameState) sig m, Has (Throw Exn) sig m) => Capability -> Term -> m ()
|
||||
hasCapabilityFor cap term = do
|
||||
h <- hasCapability cap
|
||||
h `holdsOr` Incapable FixByEquip (R.singletonCap cap) term
|
||||
|
||||
holdsOrFail' :: (Has (Throw Exn) sig m) => Const -> Bool -> [Text] -> m ()
|
||||
holdsOrFail' c a ts = a `holdsOr` cmdExn c ts
|
||||
|
||||
isJustOrFail' :: (Has (Throw Exn) sig m) => Const -> Maybe a -> [Text] -> m a
|
||||
isJustOrFail' c a ts = a `isJustOr` cmdExn c ts
|
||||
|
||||
-- | Create an exception about a command failing.
|
||||
cmdExn :: Const -> [Text] -> Exn
|
||||
cmdExn c parts = CmdFailed c (T.unwords parts) Nothing
|
||||
|
||||
getNow :: Has (Lift IO) sig m => m TimeSpec
|
||||
getNow = sendIO $ System.Clock.getTime System.Clock.Monotonic
|
||||
|
||||
------------------------------------------------------------
|
||||
-- Some utility functions
|
||||
------------------------------------------------------------
|
||||
|
||||
-- | Set a flag telling the UI that the world needs to be redrawn.
|
||||
flagRedraw :: (Has (State GameState) sig m) => m ()
|
||||
flagRedraw = needsRedraw .= True
|
||||
|
||||
-- | Perform an action requiring a 'W.World' state component in a
|
||||
-- larger context with a 'GameState'.
|
||||
zoomWorld ::
|
||||
(Has (State GameState) sig m) =>
|
||||
SubworldName ->
|
||||
StateC (W.World Int Entity) Identity b ->
|
||||
m (Maybe b)
|
||||
zoomWorld swName n = do
|
||||
mw <- use multiWorld
|
||||
forM (M.lookup swName mw) $ \w -> do
|
||||
let (w', a) = run (runState w n)
|
||||
multiWorld %= M.insert swName w'
|
||||
return a
|
||||
|
||||
-- | Get the entity (if any) at a given location.
|
||||
entityAt :: (Has (State GameState) sig m) => Cosmic Location -> m (Maybe Entity)
|
||||
entityAt (Cosmic subworldName loc) =
|
||||
join <$> zoomWorld subworldName (W.lookupEntityM @Int (W.locToCoords loc))
|
||||
|
||||
-- | Get the robot with a given ID.
|
||||
robotWithID :: (Has (State GameState) sig m) => RID -> m (Maybe Robot)
|
||||
robotWithID rid = use (robotMap . at rid)
|
||||
|
||||
-- | Get the robot with a given name.
|
||||
robotWithName :: (Has (State GameState) sig m) => Text -> m (Maybe Robot)
|
||||
robotWithName rname = use (robotMap . to IM.elems . to (find $ \r -> r ^. robotName == rname))
|
||||
|
||||
-- | Generate a uniformly random number using the random generator in
|
||||
-- the game state.
|
||||
uniform :: (Has (State GameState) sig m, UniformRange a) => (a, a) -> m a
|
||||
uniform bnds = do
|
||||
rand <- use randGen
|
||||
let (n, g) = uniformR bnds rand
|
||||
randGen .= g
|
||||
return n
|
||||
|
||||
-- | Given a weighting function and a list of values, choose one of
|
||||
-- the values randomly (using the random generator in the game
|
||||
-- state), with the probability of each being proportional to its
|
||||
-- weight. Return @Nothing@ if the list is empty.
|
||||
weightedChoice :: Has (State GameState) sig m => (a -> Integer) -> [a] -> m (Maybe a)
|
||||
weightedChoice weight as = do
|
||||
r <- uniform (0, total - 1)
|
||||
return $ go r as
|
||||
where
|
||||
total = sum (map weight as)
|
||||
|
||||
go _ [] = Nothing
|
||||
go !k (x : xs)
|
||||
| k < w = Just x
|
||||
| otherwise = go (k - w) xs
|
||||
where
|
||||
w = weight x
|
||||
|
||||
-- | Generate a random robot name in the form adjective_name.
|
||||
randomName :: Has (State GameState) sig m => m Text
|
||||
randomName = do
|
||||
adjs <- use @GameState adjList
|
||||
names <- use @GameState nameList
|
||||
i <- uniform (bounds adjs)
|
||||
j <- uniform (bounds names)
|
||||
return $ T.concat [adjs ! i, "_", names ! j]
|
||||
@ -52,6 +52,8 @@ data Capability
|
||||
CGrab
|
||||
| -- | Execute the 'Harvest' command
|
||||
CHarvest
|
||||
| -- | Execute the 'Ignite' command
|
||||
CIgnite
|
||||
| -- | Execute the 'Place' command
|
||||
CPlace
|
||||
| -- | Execute the 'Give' command
|
||||
@ -215,6 +217,7 @@ constCaps = \case
|
||||
Turn -> Just CTurn
|
||||
Grab -> Just CGrab
|
||||
Harvest -> Just CHarvest
|
||||
Ignite -> Just CIgnite
|
||||
Place -> Just CPlace
|
||||
Give -> Just CGive
|
||||
Equip -> Just CEquip
|
||||
|
||||
@ -162,6 +162,8 @@ data Const
|
||||
Grab
|
||||
| -- | Harvest an item from the current location.
|
||||
Harvest
|
||||
| -- | Ignite a combustible item
|
||||
Ignite
|
||||
| -- | Try to place an item at the current location.
|
||||
Place
|
||||
| -- | Give an item to another robot at the current location.
|
||||
@ -539,6 +541,10 @@ constInfo c = case c of
|
||||
[ "Leaves behind a growing seed if the harvested item is growable."
|
||||
, "Otherwise it works exactly like `grab`."
|
||||
]
|
||||
Ignite ->
|
||||
command 1 short . doc "Ignite a combustible item in the specified direction." $
|
||||
[ "Combustion persists for a random duration and may spread."
|
||||
]
|
||||
Place ->
|
||||
command 1 short . doc "Place an item at the current location." $
|
||||
["The current location has to be empty for this to work."]
|
||||
|
||||
@ -725,6 +725,7 @@ inferConst c = case c of
|
||||
Turn -> [tyQ| dir -> cmd unit |]
|
||||
Grab -> [tyQ| cmd text |]
|
||||
Harvest -> [tyQ| cmd text |]
|
||||
Ignite -> [tyQ| dir -> cmd unit |]
|
||||
Place -> [tyQ| text -> cmd unit |]
|
||||
Give -> [tyQ| actor -> text -> cmd unit |]
|
||||
Equip -> [tyQ| text -> cmd unit |]
|
||||
|
||||
@ -39,7 +39,7 @@ toFacade = \case
|
||||
Facade f -> f
|
||||
Ref e -> mkFacade e
|
||||
|
||||
getEntityName :: EntityFacade -> EntityName
|
||||
getEntityName :: EntityFacade -> E.EntityName
|
||||
getEntityName (EntityFacade name _) = name
|
||||
|
||||
data MapEditingBounds = MapEditingBounds
|
||||
|
||||
@ -19,7 +19,7 @@ import Data.Set qualified as Set
|
||||
import Data.Text qualified as T
|
||||
import Data.Tuple (swap)
|
||||
import Swarm.Game.Display (Display, defaultChar)
|
||||
import Swarm.Game.Entity (entitiesByName)
|
||||
import Swarm.Game.Entity (EntityName, entitiesByName)
|
||||
import Swarm.Game.Location
|
||||
import Swarm.Game.Scenario
|
||||
import Swarm.Game.Scenario.Topography.Area (AreaDimensions (..), getAreaDimensions)
|
||||
|
||||
@ -1115,6 +1115,7 @@ displayProperties :: [EntityProperty] -> Widget Name
|
||||
displayProperties = displayList . mapMaybe showProperty
|
||||
where
|
||||
showProperty Growable = Just "growing"
|
||||
showProperty Combustible = Just "combustible"
|
||||
showProperty Infinite = Just "infinite"
|
||||
showProperty Liquid = Just "liquid"
|
||||
showProperty Unwalkable = Just "blocking"
|
||||
|
||||
@ -130,6 +130,8 @@ library
|
||||
Swarm.Game.ScenarioInfo
|
||||
Swarm.Game.State
|
||||
Swarm.Game.Step
|
||||
Swarm.Game.Step.Combustion
|
||||
Swarm.Game.Step.Util
|
||||
Swarm.Game.Terrain
|
||||
Swarm.Game.Value
|
||||
Swarm.Game.World
|
||||
|
||||
@ -290,6 +290,7 @@ testScenarioSolutions rs ui =
|
||||
, testSolution Default "Testing/144-subworlds/basic-subworld"
|
||||
, testSolution Default "Testing/144-subworlds/subworld-mapped-robots"
|
||||
, testSolution Default "Testing/144-subworlds/subworld-located-robots"
|
||||
, testSolution Default "Testing/1355-combustion"
|
||||
, testSolution Default "Testing/1379-single-world-portal-reorientation"
|
||||
, testSolution Default "Testing/1399-backup-command"
|
||||
, testGroup
|
||||
|
||||
Loading…
Reference in New Issue
Block a user