mirror of
https://github.com/swarm-game/swarm.git
synced 2024-09-17 18:38:44 +03:00
subworlds (#1353)
Closes #144. This builds upon portals support (#1356) # Demo scripts/play.sh --scenario data/scenarios/Testing/144-subworlds/subworld-mapped-robots.yaml --autoplay --speed 2 [![asciicast](https://asciinema.org/a/vC13dW8M1S8t2b1J4XkW80U1q.svg)](https://asciinema.org/a/vC13dW8M1S8t2b1J4XkW80U1q) # Future work * Augment portal definitions with an optional "relative orientation" attribute, that can turn the player around when passing through the portal (#1379) * Specify whether portal performs instant transportation or whether `move down` is required (#1368)
This commit is contained in:
parent
d1a8242e5a
commit
f9c22635b5
@ -11,13 +11,15 @@ import Control.Monad.Except (runExceptT)
|
||||
import Control.Monad.State (evalStateT, execStateT)
|
||||
import Criterion.Main (Benchmark, bench, bgroup, defaultConfig, defaultMainWith, whnfAppIO)
|
||||
import Criterion.Types (Config (timeLimit))
|
||||
import Data.Map qualified as M
|
||||
import Swarm.Game.CESK (emptyStore, initMachine)
|
||||
import Swarm.Game.Display (defaultRobotDisplay)
|
||||
import Swarm.Game.Location
|
||||
import Swarm.Game.Robot (TRobot, mkRobot)
|
||||
import Swarm.Game.State (GameState, addTRobot, creativeMode, world)
|
||||
import Swarm.Game.State (GameState, addTRobot, creativeMode, multiWorld)
|
||||
import Swarm.Game.Step (gameTick)
|
||||
import Swarm.Game.Terrain (TerrainType (DirtT))
|
||||
import Swarm.Game.Universe (Cosmic (..), SubworldName (DefaultRootSubworld))
|
||||
import Swarm.Game.World (WorldFun (..), newWorld)
|
||||
import Swarm.Language.Context qualified as Context
|
||||
import Swarm.Language.Pipeline (ProcessedTerm)
|
||||
@ -73,7 +75,7 @@ circlerProgram =
|
||||
|
||||
-- | Initializes a robot with program prog at location loc facing north.
|
||||
initRobot :: ProcessedTerm -> Location -> TRobot
|
||||
initRobot prog loc = mkRobot () Nothing "" [] (Just loc) north defaultRobotDisplay (initMachine prog Context.empty emptyStore) [] [] False False 0
|
||||
initRobot prog loc = mkRobot () Nothing "" [] (Just $ Cosmic DefaultRootSubworld loc) north defaultRobotDisplay (initMachine prog Context.empty emptyStore) [] [] False False 0
|
||||
|
||||
-- | Creates a GameState with numRobot copies of robot on a blank map, aligned
|
||||
-- in a row starting at (0,0) and spreading east.
|
||||
@ -85,7 +87,7 @@ mkGameState robotMaker numRobots = do
|
||||
(mapM addTRobot robots)
|
||||
( (initAppState ^. gameState)
|
||||
& creativeMode .~ True
|
||||
& world .~ newWorld (WF $ const (fromEnum DirtT, Nothing))
|
||||
& multiWorld .~ M.singleton DefaultRootSubworld (newWorld (WF $ const (fromEnum DirtT, Nothing)))
|
||||
)
|
||||
|
||||
-- | Runs numGameTicks ticks of the game.
|
||||
|
@ -38,3 +38,4 @@
|
||||
1295-density-command.yaml
|
||||
1138-structures
|
||||
1356-portals
|
||||
144-subworlds
|
||||
|
5
data/scenarios/Testing/144-subworlds/00-ORDER.txt
Normal file
5
data/scenarios/Testing/144-subworlds/00-ORDER.txt
Normal file
@ -0,0 +1,5 @@
|
||||
basic-subworld.yaml
|
||||
subworld-shared-structures.yaml
|
||||
subworld-mapped-robots.yaml
|
||||
subworld-located-robots.yaml
|
||||
spatial-consistency-enforcement.yaml
|
@ -0,0 +1,7 @@
|
||||
|
||||
def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end;
|
||||
|
||||
doN 8 move;
|
||||
f <- grab;
|
||||
doN 7 move;
|
||||
place f;
|
@ -0,0 +1,10 @@
|
||||
|
||||
def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end;
|
||||
|
||||
doN 3 move;
|
||||
f <- grab;
|
||||
|
||||
doN 5 move;
|
||||
r <- meet;
|
||||
case r return $ \j. give j f;
|
||||
|
@ -0,0 +1,52 @@
|
||||
|
||||
def getRobotNumber = \n.
|
||||
r <- robotnumbered n;
|
||||
if (r == self) {
|
||||
return n;
|
||||
} {getRobotNumber $ n + 1};
|
||||
end;
|
||||
|
||||
def amLowestRecursive = \targetName. \idx.
|
||||
r <- robotnumbered idx;
|
||||
thisName <- as r {whoami};
|
||||
if (thisName == targetName) {
|
||||
return $ r == self;
|
||||
} {amLowestRecursive targetName $ idx + 1};
|
||||
end;
|
||||
|
||||
/**
|
||||
Iterates through robots by increasing index.
|
||||
If we encounter a robot, fetched by index,
|
||||
with the same name as me, but I am not that robot,
|
||||
then we return false.
|
||||
*/
|
||||
def amFirstOfMyName =
|
||||
myName <- whoami;
|
||||
amLowestRecursive myName 0;
|
||||
end;
|
||||
|
||||
def waitToGiveThing = \thing.
|
||||
r <- meet;
|
||||
case r (\_. wait 1; waitToGiveThing thing) $ \b. give b thing;
|
||||
end;
|
||||
|
||||
def waitToGive =
|
||||
let thing = "bitcoin" in
|
||||
create thing;
|
||||
waitToGiveThing thing;
|
||||
end;
|
||||
|
||||
def waitToReceive =
|
||||
noop;
|
||||
end;
|
||||
|
||||
def go =
|
||||
myNumber <- getRobotNumber 0;
|
||||
log $ "My number: " ++ format myNumber;
|
||||
amFirst <- amFirstOfMyName;
|
||||
log $ "Am first with this name? " ++ format amFirst;
|
||||
|
||||
if amFirst {waitToReceive} {waitToGive};
|
||||
end;
|
||||
|
||||
go;
|
@ -0,0 +1,8 @@
|
||||
|
||||
def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end;
|
||||
|
||||
doN 16 move;
|
||||
|
||||
r <- meet;
|
||||
case r return $ \j. give j "bitcoin";
|
||||
|
108
data/scenarios/Testing/144-subworlds/basic-subworld.yaml
Normal file
108
data/scenarios/Testing/144-subworlds/basic-subworld.yaml
Normal file
@ -0,0 +1,108 @@
|
||||
version: 1
|
||||
name: Subworlds demo
|
||||
description: |
|
||||
Surface and underground with portals.
|
||||
objectives:
|
||||
- goal:
|
||||
- |
|
||||
`place` the "flower" on the white cell.
|
||||
condition: |
|
||||
j <- robotnamed "judge";
|
||||
as j {ishere "flower"}
|
||||
solution: |
|
||||
run "scenarios/Testing/144-subworlds/_basic-subworld/solution.sw"
|
||||
attrs:
|
||||
- name: portal_in
|
||||
fg: "#ff9a00"
|
||||
bg: "#ff5d00"
|
||||
- name: portal_out
|
||||
fg: "#00a2ff"
|
||||
bg: "#0065ff"
|
||||
entities:
|
||||
- name: telepad entrance
|
||||
display:
|
||||
attr: portal_in
|
||||
char: "o"
|
||||
description:
|
||||
- Portal entrance
|
||||
properties: [known]
|
||||
- name: telepad exit
|
||||
display:
|
||||
attr: portal_out
|
||||
char: "o"
|
||||
description:
|
||||
- Portal exit
|
||||
properties: [known]
|
||||
robots:
|
||||
- name: base
|
||||
dir: [1, 0]
|
||||
devices:
|
||||
- ADT calculator
|
||||
- branch predictor
|
||||
- comparator
|
||||
- compass
|
||||
- dictionary
|
||||
- GPS receiver
|
||||
- grabber
|
||||
- lambda
|
||||
- lodestone
|
||||
- logger
|
||||
- strange loop
|
||||
- treads
|
||||
- name: judge
|
||||
dir: [1, 0]
|
||||
system: true
|
||||
display:
|
||||
char: 'J'
|
||||
invisible: true
|
||||
known: [flower, boulder]
|
||||
subworlds:
|
||||
- name: underground
|
||||
default: [blank]
|
||||
palette:
|
||||
'.': [dirt]
|
||||
'f': [dirt, flower]
|
||||
'b': [dirt, boulder]
|
||||
'p':
|
||||
cell: [dirt, telepad exit]
|
||||
waypoint:
|
||||
name: portal_out2
|
||||
'P':
|
||||
cell: [dirt, telepad entrance]
|
||||
waypoint:
|
||||
name: portal_in2
|
||||
portals:
|
||||
- entrance: portal_in2
|
||||
exitInfo:
|
||||
exit: portal_out1
|
||||
subworldName: root
|
||||
upperleft: [-1, 1]
|
||||
map: |
|
||||
b..b..b..b
|
||||
.p..f...P.
|
||||
b..b..b..b
|
||||
world:
|
||||
name: root
|
||||
default: [blank]
|
||||
palette:
|
||||
'.': [grass]
|
||||
'B': [grass, null, base]
|
||||
't': [ice, null, judge]
|
||||
'p':
|
||||
cell: [grass, telepad exit]
|
||||
waypoint:
|
||||
name: portal_out1
|
||||
'P':
|
||||
cell: [grass, telepad entrance]
|
||||
waypoint:
|
||||
name: portal_in1
|
||||
upperleft: [-1, 1]
|
||||
portals:
|
||||
- entrance: portal_in1
|
||||
exitInfo:
|
||||
exit: portal_out2
|
||||
subworldName: underground
|
||||
map: |
|
||||
..........
|
||||
.p.Bt...P.
|
||||
..........
|
@ -0,0 +1,93 @@
|
||||
version: 1
|
||||
name: Subworld spatial consistency enforcement
|
||||
description: |
|
||||
Portals annotated to enforce spatial consistency between subworlds
|
||||
attrs:
|
||||
- name: portal_in
|
||||
fg: "#ff9a00"
|
||||
bg: "#ff5d00"
|
||||
- name: portal_out
|
||||
fg: "#00a2ff"
|
||||
bg: "#0065ff"
|
||||
entities:
|
||||
- name: telepad entrance
|
||||
display:
|
||||
attr: portal_in
|
||||
char: "o"
|
||||
description:
|
||||
- Portal entrance
|
||||
properties: [known]
|
||||
- name: telepad exit
|
||||
display:
|
||||
attr: portal_out
|
||||
char: "o"
|
||||
description:
|
||||
- Portal exit
|
||||
properties: [known]
|
||||
robots:
|
||||
- name: base
|
||||
dir: [1, 0]
|
||||
devices:
|
||||
- ADT calculator
|
||||
- branch predictor
|
||||
- comparator
|
||||
- compass
|
||||
- dictionary
|
||||
- GPS receiver
|
||||
- grabber
|
||||
- lambda
|
||||
- lodestone
|
||||
- logger
|
||||
- strange loop
|
||||
- treads
|
||||
known: [boulder]
|
||||
subworlds:
|
||||
- name: underground
|
||||
default: [blank]
|
||||
palette:
|
||||
'.': [dirt]
|
||||
'b': [dirt, boulder]
|
||||
'p':
|
||||
cell: [dirt, telepad exit]
|
||||
waypoint:
|
||||
name: portal_out2
|
||||
'P':
|
||||
cell: [dirt, telepad entrance]
|
||||
waypoint:
|
||||
name: portal_in2
|
||||
portals:
|
||||
- entrance: portal_in2
|
||||
exitInfo:
|
||||
exit: portal_out1
|
||||
subworldName: root
|
||||
consistent: true
|
||||
upperleft: [-1, 1]
|
||||
map: |
|
||||
b..b..b..b
|
||||
.P......p.
|
||||
b..b..b..b
|
||||
world:
|
||||
name: root
|
||||
default: [blank]
|
||||
palette:
|
||||
'.': [grass]
|
||||
'B': [grass, null, base]
|
||||
'p':
|
||||
cell: [grass, telepad exit]
|
||||
waypoint:
|
||||
name: portal_out1
|
||||
'P':
|
||||
cell: [grass, telepad entrance]
|
||||
waypoint:
|
||||
name: portal_in1
|
||||
upperleft: [-1, 1]
|
||||
portals:
|
||||
- entrance: portal_in1
|
||||
exitInfo:
|
||||
exit: portal_out2
|
||||
subworldName: underground
|
||||
consistent: true
|
||||
map: |
|
||||
..........
|
||||
.p.B....P.
|
||||
..........
|
@ -0,0 +1,116 @@
|
||||
version: 1
|
||||
name: Subworld robots (explicit location)
|
||||
description: |
|
||||
Demonstrate that system robots can be placed in any subworld.
|
||||
objectives:
|
||||
- goal:
|
||||
- |
|
||||
`give` the "flower" to the robot underground.
|
||||
condition: |
|
||||
j <- robotnamed "judge";
|
||||
as j {has "flower"}
|
||||
solution: |
|
||||
run "scenarios/Testing/144-subworlds/_subworld-located-robots/solution.sw"
|
||||
attrs:
|
||||
- name: portal_in
|
||||
fg: "#ff9a00"
|
||||
bg: "#ff5d00"
|
||||
- name: portal_out
|
||||
fg: "#00a2ff"
|
||||
bg: "#0065ff"
|
||||
entities:
|
||||
- name: telepad entrance
|
||||
display:
|
||||
attr: portal_in
|
||||
char: "o"
|
||||
description:
|
||||
- Portal entrance
|
||||
properties: [known]
|
||||
- name: telepad exit
|
||||
display:
|
||||
attr: portal_out
|
||||
char: "o"
|
||||
description:
|
||||
- Portal exit
|
||||
properties: [known]
|
||||
robots:
|
||||
- name: base
|
||||
dir: [1, 0]
|
||||
loc:
|
||||
subworld: root
|
||||
loc: [2, 0]
|
||||
devices:
|
||||
- ADT calculator
|
||||
- antenna
|
||||
- branch predictor
|
||||
- comparator
|
||||
- compass
|
||||
- dictionary
|
||||
- GPS receiver
|
||||
- grabber
|
||||
- lambda
|
||||
- lodestone
|
||||
- logger
|
||||
- strange loop
|
||||
- treads
|
||||
- name: judge
|
||||
dir: [1, 0]
|
||||
loc:
|
||||
subworld: underground
|
||||
loc: [4, 0]
|
||||
system: true
|
||||
display:
|
||||
char: 'J'
|
||||
invisible: false
|
||||
known: [flower, boulder]
|
||||
subworlds:
|
||||
- name: underground
|
||||
default: [blank]
|
||||
palette:
|
||||
'.': [dirt]
|
||||
'b': [dirt, boulder]
|
||||
't': [grass, null, judge]
|
||||
'p':
|
||||
cell: [dirt, telepad exit]
|
||||
waypoint:
|
||||
name: portal_out2
|
||||
'P':
|
||||
cell: [dirt, telepad entrance]
|
||||
waypoint:
|
||||
name: portal_in2
|
||||
portals:
|
||||
- entrance: portal_in2
|
||||
exitInfo:
|
||||
exit: portal_out1
|
||||
subworldName: root
|
||||
upperleft: [-1, 1]
|
||||
map: |
|
||||
b..b..b..b
|
||||
.p......P.
|
||||
b..b..b..b
|
||||
world:
|
||||
name: root
|
||||
default: [blank]
|
||||
palette:
|
||||
'.': [grass]
|
||||
'f': [grass, flower]
|
||||
'B': [grass, null, base]
|
||||
't': [grass, null, judge]
|
||||
'p':
|
||||
cell: [grass, telepad exit]
|
||||
waypoint:
|
||||
name: portal_out1
|
||||
'P':
|
||||
cell: [grass, telepad entrance]
|
||||
waypoint:
|
||||
name: portal_in1
|
||||
upperleft: [-1, 1]
|
||||
portals:
|
||||
- entrance: portal_in1
|
||||
exitInfo:
|
||||
exit: portal_out2
|
||||
subworldName: underground
|
||||
map: |
|
||||
..........
|
||||
.p....f.P.
|
||||
..........
|
116
data/scenarios/Testing/144-subworlds/subworld-mapped-robots.yaml
Normal file
116
data/scenarios/Testing/144-subworlds/subworld-mapped-robots.yaml
Normal file
@ -0,0 +1,116 @@
|
||||
version: 1
|
||||
name: Subworld robots (map placement)
|
||||
description: |
|
||||
Demonstrate that system robots can be placed in any subworld.
|
||||
|
||||
Also demonstrates tiebreaking logic for robot numbering based
|
||||
on subworld.
|
||||
objectives:
|
||||
- goal:
|
||||
- |
|
||||
`give` the "bitcoin" to the robot in the "root" world.
|
||||
- |
|
||||
First obtain it from the robot living underground.
|
||||
condition: |
|
||||
j <- robotnumbered 1;
|
||||
as j {has "bitcoin"}
|
||||
solution: |
|
||||
run "scenarios/Testing/144-subworlds/_subworld-mapped-robots/solution.sw"
|
||||
attrs:
|
||||
- name: portal_in
|
||||
fg: "#ff9a00"
|
||||
bg: "#ff5d00"
|
||||
- name: portal_out
|
||||
fg: "#00a2ff"
|
||||
bg: "#0065ff"
|
||||
entities:
|
||||
- name: telepad entrance
|
||||
display:
|
||||
attr: portal_in
|
||||
char: "o"
|
||||
description:
|
||||
- Portal entrance
|
||||
properties: [known]
|
||||
- name: telepad exit
|
||||
display:
|
||||
attr: portal_out
|
||||
char: "o"
|
||||
description:
|
||||
- Portal exit
|
||||
properties: [known]
|
||||
robots:
|
||||
- name: base
|
||||
dir: [1, 0]
|
||||
devices:
|
||||
- ADT calculator
|
||||
- antenna
|
||||
- branch predictor
|
||||
- comparator
|
||||
- compass
|
||||
- dictionary
|
||||
- GPS receiver
|
||||
- grabber
|
||||
- lambda
|
||||
- lodestone
|
||||
- logger
|
||||
- strange loop
|
||||
- treads
|
||||
- name: judge
|
||||
dir: [1, 0]
|
||||
system: true
|
||||
display:
|
||||
char: 'J'
|
||||
invisible: false
|
||||
program: |
|
||||
run "scenarios/Testing/144-subworlds/_subworld-mapped-robots/judges.sw";
|
||||
known: [boulder]
|
||||
subworlds:
|
||||
- name: underground
|
||||
default: [blank]
|
||||
palette:
|
||||
'.': [dirt]
|
||||
'b': [dirt, boulder]
|
||||
't': [grass, null, judge]
|
||||
'p':
|
||||
cell: [dirt, telepad exit]
|
||||
waypoint:
|
||||
name: portal_out2
|
||||
'P':
|
||||
cell: [dirt, telepad entrance]
|
||||
waypoint:
|
||||
name: portal_in2
|
||||
portals:
|
||||
- entrance: portal_in2
|
||||
exitInfo:
|
||||
exit: portal_out1
|
||||
subworldName: root
|
||||
upperleft: [-1, 1]
|
||||
map: |
|
||||
b..b..b..b
|
||||
.p.t....P.
|
||||
b..b..b..b
|
||||
world:
|
||||
name: root
|
||||
default: [blank]
|
||||
palette:
|
||||
'.': [grass]
|
||||
'B': [grass, null, base]
|
||||
't': [grass, null, judge]
|
||||
'p':
|
||||
cell: [grass, telepad exit]
|
||||
waypoint:
|
||||
name: portal_out1
|
||||
'P':
|
||||
cell: [grass, telepad entrance]
|
||||
waypoint:
|
||||
name: portal_in1
|
||||
upperleft: [-1, 1]
|
||||
portals:
|
||||
- entrance: portal_in1
|
||||
exitInfo:
|
||||
exit: portal_out2
|
||||
subworldName: underground
|
||||
map: |
|
||||
..........
|
||||
.p.B..t.P.
|
||||
..........
|
@ -0,0 +1,193 @@
|
||||
version: 1
|
||||
name: Subworld shared structures
|
||||
description: |
|
||||
Traverse floors of the tower
|
||||
attrs:
|
||||
- name: portal_in
|
||||
fg: "#ff9a00"
|
||||
bg: "#ff5d00"
|
||||
- name: portal_out
|
||||
fg: "#00a2ff"
|
||||
bg: "#0065ff"
|
||||
entities:
|
||||
- name: telepad entrance
|
||||
display:
|
||||
attr: portal_in
|
||||
char: "o"
|
||||
description:
|
||||
- Portal entrance
|
||||
properties: [known]
|
||||
- name: telepad exit
|
||||
display:
|
||||
attr: portal_out
|
||||
char: "o"
|
||||
description:
|
||||
- Portal exit
|
||||
properties: [known]
|
||||
robots:
|
||||
- name: base
|
||||
dir: [1, 0]
|
||||
loc: [0, 0]
|
||||
devices:
|
||||
- ADT calculator
|
||||
- branch predictor
|
||||
- comparator
|
||||
- compass
|
||||
- dictionary
|
||||
- GPS receiver
|
||||
- grabber
|
||||
- lambda
|
||||
- lodestone
|
||||
- logger
|
||||
- strange loop
|
||||
- treads
|
||||
known: [flower]
|
||||
structures:
|
||||
- name: minibox
|
||||
structure:
|
||||
palette:
|
||||
'.': [stone]
|
||||
'd': [dirt]
|
||||
'f': [stone, flower]
|
||||
'p':
|
||||
cell: [grass, telepad exit]
|
||||
waypoint:
|
||||
name: portal_out
|
||||
'P':
|
||||
cell: [grass, telepad entrance]
|
||||
waypoint:
|
||||
name: portal_in
|
||||
map: |
|
||||
p....
|
||||
.ddd.
|
||||
.d.d.
|
||||
.ddd.
|
||||
....P
|
||||
- name: flowers
|
||||
structure:
|
||||
mask: '.'
|
||||
palette:
|
||||
'f': [stone, flower]
|
||||
map: |
|
||||
f.f
|
||||
.f.
|
||||
f.f
|
||||
subworlds:
|
||||
- name: floor1
|
||||
default: [blank]
|
||||
palette:
|
||||
'.': [dirt]
|
||||
'f': [dirt, flower]
|
||||
'p':
|
||||
cell: [dirt, telepad exit]
|
||||
waypoint:
|
||||
name: portal_out
|
||||
'P':
|
||||
cell: [dirt, telepad entrance]
|
||||
waypoint:
|
||||
name: portal_in
|
||||
placements:
|
||||
- src: flowers
|
||||
offset: [1, 1]
|
||||
- src: minibox
|
||||
offset: [0, 0]
|
||||
orient:
|
||||
up: west
|
||||
portals:
|
||||
- entrance: portal_in
|
||||
exitInfo:
|
||||
exit: portal_out
|
||||
subworldName: floor2
|
||||
upperleft: [0, 0]
|
||||
map: |
|
||||
.....
|
||||
.....
|
||||
.....
|
||||
.....
|
||||
.....
|
||||
- name: floor2
|
||||
default: [blank]
|
||||
palette:
|
||||
'.': [dirt]
|
||||
'f': [dirt, flower]
|
||||
'p':
|
||||
cell: [dirt, telepad exit]
|
||||
waypoint:
|
||||
name: portal_out
|
||||
'P':
|
||||
cell: [dirt, telepad entrance]
|
||||
waypoint:
|
||||
name: portal_in
|
||||
placements:
|
||||
- src: flowers
|
||||
offset: [1, 0]
|
||||
- src: minibox
|
||||
offset: [0, 0]
|
||||
orient:
|
||||
up: south
|
||||
portals:
|
||||
- entrance: portal_in
|
||||
exitInfo:
|
||||
exit: portal_out
|
||||
subworldName: floor3
|
||||
upperleft: [0, 0]
|
||||
map: |
|
||||
.....
|
||||
.....
|
||||
.....
|
||||
.....
|
||||
.....
|
||||
- name: floor3
|
||||
default: [blank]
|
||||
palette:
|
||||
'.': [dirt]
|
||||
'f': [dirt, flower]
|
||||
'p':
|
||||
cell: [dirt, telepad exit]
|
||||
waypoint:
|
||||
name: portal_out
|
||||
'P':
|
||||
cell: [dirt, telepad entrance]
|
||||
waypoint:
|
||||
name: portal_in
|
||||
placements:
|
||||
- src: flowers
|
||||
offset: [1, -2]
|
||||
- src: minibox
|
||||
offset: [0, 0]
|
||||
orient:
|
||||
up: east
|
||||
portals:
|
||||
- entrance: portal_in
|
||||
exitInfo:
|
||||
exit: portal_out
|
||||
subworldName: root
|
||||
upperleft: [0, 0]
|
||||
map: |
|
||||
.....
|
||||
.....
|
||||
.....
|
||||
.....
|
||||
.....
|
||||
world:
|
||||
name: root
|
||||
default: [blank]
|
||||
palette:
|
||||
'.': [grass]
|
||||
upperleft: [0, 0]
|
||||
placements:
|
||||
- src: flowers
|
||||
offset: [0, -2]
|
||||
- src: minibox
|
||||
offset: [0, 0]
|
||||
portals:
|
||||
- entrance: portal_in
|
||||
exitInfo:
|
||||
exit: portal_out
|
||||
subworldName: floor1
|
||||
map: |
|
||||
.....
|
||||
.....
|
||||
.....
|
||||
.....
|
||||
.....
|
@ -0,0 +1,93 @@
|
||||
version: 1
|
||||
name: Subworld spatial consistency enforcement
|
||||
description: |
|
||||
Portals annotated to enforce spatial consistency between subworlds
|
||||
attrs:
|
||||
- name: portal_in
|
||||
fg: "#ff9a00"
|
||||
bg: "#ff5d00"
|
||||
- name: portal_out
|
||||
fg: "#00a2ff"
|
||||
bg: "#0065ff"
|
||||
entities:
|
||||
- name: telepad entrance
|
||||
display:
|
||||
attr: portal_in
|
||||
char: "o"
|
||||
description:
|
||||
- Portal entrance
|
||||
properties: [known]
|
||||
- name: telepad exit
|
||||
display:
|
||||
attr: portal_out
|
||||
char: "o"
|
||||
description:
|
||||
- Portal exit
|
||||
properties: [known]
|
||||
robots:
|
||||
- name: base
|
||||
dir: [1, 0]
|
||||
devices:
|
||||
- ADT calculator
|
||||
- branch predictor
|
||||
- comparator
|
||||
- compass
|
||||
- dictionary
|
||||
- GPS receiver
|
||||
- grabber
|
||||
- lambda
|
||||
- lodestone
|
||||
- logger
|
||||
- strange loop
|
||||
- treads
|
||||
known: [boulder]
|
||||
subworlds:
|
||||
- name: underground
|
||||
default: [blank]
|
||||
palette:
|
||||
'.': [dirt]
|
||||
'b': [dirt, boulder]
|
||||
'p':
|
||||
cell: [dirt, telepad exit]
|
||||
waypoint:
|
||||
name: portal_out2
|
||||
'P':
|
||||
cell: [dirt, telepad entrance]
|
||||
waypoint:
|
||||
name: portal_in2
|
||||
portals:
|
||||
- entrance: portal_in2
|
||||
exitInfo:
|
||||
exit: portal_out1
|
||||
subworldName: root
|
||||
consistent: true
|
||||
upperleft: [-1, 1]
|
||||
map: |
|
||||
b..b..b..b
|
||||
.P.....p..
|
||||
b..b..b..b
|
||||
world:
|
||||
name: root
|
||||
default: [blank]
|
||||
palette:
|
||||
'.': [grass]
|
||||
'B': [grass, null, base]
|
||||
'p':
|
||||
cell: [grass, telepad exit]
|
||||
waypoint:
|
||||
name: portal_out1
|
||||
'P':
|
||||
cell: [grass, telepad entrance]
|
||||
waypoint:
|
||||
name: portal_in1
|
||||
upperleft: [-1, 1]
|
||||
portals:
|
||||
- entrance: portal_in1
|
||||
exitInfo:
|
||||
exit: portal_out2
|
||||
subworldName: underground
|
||||
consistent: true
|
||||
map: |
|
||||
..........
|
||||
.p.B....P.
|
||||
..........
|
@ -0,0 +1,87 @@
|
||||
version: 1
|
||||
name: Subworld uniqueness (default name)
|
||||
description: |
|
||||
Has two unnamed subworlds, which fail uniqueness
|
||||
attrs:
|
||||
- name: portal_in
|
||||
fg: "#ff9a00"
|
||||
bg: "#ff5d00"
|
||||
- name: portal_out
|
||||
fg: "#00a2ff"
|
||||
bg: "#0065ff"
|
||||
entities:
|
||||
- name: telepad entrance
|
||||
display:
|
||||
attr: portal_in
|
||||
char: "o"
|
||||
description:
|
||||
- Portal entrance
|
||||
properties: [known]
|
||||
- name: telepad exit
|
||||
display:
|
||||
attr: portal_out
|
||||
char: "o"
|
||||
description:
|
||||
- Portal exit
|
||||
properties: [known]
|
||||
robots:
|
||||
- name: base
|
||||
dir: [1, 0]
|
||||
devices:
|
||||
- ADT calculator
|
||||
- branch predictor
|
||||
- comparator
|
||||
- compass
|
||||
- dictionary
|
||||
- GPS receiver
|
||||
- grabber
|
||||
- lambda
|
||||
- lodestone
|
||||
- logger
|
||||
- strange loop
|
||||
- treads
|
||||
- name: judge
|
||||
dir: [1, 0]
|
||||
system: true
|
||||
display:
|
||||
char: 'J'
|
||||
invisible: true
|
||||
known: [flower, boulder]
|
||||
subworlds:
|
||||
- default: [blank]
|
||||
palette:
|
||||
'.': [dirt]
|
||||
'f': [dirt, flower]
|
||||
'b': [dirt, boulder]
|
||||
'p':
|
||||
cell: [dirt, telepad exit]
|
||||
waypoint:
|
||||
name: portal_out2
|
||||
'P':
|
||||
cell: [dirt, telepad entrance]
|
||||
waypoint:
|
||||
name: portal_in2
|
||||
upperleft: [-1, 1]
|
||||
map: |
|
||||
b..b..b..b
|
||||
.p..f...P.
|
||||
b..b..b..b
|
||||
world:
|
||||
default: [blank]
|
||||
palette:
|
||||
'.': [grass]
|
||||
'B': [grass, null, base]
|
||||
't': [ice, null, judge]
|
||||
'p':
|
||||
cell: [grass, telepad exit]
|
||||
waypoint:
|
||||
name: portal_out1
|
||||
'P':
|
||||
cell: [grass, telepad entrance]
|
||||
waypoint:
|
||||
name: portal_in1
|
||||
upperleft: [-1, 1]
|
||||
map: |
|
||||
..........
|
||||
.p.Bt...P.
|
||||
..........
|
@ -0,0 +1,89 @@
|
||||
version: 1
|
||||
name: Subworld uniqueness (explicit name)
|
||||
description: |
|
||||
Has two identically-named subworlds
|
||||
attrs:
|
||||
- name: portal_in
|
||||
fg: "#ff9a00"
|
||||
bg: "#ff5d00"
|
||||
- name: portal_out
|
||||
fg: "#00a2ff"
|
||||
bg: "#0065ff"
|
||||
entities:
|
||||
- name: telepad entrance
|
||||
display:
|
||||
attr: portal_in
|
||||
char: "o"
|
||||
description:
|
||||
- Portal entrance
|
||||
properties: [known]
|
||||
- name: telepad exit
|
||||
display:
|
||||
attr: portal_out
|
||||
char: "o"
|
||||
description:
|
||||
- Portal exit
|
||||
properties: [known]
|
||||
robots:
|
||||
- name: base
|
||||
dir: [1, 0]
|
||||
devices:
|
||||
- ADT calculator
|
||||
- branch predictor
|
||||
- comparator
|
||||
- compass
|
||||
- dictionary
|
||||
- GPS receiver
|
||||
- grabber
|
||||
- lambda
|
||||
- lodestone
|
||||
- logger
|
||||
- strange loop
|
||||
- treads
|
||||
- name: judge
|
||||
dir: [1, 0]
|
||||
system: true
|
||||
display:
|
||||
char: 'J'
|
||||
invisible: true
|
||||
known: [flower, boulder]
|
||||
subworlds:
|
||||
- name: foo
|
||||
default: [blank]
|
||||
palette:
|
||||
'.': [dirt]
|
||||
'f': [dirt, flower]
|
||||
'b': [dirt, boulder]
|
||||
'p':
|
||||
cell: [dirt, telepad exit]
|
||||
waypoint:
|
||||
name: portal_out2
|
||||
'P':
|
||||
cell: [dirt, telepad entrance]
|
||||
waypoint:
|
||||
name: portal_in2
|
||||
upperleft: [-1, 1]
|
||||
map: |
|
||||
b..b..b..b
|
||||
.p..f...P.
|
||||
b..b..b..b
|
||||
world:
|
||||
name: foo
|
||||
default: [blank]
|
||||
palette:
|
||||
'.': [grass]
|
||||
'B': [grass, null, base]
|
||||
't': [ice, null, judge]
|
||||
'p':
|
||||
cell: [grass, telepad exit]
|
||||
waypoint:
|
||||
name: portal_out1
|
||||
'P':
|
||||
cell: [grass, telepad entrance]
|
||||
waypoint:
|
||||
name: portal_in1
|
||||
upperleft: [-1, 1]
|
||||
map: |
|
||||
..........
|
||||
.p.Bt...P.
|
||||
..........
|
@ -4,7 +4,7 @@ SCRIPT_DIR=$( cd -- "$( dirname -- "${BASH_SOURCE[0]}" )" &> /dev/null && pwd )
|
||||
cd $SCRIPT_DIR/..
|
||||
|
||||
|
||||
if grep --line-number --include \*.hs -riP '(TODO|FIXME|XXX):?\s' src 2>&1 | grep -vP '#\d+'; then
|
||||
if grep --line-number --include \*.hs -riP '(TODO|FIXME|XXX)\b' src 2>&1 | grep -vP '#\d+'; then
|
||||
echo "Please add a link to Issue, for example: TODO: #123"
|
||||
exit 1
|
||||
else
|
||||
|
@ -52,7 +52,7 @@ import Swarm.Game.Failure qualified as F
|
||||
import Swarm.Game.Failure.Render qualified as F
|
||||
import Swarm.Game.Recipe (Recipe, loadRecipes, recipeInputs, recipeOutputs, recipeRequirements, recipeTime, recipeWeight)
|
||||
import Swarm.Game.ResourceLoading (getDataFileNameSafe)
|
||||
import Swarm.Game.Robot (equippedDevices, instantiateRobot, robotInventory)
|
||||
import Swarm.Game.Robot (Robot, equippedDevices, instantiateRobot, robotInventory)
|
||||
import Swarm.Game.Scenario (Scenario, loadScenario, scenarioRobots)
|
||||
import Swarm.Game.WorldGen (testWorld2Entites)
|
||||
import Swarm.Language.Capability (Capability)
|
||||
@ -551,11 +551,14 @@ classicScenario = do
|
||||
entities <- loadEntities >>= guardRight "load entities"
|
||||
fst <$> loadScenario "data/scenarios/classic.yaml" entities
|
||||
|
||||
startingHelper :: Scenario -> Robot
|
||||
startingHelper = instantiateRobot 0 . head . view scenarioRobots
|
||||
|
||||
startingDevices :: Scenario -> Set Entity
|
||||
startingDevices = Set.fromList . map snd . E.elems . view equippedDevices . instantiateRobot 0 . head . view scenarioRobots
|
||||
startingDevices = Set.fromList . map snd . E.elems . view equippedDevices . startingHelper
|
||||
|
||||
startingInventory :: Scenario -> Map Entity Int
|
||||
startingInventory = Map.fromList . map swap . E.elems . view robotInventory . instantiateRobot 0 . head . view scenarioRobots
|
||||
startingInventory = Map.fromList . map swap . E.elems . view robotInventory . startingHelper
|
||||
|
||||
-- | Ignore utility entities that are just used for tutorials and challenges.
|
||||
ignoredEntities :: Set Text
|
||||
|
@ -20,6 +20,7 @@ module Swarm.Game.Log (
|
||||
|
||||
-- * Robot log entries
|
||||
LogEntry (..),
|
||||
LogLocation (..),
|
||||
leText,
|
||||
leSource,
|
||||
leRobotName,
|
||||
@ -34,6 +35,7 @@ import Data.Text (Text)
|
||||
import GHC.Generics (Generic)
|
||||
import Swarm.Game.CESK (TickNumber)
|
||||
import Swarm.Game.Location (Location)
|
||||
import Swarm.Game.Universe (Cosmic)
|
||||
|
||||
-- | Severity of the error - critical errors are bugs
|
||||
-- and should be reported as Issues.
|
||||
@ -50,6 +52,9 @@ data LogSource
|
||||
ErrorTrace ErrorLevel
|
||||
deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON)
|
||||
|
||||
data LogLocation a = Omnipresent | Located a
|
||||
deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON)
|
||||
|
||||
-- | An entry in a robot's log.
|
||||
data LogEntry = LogEntry
|
||||
{ _leTime :: TickNumber
|
||||
@ -61,7 +66,7 @@ data LogEntry = LogEntry
|
||||
-- ^ The name of the robot that generated the entry.
|
||||
, _leRobotID :: Int
|
||||
-- ^ The ID of the robot that generated the entry.
|
||||
, _leLocation :: Location
|
||||
, _leLocation :: LogLocation (Cosmic Location)
|
||||
-- ^ Location of the robot at log entry creation.
|
||||
, _leText :: Text
|
||||
-- ^ The text of the log entry.
|
||||
|
@ -95,6 +95,7 @@ import Swarm.Game.Display (Display, curOrientation, defaultRobotDisplay, invisib
|
||||
import Swarm.Game.Entity hiding (empty)
|
||||
import Swarm.Game.Location (Heading, Location, toDirection)
|
||||
import Swarm.Game.Log
|
||||
import Swarm.Game.Universe
|
||||
import Swarm.Language.Capability (Capability)
|
||||
import Swarm.Language.Context qualified as Ctx
|
||||
import Swarm.Language.Requirement (ReqCtx)
|
||||
@ -167,8 +168,8 @@ data RobotPhase
|
||||
-- | With a robot template, we may or may not have a location. With a
|
||||
-- concrete robot we must have a location.
|
||||
type family RobotLocation (phase :: RobotPhase) :: Data.Kind.Type where
|
||||
RobotLocation 'TemplateRobot = Maybe Location
|
||||
RobotLocation 'ConcreteRobot = Location
|
||||
RobotLocation 'TemplateRobot = Maybe (Cosmic Location)
|
||||
RobotLocation 'ConcreteRobot = Cosmic Location
|
||||
|
||||
-- | Robot templates have no ID; concrete robots definitely do.
|
||||
type family RobotID (phase :: RobotPhase) :: Data.Kind.Type where
|
||||
@ -270,19 +271,19 @@ robotDisplay = lens getDisplay setDisplay
|
||||
-- a getter, since when changing a robot's location we must remember
|
||||
-- to update the 'robotsByLocation' map as well. You can use the
|
||||
-- 'updateRobotLocation' function for this purpose.
|
||||
robotLocation :: Getter Robot Location
|
||||
robotLocation :: Getter Robot (Cosmic Location)
|
||||
|
||||
-- | Set a robot's location. This is unsafe and should never be
|
||||
-- called directly except by the 'updateRobotLocation' function.
|
||||
-- The reason is that we need to make sure the 'robotsByLocation'
|
||||
-- map stays in sync.
|
||||
unsafeSetRobotLocation :: Location -> Robot -> Robot
|
||||
unsafeSetRobotLocation :: Cosmic Location -> Robot -> Robot
|
||||
unsafeSetRobotLocation loc r = r {_robotLocation = loc}
|
||||
|
||||
-- | A template robot's location. Unlike 'robotLocation', this is a
|
||||
-- lens, since when dealing with robot templates there is as yet no
|
||||
-- 'robotsByLocation' map to keep up-to-date.
|
||||
trobotLocation :: Lens' TRobot (Maybe Location)
|
||||
trobotLocation :: Lens' TRobot (Maybe (Cosmic Location))
|
||||
trobotLocation = lens _robotLocation (\r l -> r {_robotLocation = l})
|
||||
|
||||
-- | Which way the robot is currently facing.
|
||||
@ -313,7 +314,7 @@ instantiateRobot :: RID -> TRobot -> Robot
|
||||
instantiateRobot i r =
|
||||
r
|
||||
{ _robotID = i
|
||||
, _robotLocation = fromMaybe zero (_robotLocation r)
|
||||
, _robotLocation = fromMaybe defaultCosmicLocation $ _robotLocation r
|
||||
}
|
||||
|
||||
-- | The ID number of the robot's parent, that is, the robot that
|
||||
|
@ -33,7 +33,8 @@ module Swarm.Game.Scenario (
|
||||
scenarioEntities,
|
||||
scenarioRecipes,
|
||||
scenarioKnown,
|
||||
scenarioWorld,
|
||||
scenarioWorlds,
|
||||
scenarioNavigation,
|
||||
scenarioRobots,
|
||||
scenarioObjectives,
|
||||
scenarioSolution,
|
||||
@ -45,19 +46,24 @@ module Swarm.Game.Scenario (
|
||||
getScenarioPath,
|
||||
) where
|
||||
|
||||
import Control.Arrow ((&&&))
|
||||
import Control.Lens hiding (from, (.=), (<.>))
|
||||
import Control.Monad (filterM)
|
||||
import Control.Monad (filterM, unless)
|
||||
import Control.Monad.Except (ExceptT (..), runExceptT, withExceptT)
|
||||
import Control.Monad.IO.Class (MonadIO (liftIO))
|
||||
import Control.Monad.Trans.Except (except)
|
||||
import Data.Aeson
|
||||
import Data.Either.Extra (eitherToMaybe, maybeToEither)
|
||||
import Data.List.NonEmpty (NonEmpty ((:|)))
|
||||
import Data.List.NonEmpty qualified as NE
|
||||
import Data.Map qualified as M
|
||||
import Data.Maybe (catMaybes, isNothing, listToMaybe)
|
||||
import Data.Text (Text)
|
||||
import Data.Text qualified as T
|
||||
import Swarm.Game.Entity
|
||||
import Swarm.Game.Failure
|
||||
import Swarm.Game.Failure.Render
|
||||
import Swarm.Game.Location
|
||||
import Swarm.Game.Recipe
|
||||
import Swarm.Game.ResourceLoading (getDataFileNameSafe)
|
||||
import Swarm.Game.Robot (TRobot)
|
||||
@ -66,9 +72,12 @@ import Swarm.Game.Scenario.Objective.Validation
|
||||
import Swarm.Game.Scenario.RobotLookup
|
||||
import Swarm.Game.Scenario.Style
|
||||
import Swarm.Game.Scenario.Topography.Cell
|
||||
import Swarm.Game.Scenario.Topography.Navigation.Portal
|
||||
import Swarm.Game.Scenario.Topography.Structure qualified as Structure
|
||||
import Swarm.Game.Scenario.Topography.WorldDescription
|
||||
import Swarm.Game.Universe
|
||||
import Swarm.Language.Pipeline (ProcessedTerm)
|
||||
import Swarm.Util (failT)
|
||||
import Swarm.Util (binTuples, failT)
|
||||
import Swarm.Util.Lens (makeLensesNoSigs)
|
||||
import Swarm.Util.Yaml
|
||||
import System.Directory (doesFileExist)
|
||||
@ -92,7 +101,8 @@ data Scenario = Scenario
|
||||
, _scenarioEntities :: EntityMap
|
||||
, _scenarioRecipes :: [Recipe Entity]
|
||||
, _scenarioKnown :: [Text]
|
||||
, _scenarioWorld :: WorldDescription
|
||||
, _scenarioWorlds :: NonEmpty WorldDescription
|
||||
, _scenarioNavigation :: Navigation (M.Map SubworldName) Location
|
||||
, _scenarioRobots :: [TRobot]
|
||||
, _scenarioObjectives :: [Objective]
|
||||
, _scenarioSolution :: Maybe ProcessedTerm
|
||||
@ -123,6 +133,35 @@ instance FromJSONE EntityMap Scenario where
|
||||
rs <- v ..: "robots"
|
||||
let rsMap = buildRobotMap rs
|
||||
|
||||
rootLevelSharedStructures <- localE (,rsMap) $ v ..:? "structures" ..!= []
|
||||
|
||||
allWorlds <- localE (\x -> (rootLevelSharedStructures :: Structure.InheritedStructureDefs, (x, rsMap))) $ do
|
||||
rootWorld <- v ..: "world"
|
||||
subworlds <- v ..:? "subworlds" ..!= []
|
||||
return $ rootWorld :| subworlds
|
||||
|
||||
let worldsByName = binTuples $ NE.toList $ NE.map (worldName &&& id) allWorlds
|
||||
dupedNames = M.keys $ M.filter ((> 1) . length) worldsByName
|
||||
unless (null dupedNames) $
|
||||
failT
|
||||
[ "Subworld names are not unique:"
|
||||
, T.intercalate ", " $ map renderWorldName dupedNames
|
||||
]
|
||||
|
||||
let mergedWaypoints =
|
||||
M.fromList $
|
||||
map (worldName &&& runIdentity . waypoints . navigation) $
|
||||
NE.toList allWorlds
|
||||
|
||||
mergedPortals <-
|
||||
validatePortals
|
||||
. Navigation mergedWaypoints
|
||||
. M.unions
|
||||
. map (portals . navigation)
|
||||
$ NE.toList allWorlds
|
||||
|
||||
let mergedNavigation = Navigation mergedWaypoints mergedPortals
|
||||
|
||||
Scenario
|
||||
<$> liftE (v .: "version")
|
||||
<*> liftE (v .: "name")
|
||||
@ -134,7 +173,8 @@ instance FromJSONE EntityMap Scenario where
|
||||
<*> pure em
|
||||
<*> v ..:? "recipes" ..!= []
|
||||
<*> pure known
|
||||
<*> localE (,rsMap) (v ..: "world")
|
||||
<*> pure allWorlds
|
||||
<*> pure mergedNavigation
|
||||
<*> pure rs
|
||||
<*> (liftE (v .:? "objectives" .!= []) >>= validateObjectives)
|
||||
<*> liftE (v .:? "solution")
|
||||
@ -179,8 +219,12 @@ scenarioRecipes :: Lens' Scenario [Recipe Entity]
|
||||
-- not have to scan them.
|
||||
scenarioKnown :: Lens' Scenario [Text]
|
||||
|
||||
-- | The starting world for the scenario.
|
||||
scenarioWorld :: Lens' Scenario WorldDescription
|
||||
-- | The subworlds of the scenario.
|
||||
-- The "root" subworld shall always be at the head of the list, by construction.
|
||||
scenarioWorlds :: Lens' Scenario (NonEmpty WorldDescription)
|
||||
|
||||
-- | Waypoints and inter-world portals
|
||||
scenarioNavigation :: Lens' Scenario (Navigation (M.Map SubworldName) Location)
|
||||
|
||||
-- | The starting robots for the scenario. Note this should
|
||||
-- include the base.
|
||||
|
@ -6,9 +6,12 @@
|
||||
module Swarm.Game.Scenario.RobotLookup where
|
||||
|
||||
import Control.Lens hiding (from, (<.>))
|
||||
import Data.Aeson (FromJSON)
|
||||
import Data.Map (Map)
|
||||
import Data.Map qualified as M
|
||||
import Data.Text (Text)
|
||||
import Data.Text qualified as T
|
||||
import GHC.Generics (Generic)
|
||||
import Swarm.Game.Entity
|
||||
import Swarm.Game.Robot (TRobot, trobotName)
|
||||
import Swarm.Util (failT, quote)
|
||||
@ -18,17 +21,20 @@ import Swarm.Util.Yaml
|
||||
-- Robot map
|
||||
------------------------------------------------------------
|
||||
|
||||
newtype RobotName = RobotName Text
|
||||
deriving (Show, Eq, Ord, Generic, FromJSON)
|
||||
|
||||
-- | A robot template paired with its definition's index within
|
||||
-- the Scenario file
|
||||
type IndexedTRobot = (Int, TRobot)
|
||||
|
||||
-- | A map from names to robots, used to look up robots in scenario
|
||||
-- descriptions.
|
||||
type RobotMap = Map Text IndexedTRobot
|
||||
type RobotMap = Map RobotName IndexedTRobot
|
||||
|
||||
-- | Create a 'RobotMap' from a list of robot templates.
|
||||
buildRobotMap :: [TRobot] -> RobotMap
|
||||
buildRobotMap rs = M.fromList $ zipWith (\x y -> (view trobotName y, (x, y))) [0 ..] rs
|
||||
buildRobotMap rs = M.fromList $ zipWith (\x y -> (RobotName $ view trobotName y, (x, y))) [0 ..] rs
|
||||
|
||||
------------------------------------------------------------
|
||||
-- Lookup utilities
|
||||
@ -36,11 +42,11 @@ buildRobotMap rs = M.fromList $ zipWith (\x y -> (view trobotName y, (x, y))) [0
|
||||
|
||||
-- | Look up a thing by name, throwing a parse error if it is not
|
||||
-- found.
|
||||
getThing :: Text -> (Text -> m -> Maybe a) -> Text -> ParserE m a
|
||||
getThing :: Show k => Text -> (k -> m -> Maybe a) -> k -> ParserE m a
|
||||
getThing thing lkup name = do
|
||||
m <- getE
|
||||
case lkup name m of
|
||||
Nothing -> failT ["Unknown", thing, "name:", quote name]
|
||||
Nothing -> failT ["Unknown", thing, "name:", quote $ T.pack $ show name]
|
||||
Just a -> return a
|
||||
|
||||
-- | Look up an entity by name in an 'EntityMap', throwing a parse
|
||||
@ -50,5 +56,5 @@ getEntity = getThing "entity" lookupEntityName
|
||||
|
||||
-- | Look up a robot by name in a 'RobotMap', throwing a parse error
|
||||
-- if it is not found.
|
||||
getRobot :: Text -> ParserE RobotMap IndexedTRobot
|
||||
getRobot :: RobotName -> ParserE RobotMap IndexedTRobot
|
||||
getRobot = getThing "robot" M.lookup
|
||||
|
@ -77,7 +77,7 @@ instance FromJSONE (EntityMap, RobotMap) Cell where
|
||||
traverse (localE fst . getEntity) meName
|
||||
|
||||
let name2rob r = do
|
||||
mrName <- liftE $ parseJSON @(Maybe Text) r
|
||||
mrName <- liftE $ parseJSON @(Maybe RobotName) r
|
||||
traverse (localE snd . getRobot) mrName
|
||||
|
||||
robs <- mapMaybeM name2rob (drop 2 tup)
|
||||
|
@ -1,38 +1,65 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
-- |
|
||||
-- SPDX-License-Identifier: BSD-3-Clause
|
||||
module Swarm.Game.Scenario.Topography.Navigation.Portal where
|
||||
|
||||
import Control.Arrow ((&&&))
|
||||
import Control.Lens (view)
|
||||
import Control.Monad (forM, forM_, unless)
|
||||
import Data.Aeson (FromJSON)
|
||||
import Data.Aeson
|
||||
import Data.Bifunctor (first)
|
||||
import Data.BoolExpr (Signed (..))
|
||||
import Data.Function (on)
|
||||
import Data.Functor.Identity
|
||||
import Data.Int (Int32)
|
||||
import Data.List (intercalate)
|
||||
import Data.List.NonEmpty (NonEmpty ((:|)))
|
||||
import Data.List.NonEmpty qualified as NE
|
||||
import Data.Map (Map)
|
||||
import Data.Map qualified as M
|
||||
import Data.Maybe (listToMaybe)
|
||||
import Data.Text (Text)
|
||||
import Data.Maybe (fromMaybe, listToMaybe)
|
||||
import Data.Text qualified as T
|
||||
import Data.Tuple (swap)
|
||||
import GHC.Generics (Generic)
|
||||
import Linear (V2)
|
||||
import Linear (V2, negated)
|
||||
import Swarm.Game.Location
|
||||
import Swarm.Game.Scenario.Topography.Navigation.Waypoint
|
||||
import Swarm.Util (binTuples, quote)
|
||||
import Swarm.Game.Universe
|
||||
import Swarm.Util (allEqual, binTuples, both, failT, quote, showT)
|
||||
|
||||
-- | Note: The primary overworld shall use
|
||||
-- the reserved name \"root\".
|
||||
newtype SubworldName = SubworldName Text
|
||||
deriving (Show, Eq, Ord, Generic, FromJSON)
|
||||
type WaypointMap = M.Map WaypointName (NonEmpty Location)
|
||||
|
||||
data Navigation = Navigation
|
||||
{ waypoints :: M.Map WaypointName (NonEmpty Location)
|
||||
data AnnotatedDestination a = AnnotatedDestination
|
||||
{ enforceConsistency :: Bool
|
||||
, cosmoLocation :: Cosmic a
|
||||
}
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- | Parameterized on waypoint dimensionality ('additionalDimension') and
|
||||
-- on the portal location specification method ('portalExitLoc').
|
||||
-- == @additionalDimension@
|
||||
-- As a member of the 'WorldDescription', waypoints are only known within a
|
||||
-- a single subworld, so 'additionalDimension' is 'Identity' for the map
|
||||
-- of waypoint names to planar locations.
|
||||
-- At the Scenario level, in contrast, we have access to all subworlds, so
|
||||
-- we nest this map to planar locations in additional mapping layer by subworld.
|
||||
-- == @portalExitLoc@
|
||||
-- At the subworld parsing level, we only can obtain the planar location
|
||||
-- for portal /entrances/, but the /exits/ remain as waypoint names.
|
||||
-- At the Scenario-parsing level, we finally have
|
||||
-- access to the waypoints across all subworlds, and can therefore translate
|
||||
-- the portal exits to concrete planar locations.
|
||||
data Navigation additionalDimension portalExitLoc = Navigation
|
||||
{ waypoints :: additionalDimension WaypointMap
|
||||
-- ^ Note that waypoints defined at the "root" level are still relative to
|
||||
-- the top-left corner of the map rectangle; they are not in absolute world
|
||||
-- coordinates (as with applying the "ul" offset).
|
||||
, portals :: M.Map Location Location
|
||||
, portals :: M.Map (Cosmic Location) (AnnotatedDestination portalExitLoc)
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
deriving instance (Eq (a WaypointMap), Eq b) => Eq (Navigation a b)
|
||||
deriving instance (Show (a WaypointMap), Show b) => Show (Navigation a b)
|
||||
|
||||
data PortalExit = PortalExit
|
||||
{ exit :: WaypointName
|
||||
@ -44,51 +71,81 @@ data PortalExit = PortalExit
|
||||
data Portal = Portal
|
||||
{ entrance :: WaypointName
|
||||
, exitInfo :: PortalExit
|
||||
, consistent :: Bool
|
||||
}
|
||||
deriving (Show, Eq, Generic, FromJSON)
|
||||
deriving (Show, Eq)
|
||||
|
||||
instance FromJSON Portal where
|
||||
parseJSON = withObject "Portal" $ \v ->
|
||||
Portal
|
||||
<$> v
|
||||
.: "entrance"
|
||||
<*> v
|
||||
.: "exitInfo"
|
||||
<*> v .:? "consistent" .!= False
|
||||
|
||||
failUponDuplication ::
|
||||
(MonadFail m, Show a, Show b) =>
|
||||
String ->
|
||||
T.Text ->
|
||||
M.Map a (NonEmpty b) ->
|
||||
m ()
|
||||
failUponDuplication message binnedMap =
|
||||
forM_ (listToMaybe $ M.toList duplicated) $ \(pIn, pOuts) ->
|
||||
fail $
|
||||
unwords
|
||||
failT
|
||||
[ "Waypoint"
|
||||
, show pIn
|
||||
, showT pIn
|
||||
, message
|
||||
, intercalate ", " $ map show $ NE.toList pOuts
|
||||
, T.intercalate ", " $ map showT $ NE.toList pOuts
|
||||
]
|
||||
where
|
||||
duplicated = M.filter ((> 1) . NE.length) binnedMap
|
||||
|
||||
-- | Enforces the following constraints:
|
||||
-- * portals can have multiple entrances but only a single exit
|
||||
failWaypointLookup :: MonadFail m => WaypointName -> Maybe a -> m a
|
||||
failWaypointLookup (WaypointName rawName) =
|
||||
maybe (failT ["No waypoint named", quote rawName]) return
|
||||
|
||||
-- |
|
||||
-- The following constraints must be enforced:
|
||||
-- * portals based on plural waypoint multiplicity can have multiple entrances but only a single exit
|
||||
-- * no two portals share the same entrance location
|
||||
-- * global waypoint uniqueness when the "unique" flag is specified
|
||||
validateNavigation ::
|
||||
-- * waypoint uniqueness within a subworld when the 'unique' flag is specified
|
||||
--
|
||||
-- == Data flow:
|
||||
--
|
||||
-- Waypoints are defined within a subworld and are namespaced by it.
|
||||
-- Optional intra-subworld uniqueness of Waypoints is enforced at WorldDescription
|
||||
-- parse time.
|
||||
-- Portals are declared within a subworld. The portal entrance must be a waypoint
|
||||
-- within this subworld.
|
||||
-- They can reference waypoints in other subworlds as exits, but these references
|
||||
-- are not validated until the Scenario parse level.
|
||||
--
|
||||
-- * Since portal /entrances/ are specified at the subworld level, validation that
|
||||
-- no entrances overlap can also be performed at that level.
|
||||
-- * However, enforcement of single-multiplicity on portal /exits/ must be performed
|
||||
-- at scenario-parse level, because for a portal exit that references a waypoint in
|
||||
-- another subworld, we can't know at the single-WorldDescription level whether
|
||||
-- that waypoint has plural multiplicity.
|
||||
validatePartialNavigation ::
|
||||
(MonadFail m, Traversable t) =>
|
||||
V2 Int32 ->
|
||||
SubworldName ->
|
||||
Location ->
|
||||
[Originated Waypoint] ->
|
||||
t Portal ->
|
||||
m Navigation
|
||||
validateNavigation upperLeft unmergedWaypoints portalDefs = do
|
||||
m (Navigation Identity WaypointName)
|
||||
validatePartialNavigation currentSubworldName upperLeft unmergedWaypoints portalDefs = do
|
||||
failUponDuplication "is required to be unique, but is duplicated in:" waypointsWithUniqueFlag
|
||||
|
||||
-- TODO(#144) Currently ignores subworld references
|
||||
nestedPortalPairs <- forM portalDefs $ \(Portal entranceName (PortalExit exitName@(WaypointName rawExitName) _)) -> do
|
||||
nestedPortalPairs <- forM portalDefs $ \(Portal entranceName (PortalExit exitName maybeExitSubworldName) isConsistent) -> do
|
||||
-- Portals can have multiple entrances but only a single exit.
|
||||
-- That is, the pairings of entries to exits must form a proper mathematical "function".
|
||||
-- Multiple occurrences of entrance waypoints of a given name will replicate portal entrances.
|
||||
-- Multiple occurrences of entrance waypoints of a given name will result in
|
||||
-- multiple portal entrances.
|
||||
entranceLocs <- getLocs entranceName
|
||||
firstExitLoc :| otherExits <- getLocs exitName
|
||||
unless (null otherExits)
|
||||
. fail
|
||||
. T.unpack
|
||||
$ T.unwords ["Ambiguous exit waypoints named", quote rawExitName, "for portal"]
|
||||
return $ map ((,extractLoc firstExitLoc) . extractLoc) $ NE.toList entranceLocs
|
||||
|
||||
let sw = fromMaybe currentSubworldName maybeExitSubworldName
|
||||
f = (,AnnotatedDestination isConsistent $ Cosmic sw exitName) . extractLoc
|
||||
return $ map f $ NE.toList entranceLocs
|
||||
|
||||
let reconciledPortalPairs = concat nestedPortalPairs
|
||||
|
||||
@ -97,24 +154,143 @@ validateNavigation upperLeft unmergedWaypoints portalDefs = do
|
||||
failUponDuplication "has overlapping portal entrances exiting to" $
|
||||
binTuples reconciledPortalPairs
|
||||
|
||||
return $ Navigation bareWaypoints $ M.fromList reconciledPortalPairs
|
||||
return . Navigation (pure bareWaypoints) . M.fromList $
|
||||
map (first $ Cosmic currentSubworldName) reconciledPortalPairs
|
||||
where
|
||||
getLocs wpWrapper@(WaypointName rawName) = case M.lookup wpWrapper correctedWaypoints of
|
||||
Nothing ->
|
||||
fail $
|
||||
T.unpack $
|
||||
T.unwords
|
||||
[ "No waypoint named"
|
||||
, quote rawName
|
||||
]
|
||||
Just xs -> return xs
|
||||
getLocs wpWrapper = failWaypointLookup wpWrapper $ M.lookup wpWrapper correctedWaypoints
|
||||
|
||||
extractLoc (Originated _ (Waypoint _ loc)) = loc
|
||||
correctedWaypoints =
|
||||
binTuples $
|
||||
map
|
||||
(\x -> (wpName $ wpConfig $ value x, fmap (offsetWaypoint upperLeft) x))
|
||||
(\x -> (wpName $ wpConfig $ value x, fmap (offsetWaypoint $ upperLeft .-. origin) x))
|
||||
unmergedWaypoints
|
||||
bareWaypoints = M.map (NE.map extractLoc) correctedWaypoints
|
||||
|
||||
waypointsWithUniqueFlag = M.filter (any $ wpUnique . wpConfig . value) correctedWaypoints
|
||||
|
||||
validatePortals ::
|
||||
MonadFail m =>
|
||||
Navigation (M.Map SubworldName) WaypointName ->
|
||||
m (M.Map (Cosmic Location) (AnnotatedDestination Location))
|
||||
validatePortals (Navigation wpUniverse partialPortals) = do
|
||||
portalPairs <- forM (M.toList partialPortals) $ \(portalEntrance, AnnotatedDestination isConsistent portalExit@(Cosmic swName (WaypointName rawExitName))) -> do
|
||||
firstExitLoc :| otherExits <- getLocs portalExit
|
||||
unless (null otherExits) $
|
||||
failT
|
||||
[ "Ambiguous exit waypoints named"
|
||||
, quote rawExitName
|
||||
, "for portal"
|
||||
]
|
||||
return (portalEntrance, AnnotatedDestination isConsistent $ Cosmic swName firstExitLoc)
|
||||
|
||||
ensureSpatialConsistency portalPairs
|
||||
|
||||
return $ M.fromList portalPairs
|
||||
where
|
||||
getLocs (Cosmic swName wpWrapper@(WaypointName exitName)) = do
|
||||
subworldWaypoints <- case M.lookup swName wpUniverse of
|
||||
Just x -> return x
|
||||
Nothing ->
|
||||
failT
|
||||
[ "Could not lookup waypoint"
|
||||
, quote exitName
|
||||
, "for portal exit because subworld"
|
||||
, quote $ renderWorldName swName
|
||||
, "does not exist"
|
||||
]
|
||||
|
||||
failWaypointLookup wpWrapper $
|
||||
M.lookup wpWrapper subworldWaypoints
|
||||
|
||||
-- | A portal can be marked as \"consistent\", meaning that it represents
|
||||
-- a conventional physical passage rather than a \"magical\" teleportation.
|
||||
--
|
||||
-- If there exists more than one \"consistent\" portal between the same
|
||||
-- two subworlds, then the portal locations must be spatially consistent
|
||||
-- between the two worlds. I.e. the space comprising the two subworlds
|
||||
-- forms a "conservative vector field".
|
||||
--
|
||||
-- Verifying this is simple:
|
||||
-- For all of the portals between Subworlds A and B:
|
||||
-- * The coordinates of all \"consistent\" portal locations in Subworld A
|
||||
-- are subtracted from the corresponding coordinates in Subworld B. It
|
||||
-- does not matter which are exits vs. entrances.
|
||||
-- * The resulting \"vector\" from every pair must be equal.
|
||||
ensureSpatialConsistency ::
|
||||
MonadFail m =>
|
||||
[(Cosmic Location, AnnotatedDestination Location)] ->
|
||||
m ()
|
||||
ensureSpatialConsistency xs =
|
||||
unless (null nonUniform) $
|
||||
failT
|
||||
[ "Non-uniform portal distances:"
|
||||
, showT nonUniform
|
||||
]
|
||||
where
|
||||
consistentPairs :: [(Cosmic Location, Cosmic Location)]
|
||||
consistentPairs = map (fmap cosmoLocation) $ filter (enforceConsistency . snd) xs
|
||||
|
||||
interWorldPairs :: [(Cosmic Location, Cosmic Location)]
|
||||
interWorldPairs = filter (uncurry ((/=) `on` view subworld)) consistentPairs
|
||||
|
||||
normalizedOrdering :: [Signed (Cosmic Location, Cosmic Location)]
|
||||
normalizedOrdering = map normalizePairOrder interWorldPairs
|
||||
|
||||
normalizePairOrder :: (Cosmic a, Cosmic a) -> Signed (Cosmic a, Cosmic a)
|
||||
normalizePairOrder pair =
|
||||
if uncurry ((>) `on` view subworld) pair
|
||||
then Negative $ swap pair
|
||||
else Positive pair
|
||||
|
||||
tuplify :: (Cosmic a, Cosmic a) -> ((SubworldName, SubworldName), (a, a))
|
||||
tuplify = both (view subworld) &&& both (view planar)
|
||||
|
||||
getSigned :: Signed (V2 Int32) -> V2 Int32
|
||||
getSigned = \case
|
||||
Positive x -> x
|
||||
Negative x -> negated x
|
||||
|
||||
groupedBySubworldPair ::
|
||||
Map (SubworldName, SubworldName) (NonEmpty (Signed (Location, Location)))
|
||||
groupedBySubworldPair = binTuples $ map (sequenceSigned . fmap tuplify) normalizedOrdering
|
||||
|
||||
vectorized :: Map (SubworldName, SubworldName) (NonEmpty (V2 Int32))
|
||||
vectorized = M.map (NE.map (getSigned . fmap (uncurry (.-.)))) groupedBySubworldPair
|
||||
|
||||
nonUniform :: Map (SubworldName, SubworldName) (NonEmpty (V2 Int32))
|
||||
nonUniform = M.filter ((not . allEqual) . NE.toList) vectorized
|
||||
|
||||
-- |
|
||||
-- An implementation of 'sequenceA' for 'Signed' that does not
|
||||
-- require an 'Applicative' instance for the inner 'Functor'.
|
||||
--
|
||||
-- == Discussion
|
||||
-- Compare to the 'Traversable' instance of 'Signed':
|
||||
-- @
|
||||
-- instance Traversable Signed where
|
||||
-- traverse f (Positive x) = Positive <$> f x
|
||||
-- traverse f (Negative x) = Negative <$> f x
|
||||
-- @
|
||||
--
|
||||
-- if we were to substitute 'id' for f:
|
||||
-- @
|
||||
-- traverse id (Positive x) = Positive <$> id x
|
||||
-- traverse id (Negative x) = Negative <$> id x
|
||||
-- @
|
||||
-- our implementation essentially becomes @traverse id@.
|
||||
--
|
||||
-- However, we cannot simply write our implementation as @traverse id@, because
|
||||
-- the 'traverse' function has an 'Applicative' constraint, which is superfluous
|
||||
-- for our purpose.
|
||||
--
|
||||
-- Perhaps there is an opportunity to invent a typeclass for datatypes which
|
||||
-- consist exclusively of unary (or more ambitiously, non-nullary?) data constructors,
|
||||
-- for which a less-constrained 'sequence' function could be automatically derived.
|
||||
-- Compare to the 'Comonad' class and its 'extract' function.
|
||||
sequenceSigned ::
|
||||
Functor f =>
|
||||
Signed (f a) ->
|
||||
f (Signed a)
|
||||
sequenceSigned = \case
|
||||
Positive x -> Positive <$> x
|
||||
Negative x -> Negative <$> x
|
||||
|
@ -22,6 +22,7 @@ import Swarm.Game.Scenario.Topography.Cell
|
||||
import Swarm.Game.Scenario.Topography.Navigation.Waypoint
|
||||
import Swarm.Game.Scenario.Topography.Placement
|
||||
import Swarm.Game.Scenario.Topography.WorldPalette
|
||||
import Swarm.Util (failT, showT)
|
||||
import Swarm.Util.Yaml
|
||||
import Witch (into)
|
||||
|
||||
@ -31,11 +32,13 @@ data NamedStructure c = NamedStructure
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
type InheritedStructureDefs = [NamedStructure (Maybe (PCell Entity))]
|
||||
|
||||
instance FromJSONE (EntityMap, RobotMap) (NamedStructure (Maybe (PCell Entity))) where
|
||||
parseJSONE = withObjectE "named structure" $ \v -> do
|
||||
sName <- liftE $ v .: "name"
|
||||
NamedStructure sName
|
||||
<$> v
|
||||
NamedStructure
|
||||
<$> liftE (v .: "name")
|
||||
<*> v
|
||||
..: "structure"
|
||||
|
||||
data PStructure c = Structure
|
||||
@ -111,12 +114,12 @@ mergeStructures inheritedStrucDefs parentPlacement (Structure origArea subStruct
|
||||
instance FromJSONE (EntityMap, RobotMap) (PStructure (Maybe (PCell Entity))) where
|
||||
parseJSONE = withObjectE "structure definition" $ \v -> do
|
||||
pal <- v ..:? "palette" ..!= WorldPalette mempty
|
||||
structureDefs <- v ..:? "structures" ..!= []
|
||||
localStructureDefs <- v ..:? "structures" ..!= []
|
||||
placementDefs <- liftE $ v .:? "placements" .!= []
|
||||
waypointDefs <- liftE $ v .:? "waypoints" .!= []
|
||||
maybeMaskChar <- liftE $ v .:? "mask"
|
||||
(maskedArea, mapWaypoints) <- liftE $ (v .:? "map" .!= "") >>= paintMap maybeMaskChar pal
|
||||
return $ Structure maskedArea structureDefs placementDefs $ waypointDefs <> mapWaypoints
|
||||
return $ Structure maskedArea localStructureDefs placementDefs $ waypointDefs <> mapWaypoints
|
||||
|
||||
-- | "Paint" a world map using a 'WorldPalette', turning it from a raw
|
||||
-- string into a nested list of 'Cell' values by looking up each
|
||||
@ -142,7 +145,7 @@ paintMap maskChar pal a = do
|
||||
if Just c == maskChar
|
||||
then return Nothing
|
||||
else case KeyMap.lookup (Key.fromString [c]) (unPalette pal) of
|
||||
Nothing -> fail $ "Char not in world palette: " ++ show c
|
||||
Nothing -> failT ["Char not in world palette:", showT c]
|
||||
Just cell -> return $ Just cell
|
||||
|
||||
readMap :: Applicative f => (Char -> f b) -> Text -> f [[b]]
|
||||
|
@ -5,7 +5,7 @@
|
||||
-- SPDX-License-Identifier: BSD-3-Clause
|
||||
module Swarm.Game.Scenario.Topography.WorldDescription where
|
||||
|
||||
import Data.Coerce
|
||||
import Data.Functor.Identity
|
||||
import Data.Maybe (catMaybes)
|
||||
import Data.Yaml as Y
|
||||
import Swarm.Game.Entity
|
||||
@ -14,8 +14,13 @@ import Swarm.Game.Scenario.RobotLookup
|
||||
import Swarm.Game.Scenario.Topography.Cell
|
||||
import Swarm.Game.Scenario.Topography.EntityFacade
|
||||
import Swarm.Game.Scenario.Topography.Navigation.Portal
|
||||
import Swarm.Game.Scenario.Topography.Navigation.Waypoint (
|
||||
WaypointName,
|
||||
)
|
||||
import Swarm.Game.Scenario.Topography.Structure (InheritedStructureDefs, MergedStructure (MergedStructure), PStructure (Structure))
|
||||
import Swarm.Game.Scenario.Topography.Structure qualified as Structure
|
||||
import Swarm.Game.Scenario.Topography.WorldPalette
|
||||
import Swarm.Game.Universe
|
||||
import Swarm.Util.Yaml
|
||||
|
||||
------------------------------------------------------------
|
||||
@ -32,36 +37,49 @@ data PWorldDescription e = WorldDescription
|
||||
, palette :: WorldPalette e
|
||||
, ul :: Location
|
||||
, area :: [[PCell e]]
|
||||
, navigation :: Navigation
|
||||
, navigation :: Navigation Identity WaypointName
|
||||
, worldName :: SubworldName
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
type WorldDescription = PWorldDescription Entity
|
||||
|
||||
instance FromJSONE (EntityMap, RobotMap) WorldDescription where
|
||||
instance FromJSONE (InheritedStructureDefs, (EntityMap, RobotMap)) WorldDescription where
|
||||
parseJSONE = withObjectE "world description" $ \v -> do
|
||||
(scenarioLevelStructureDefs, (em, rm)) <- getE
|
||||
(pal, terr, rootWorldStructureDefs) <- localE (const (em, rm)) $ do
|
||||
pal <- v ..:? "palette" ..!= WorldPalette mempty
|
||||
structureDefs <- v ..:? "structures" ..!= []
|
||||
terr <- v ..:? "default"
|
||||
rootWorldStructs <- v ..:? "structures" ..!= []
|
||||
return (pal, terr, rootWorldStructs)
|
||||
|
||||
waypointDefs <- liftE $ v .:? "waypoints" .!= []
|
||||
portalDefs <- liftE $ v .:? "portals" .!= []
|
||||
placementDefs <- liftE $ v .:? "placements" .!= []
|
||||
(initialArea, mapWaypoints) <- liftE ((v .:? "map" .!= "") >>= Structure.paintMap Nothing pal)
|
||||
|
||||
upperLeft <- liftE (v .:? "upperleft" .!= origin)
|
||||
subWorldName <- liftE (v .:? "name" .!= DefaultRootSubworld)
|
||||
|
||||
let struc = Structure.Structure initialArea structureDefs placementDefs $ waypointDefs <> mapWaypoints
|
||||
Structure.MergedStructure mergedArea unmergedWaypoints = Structure.mergeStructures mempty Nothing struc
|
||||
let initialStructureDefs = scenarioLevelStructureDefs <> rootWorldStructureDefs
|
||||
struc = Structure initialArea initialStructureDefs placementDefs $ waypointDefs <> mapWaypoints
|
||||
MergedStructure mergedArea unmergedWaypoints = Structure.mergeStructures mempty Nothing struc
|
||||
|
||||
validatedLandmarks <- validateNavigation (coerce upperLeft) unmergedWaypoints portalDefs
|
||||
validatedNavigation <-
|
||||
validatePartialNavigation
|
||||
subWorldName
|
||||
upperLeft
|
||||
unmergedWaypoints
|
||||
portalDefs
|
||||
|
||||
WorldDescription
|
||||
<$> v ..:? "default"
|
||||
<*> liftE (v .:? "offset" .!= False)
|
||||
WorldDescription terr
|
||||
<$> liftE (v .:? "offset" .!= False)
|
||||
<*> liftE (v .:? "scrollable" .!= True)
|
||||
<*> pure pal
|
||||
<*> pure upperLeft
|
||||
<*> pure (map catMaybes mergedArea) -- Root-level map has no transparent cells.
|
||||
<*> pure validatedLandmarks
|
||||
<*> pure validatedNavigation
|
||||
<*> pure subWorldName
|
||||
|
||||
------------------------------------------------------------
|
||||
-- World editor
|
||||
|
@ -61,7 +61,7 @@ module Swarm.Game.State (
|
||||
currentScenarioPath,
|
||||
knownEntities,
|
||||
worldNavigation,
|
||||
world,
|
||||
multiWorld,
|
||||
worldScrollable,
|
||||
viewCenterRule,
|
||||
viewCenter,
|
||||
@ -107,6 +107,7 @@ module Swarm.Game.State (
|
||||
focusedRange,
|
||||
clearFocusedRobotLogUpdated,
|
||||
addRobot,
|
||||
addRobotToLocation,
|
||||
addTRobot,
|
||||
emitMessage,
|
||||
wakeWatchingRobots,
|
||||
@ -114,6 +115,7 @@ module Swarm.Game.State (
|
||||
sleepForever,
|
||||
wakeUpRobotsDoneSleeping,
|
||||
deleteRobot,
|
||||
removeRobotFromLocationMap,
|
||||
activateRobot,
|
||||
toggleRunStatus,
|
||||
messageIsRecent,
|
||||
@ -174,6 +176,7 @@ import Swarm.Game.Scenario.Status
|
||||
import Swarm.Game.Scenario.Topography.Navigation.Portal (Navigation (..))
|
||||
import Swarm.Game.ScenarioInfo
|
||||
import Swarm.Game.Terrain (TerrainType (..))
|
||||
import Swarm.Game.Universe as U
|
||||
import Swarm.Game.World (Coords (..), WorldFun (..), locToCoords, worldFunFromArray)
|
||||
import Swarm.Game.World qualified as W
|
||||
import Swarm.Game.WorldGen (Seed, findGoodOrigin, testWorld2FromArray)
|
||||
@ -185,7 +188,7 @@ import Swarm.Language.Syntax (Const, SrcLoc (..), Syntax' (..), allConst)
|
||||
import Swarm.Language.Typed (Typed (Typed))
|
||||
import Swarm.Language.Types
|
||||
import Swarm.Language.Value (Value)
|
||||
import Swarm.Util (uniq, (<+=), (<<.=), (?))
|
||||
import Swarm.Util (binTuples, surfaceEmpty, uniq, (<+=), (<<.=), (?))
|
||||
import Swarm.Util.Lens (makeLensesExcluding)
|
||||
import System.Clock qualified as Clock
|
||||
import System.Random (StdGen, mkStdGen, randomRIO)
|
||||
@ -198,7 +201,7 @@ import System.Random (StdGen, mkStdGen, randomRIO)
|
||||
-- world viewport.
|
||||
data ViewCenterRule
|
||||
= -- | The view should be centered on an absolute position.
|
||||
VCLocation Location
|
||||
VCLocation (Cosmic Location)
|
||||
| -- | The view should be centered on a certain robot.
|
||||
VCRobot RID
|
||||
deriving (Eq, Ord, Show, Generic, FromJSON, ToJSON)
|
||||
@ -381,11 +384,11 @@ data GameState = GameState
|
||||
-- Waiting robots for a given time are a list because it is cheaper to
|
||||
-- prepend to a list than insert into a Set.
|
||||
_waitingRobots :: Map TickNumber [RID]
|
||||
, _robotsByLocation :: Map Location IntSet
|
||||
, _robotsByLocation :: Map SubworldName (Map Location IntSet)
|
||||
, -- This member exists as an optimization so
|
||||
-- that we do not have to iterate over all "waiting" robots,
|
||||
-- since there may be many.
|
||||
_robotsWatching :: Map Location (S.Set RID)
|
||||
_robotsWatching :: Map (Cosmic Location) (S.Set RID)
|
||||
, _allDiscoveredEntities :: Inventory
|
||||
, _availableRecipes :: Notifications (Recipe Entity)
|
||||
, _availableCommands :: Notifications Const
|
||||
@ -401,11 +404,11 @@ data GameState = GameState
|
||||
, _recipesReq :: IntMap [Recipe Entity]
|
||||
, _currentScenarioPath :: Maybe FilePath
|
||||
, _knownEntities :: [Text]
|
||||
, _worldNavigation :: Navigation
|
||||
, _world :: W.World Int Entity
|
||||
, _worldNavigation :: Navigation (M.Map SubworldName) Location
|
||||
, _multiWorld :: W.MultiWorld Int Entity
|
||||
, _worldScrollable :: Bool
|
||||
, _viewCenterRule :: ViewCenterRule
|
||||
, _viewCenter :: Location
|
||||
, _viewCenter :: Cosmic Location
|
||||
, _needsRedraw :: Bool
|
||||
, _replStatus :: REPLStatus
|
||||
, _replNextValueIndex :: Integer
|
||||
@ -473,28 +476,32 @@ robotMap :: Lens' GameState (IntMap Robot)
|
||||
-- location of a robot changes, or a robot is created or destroyed.
|
||||
-- Fortunately, there are relatively few ways for these things to
|
||||
-- happen.
|
||||
robotsByLocation :: Lens' GameState (Map Location IntSet)
|
||||
robotsByLocation :: Lens' GameState (Map SubworldName (Map Location IntSet))
|
||||
|
||||
-- | Get a list of all the robots at a particular location.
|
||||
robotsAtLocation :: Location -> GameState -> [Robot]
|
||||
robotsAtLocation :: Cosmic Location -> GameState -> [Robot]
|
||||
robotsAtLocation loc gs =
|
||||
mapMaybe (`IM.lookup` (gs ^. robotMap))
|
||||
. maybe [] IS.toList
|
||||
. M.lookup loc
|
||||
. M.lookup (loc ^. planar)
|
||||
. M.findWithDefault mempty (loc ^. subworld)
|
||||
. view robotsByLocation
|
||||
$ gs
|
||||
|
||||
-- | Get a list of all the robots that are "watching" by location.
|
||||
robotsWatching :: Lens' GameState (Map Location (S.Set RID))
|
||||
-- | Get a list of all the robots that are \"watching\" by location.
|
||||
robotsWatching :: Lens' GameState (Map (Cosmic Location) (S.Set RID))
|
||||
|
||||
-- | Get all the robots within a given Manhattan distance from a
|
||||
-- location.
|
||||
robotsInArea :: Location -> Int32 -> GameState -> [Robot]
|
||||
robotsInArea o d gs = map (rm IM.!) rids
|
||||
robotsInArea :: Cosmic Location -> Int32 -> GameState -> [Robot]
|
||||
robotsInArea (Cosmic subworldName o) d gs = map (rm IM.!) rids
|
||||
where
|
||||
rm = gs ^. robotMap
|
||||
rl = gs ^. robotsByLocation
|
||||
rids = concatMap IS.elems $ getElemsInArea o d rl
|
||||
rids =
|
||||
concatMap IS.elems $
|
||||
getElemsInArea o d $
|
||||
M.findWithDefault mempty subworldName rl
|
||||
|
||||
-- | The base robot, if it exists.
|
||||
baseRobot :: Traversal' GameState Robot
|
||||
@ -559,19 +566,19 @@ recipesReq :: Lens' GameState (IntMap [Recipe Entity])
|
||||
-- see 'Swarm.Game.ScenarioInfo.scenarioItemByPath'.
|
||||
currentScenarioPath :: Lens' GameState (Maybe FilePath)
|
||||
|
||||
-- | The names of entities that should be considered "known", that is,
|
||||
-- | The names of entities that should be considered \"known\", that is,
|
||||
-- robots know what they are without having to scan them.
|
||||
knownEntities :: Lens' GameState [Text]
|
||||
|
||||
-- | Includes a Map of named locations and an
|
||||
-- | Includes a 'Map' of named locations and an
|
||||
-- "Edge list" (graph) that maps portal entrances to exits
|
||||
worldNavigation :: Lens' GameState Navigation
|
||||
worldNavigation :: Lens' GameState (Navigation (M.Map SubworldName) Location)
|
||||
|
||||
-- | The current state of the world (terrain and entities only; robots
|
||||
-- are stored in the 'robotMap'). Int is used instead of
|
||||
-- TerrainType because we need to be able to store terrain values in
|
||||
-- are stored in the 'robotMap'). 'Int' is used instead of
|
||||
-- 'TerrainType' because we need to be able to store terrain values in
|
||||
-- unboxed tile arrays.
|
||||
world :: Lens' GameState (W.World Int Entity)
|
||||
multiWorld :: Lens' GameState (W.MultiWorld Int Entity)
|
||||
|
||||
-- | Whether the world map is supposed to be scrollable or not.
|
||||
worldScrollable :: Lens' GameState Bool
|
||||
@ -580,7 +587,7 @@ worldScrollable :: Lens' GameState Bool
|
||||
-- modified directly, since it is calculated automatically from the
|
||||
-- 'viewCenterRule'. To modify the view center, either set the
|
||||
-- 'viewCenterRule', or use 'modifyViewCenter'.
|
||||
viewCenter :: Getter GameState Location
|
||||
viewCenter :: Getter GameState (Cosmic Location)
|
||||
viewCenter = to _viewCenter
|
||||
|
||||
-- | Whether the world view needs to be redrawn.
|
||||
@ -638,14 +645,14 @@ viewCenterRule = lens getter setter
|
||||
setter :: GameState -> ViewCenterRule -> GameState
|
||||
setter g rule =
|
||||
case rule of
|
||||
VCLocation v2 -> g {_viewCenterRule = rule, _viewCenter = v2}
|
||||
VCLocation loc -> g {_viewCenterRule = rule, _viewCenter = loc}
|
||||
VCRobot rid ->
|
||||
let robotcenter = g ^? robotMap . ix rid . robotLocation
|
||||
in -- retrieve the loc of the robot if it exists, Nothing otherwise.
|
||||
-- sometimes, lenses are amazing...
|
||||
case robotcenter of
|
||||
Nothing -> g
|
||||
Just v2 -> g {_viewCenterRule = rule, _viewCenter = v2, _focusedRobotID = rid}
|
||||
Just loc -> g {_viewCenterRule = rule, _viewCenter = loc, _focusedRobotID = rid}
|
||||
|
||||
-- | Whether the repl is currently working.
|
||||
replWorking :: Getter GameState Bool
|
||||
@ -686,14 +693,22 @@ messageNotifications = to getNotif
|
||||
messageIsRecent :: GameState -> LogEntry -> Bool
|
||||
messageIsRecent gs e = addTicks 1 (e ^. leTime) >= gs ^. ticks
|
||||
|
||||
messageIsFromNearby :: Location -> LogEntry -> Bool
|
||||
messageIsFromNearby l e = manhattan l (e ^. leLocation) <= hearingDistance
|
||||
-- | Reconciles the possibilities of log messages being
|
||||
-- omnipresent and robots being in different worlds
|
||||
messageIsFromNearby :: Cosmic Location -> LogEntry -> Bool
|
||||
messageIsFromNearby l e = case e ^. leLocation of
|
||||
Omnipresent -> True
|
||||
Located x -> f x
|
||||
where
|
||||
f logLoc = case cosmoMeasure manhattan l logLoc of
|
||||
InfinitelyFar -> False
|
||||
Measurable x -> x <= hearingDistance
|
||||
|
||||
-- | Given a current mapping from robot names to robots, apply a
|
||||
-- 'ViewCenterRule' to derive the location it refers to. The result
|
||||
-- is @Maybe@ because the rule may refer to a robot which does not
|
||||
-- is 'Maybe' because the rule may refer to a robot which does not
|
||||
-- exist.
|
||||
applyViewCenterRule :: ViewCenterRule -> IntMap Robot -> Maybe Location
|
||||
applyViewCenterRule :: ViewCenterRule -> IntMap Robot -> Maybe (Cosmic Location)
|
||||
applyViewCenterRule (VCLocation l) _ = Just l
|
||||
applyViewCenterRule (VCRobot name) m = m ^? at name . _Just . robotLocation
|
||||
|
||||
@ -710,13 +725,15 @@ recalcViewCenter g =
|
||||
& (if newViewCenter /= oldViewCenter then needsRedraw .~ True else id)
|
||||
where
|
||||
oldViewCenter = g ^. viewCenter
|
||||
newViewCenter = fromMaybe oldViewCenter (applyViewCenterRule (g ^. viewCenterRule) (g ^. robotMap))
|
||||
newViewCenter =
|
||||
fromMaybe oldViewCenter $
|
||||
applyViewCenterRule (g ^. viewCenterRule) (g ^. robotMap)
|
||||
|
||||
-- | Modify the 'viewCenter' by applying an arbitrary function to the
|
||||
-- current value. Note that this also modifies the 'viewCenterRule'
|
||||
-- to match. After calling this function the 'viewCenterRule' will
|
||||
-- specify a particular location, not a robot.
|
||||
modifyViewCenter :: (Location -> Location) -> GameState -> GameState
|
||||
modifyViewCenter :: (Cosmic Location -> Cosmic Location) -> GameState -> GameState
|
||||
modifyViewCenter update g =
|
||||
g
|
||||
& case g ^. viewCenterRule of
|
||||
@ -732,10 +749,10 @@ unfocus = (\g -> g {_focusedRobotID = -1000}) . modifyViewCenter id
|
||||
|
||||
-- | Given a width and height, compute the region, centered on the
|
||||
-- 'viewCenter', that should currently be in view.
|
||||
viewingRegion :: GameState -> (Int32, Int32) -> W.BoundsRectangle
|
||||
viewingRegion g (w, h) = (W.Coords (rmin, cmin), W.Coords (rmax, cmax))
|
||||
viewingRegion :: GameState -> (Int32, Int32) -> Cosmic W.BoundsRectangle
|
||||
viewingRegion g (w, h) = Cosmic sw (W.Coords (rmin, cmin), W.Coords (rmax, cmax))
|
||||
where
|
||||
Location cx cy = g ^. viewCenter
|
||||
Cosmic sw (Location cx cy) = g ^. viewCenter
|
||||
(rmin, rmax) = over both (+ (-cy - h `div` 2)) (0, h - 1)
|
||||
(cmin, cmax) = over both (+ (cx - w `div` 2)) (0, w - 1)
|
||||
|
||||
@ -775,17 +792,22 @@ data RobotRange
|
||||
-- both radii.
|
||||
-- * If the base has an @antenna@ installed, it also doubles both radii.
|
||||
focusedRange :: GameState -> Maybe RobotRange
|
||||
focusedRange g = computedRange <$ focusedRobot g
|
||||
focusedRange g = checkRange <$ focusedRobot g
|
||||
where
|
||||
computedRange
|
||||
| g ^. creativeMode || g ^. worldScrollable || r <= minRadius = Close
|
||||
| r > maxRadius = Far
|
||||
| otherwise = MidRange $ (r - minRadius) / (maxRadius - minRadius)
|
||||
checkRange = case r of
|
||||
InfinitelyFar -> Far
|
||||
Measurable r' -> computedRange r'
|
||||
|
||||
computedRange r'
|
||||
| g ^. creativeMode || g ^. worldScrollable || r' <= minRadius = Close
|
||||
| r' > maxRadius = Far
|
||||
| otherwise = MidRange $ (r' - minRadius) / (maxRadius - minRadius)
|
||||
|
||||
-- Euclidean distance from the base to the view center.
|
||||
r = case g ^. robotMap . at 0 of
|
||||
Just br -> euclidean (g ^. viewCenter) (br ^. robotLocation)
|
||||
_ -> 1000000000 -- if the base doesn't exist, we have bigger problems
|
||||
-- if the base doesn't exist, we have bigger problems
|
||||
Nothing -> InfinitelyFar
|
||||
Just br -> cosmoMeasure euclidean (g ^. viewCenter) (br ^. robotLocation)
|
||||
|
||||
-- See whether the base or focused robot have antennas installed.
|
||||
baseInv, focInv :: Maybe Inventory
|
||||
@ -827,10 +849,18 @@ addRobot r = do
|
||||
let rid = r ^. robotID
|
||||
|
||||
robotMap %= IM.insert rid r
|
||||
robotsByLocation
|
||||
%= M.insertWith IS.union (r ^. robotLocation) (IS.singleton rid)
|
||||
addRobotToLocation rid $ r ^. robotLocation
|
||||
internalActiveRobots %= IS.insert rid
|
||||
|
||||
-- | Helper function for updating the "robotsByLocation" bookkeeping
|
||||
addRobotToLocation :: (Has (State GameState) sig m) => RID -> Cosmic Location -> m ()
|
||||
addRobotToLocation rid rLoc =
|
||||
robotsByLocation
|
||||
%= M.insertWith
|
||||
(M.unionWith IS.union)
|
||||
(rLoc ^. subworld)
|
||||
(M.singleton (rLoc ^. planar) (IS.singleton rid))
|
||||
|
||||
maxMessageQueueSize :: Int
|
||||
maxMessageQueueSize = 1000
|
||||
|
||||
@ -889,7 +919,7 @@ clearWatchingRobots rids = do
|
||||
--
|
||||
-- NOTE: Clearing "TickNumber" map entries from "internalWaitingRobots"
|
||||
-- upon wakeup is handled by "wakeUpRobotsDoneSleeping" in State.hs
|
||||
wakeWatchingRobots :: (Has (State GameState) sig m) => Location -> m ()
|
||||
wakeWatchingRobots :: (Has (State GameState) sig m) => Cosmic Location -> m ()
|
||||
wakeWatchingRobots loc = do
|
||||
currentTick <- use ticks
|
||||
waitingMap <- use waitingRobots
|
||||
@ -948,7 +978,24 @@ deleteRobot rn = do
|
||||
mrobot <- robotMap . at rn <<.= Nothing
|
||||
mrobot `forM_` \robot -> do
|
||||
-- Delete the robot from the index of robots by location.
|
||||
robotsByLocation . ix (robot ^. robotLocation) %= IS.delete rn
|
||||
removeRobotFromLocationMap (robot ^. robotLocation) rn
|
||||
|
||||
-- | Makes sure empty sets don't hang around in the
|
||||
-- 'robotsByLocation' map. We don't want a key with an
|
||||
-- empty set at every location any robot has ever
|
||||
-- visited!
|
||||
removeRobotFromLocationMap ::
|
||||
(Has (State GameState) sig m) =>
|
||||
Cosmic Location ->
|
||||
RID ->
|
||||
m ()
|
||||
removeRobotFromLocationMap (Cosmic oldSubworld oldPlanar) rid =
|
||||
robotsByLocation %= M.update (tidyDelete rid) oldSubworld
|
||||
where
|
||||
deleteOne x = surfaceEmpty IS.null . IS.delete x
|
||||
|
||||
tidyDelete robID =
|
||||
surfaceEmpty M.null . M.update (deleteOne robID) oldPlanar
|
||||
|
||||
------------------------------------------------------------
|
||||
-- Initialization
|
||||
@ -1004,10 +1051,10 @@ initGameState gsc =
|
||||
, _currentScenarioPath = Nothing
|
||||
, _knownEntities = []
|
||||
, _worldNavigation = Navigation mempty mempty
|
||||
, _world = W.emptyWorld (fromEnum StoneT)
|
||||
, _multiWorld = mempty
|
||||
, _worldScrollable = True
|
||||
, _viewCenterRule = VCRobot 0
|
||||
, _viewCenter = origin
|
||||
, _viewCenter = defaultCosmicLocation
|
||||
, _needsRedraw = False
|
||||
, _replStatus = REPLDone Nothing
|
||||
, _replNextValueIndex = 0
|
||||
@ -1045,10 +1092,7 @@ scenarioToGameState scenario (LaunchParams (Identity userSeed) (Identity toRun))
|
||||
& winCondition .~ theWinCondition
|
||||
& winSolution .~ scenario ^. scenarioSolution
|
||||
& robotMap .~ IM.fromList (map (view robotID &&& id) robotList')
|
||||
& robotsByLocation
|
||||
.~ M.fromListWith
|
||||
IS.union
|
||||
(map (view robotLocation &&& (IS.singleton . view robotID)) robotList')
|
||||
& robotsByLocation .~ M.map (groupRobotsByPlanarLocation . NE.toList) (groupRobotsBySubworld robotList')
|
||||
& internalActiveRobots .~ setOf (traverse . robotID) robotList'
|
||||
& availableCommands .~ Notifications 0 initialCommands
|
||||
& gensym .~ initGensym
|
||||
@ -1060,9 +1104,12 @@ scenarioToGameState scenario (LaunchParams (Identity userSeed) (Identity toRun))
|
||||
& recipesIn %~ addRecipesWith inRecipeMap
|
||||
& recipesReq %~ addRecipesWith reqRecipeMap
|
||||
& knownEntities .~ scenario ^. scenarioKnown
|
||||
& worldNavigation .~ navigation (scenario ^. scenarioWorld)
|
||||
& world .~ theWorld theSeed
|
||||
& worldScrollable .~ scenario ^. scenarioWorld . to scrollable
|
||||
& worldNavigation .~ scenario ^. scenarioNavigation
|
||||
& multiWorld .~ allSubworldsMap theSeed
|
||||
-- TODO (#1370): Should we allow subworlds to have their own scrollability?
|
||||
-- Leaning toward no , but for now just adopt the root world scrollability
|
||||
-- as being universal.
|
||||
& worldScrollable .~ NE.head (scenario ^. scenarioWorlds) ^. to scrollable
|
||||
& viewCenterRule .~ VCRobot baseID
|
||||
& replStatus .~ case running of -- When the base starts out running a program, the REPL status must be set to working,
|
||||
-- otherwise the store of definition cells is not saved (see #333, #838)
|
||||
@ -1070,6 +1117,14 @@ scenarioToGameState scenario (LaunchParams (Identity userSeed) (Identity toRun))
|
||||
True -> REPLWorking (Typed Nothing PolyUnit mempty)
|
||||
& robotStepsPerTick .~ ((scenario ^. scenarioStepsPerTick) ? defaultRobotStepsPerTick)
|
||||
where
|
||||
groupRobotsBySubworld =
|
||||
binTuples . map (view (robotLocation . subworld) &&& id)
|
||||
|
||||
groupRobotsByPlanarLocation rs =
|
||||
M.fromListWith
|
||||
IS.union
|
||||
(map (view (robotLocation . planar) &&& (IS.singleton . view robotID)) rs)
|
||||
|
||||
em = initEntities gsc <> scenario ^. scenarioEntities
|
||||
baseID = 0
|
||||
(things, devices) = partition (null . view entityCapabilities) (M.elems (entitiesByName em))
|
||||
@ -1100,7 +1155,12 @@ scenarioToGameState scenario (LaunchParams (Identity userSeed) (Identity toRun))
|
||||
-- 2.a. If multiple robots are specified in the map, prefer the one that
|
||||
-- is defined first within the Scenario file.
|
||||
-- 2.b. If multiple robots are instantiated from the same template, then
|
||||
-- prefer the one closest to the upper-left of the screen, with higher rows given precedence over columns.
|
||||
-- prefer the one with a lower-indexed subworld. Note that the root
|
||||
-- subworld is always first.
|
||||
-- 2.c. If multiple robots instantiated from the same template are in the
|
||||
-- same subworld, then
|
||||
-- prefer the one closest to the upper-left of the screen, with higher
|
||||
-- rows given precedence over columns (i.e. first in row-major order).
|
||||
robotsByBasePrecedence = locatedRobots ++ map snd (sortOn fst genRobots)
|
||||
|
||||
initialCodeToRun = getCodeToRun <$> toRun
|
||||
@ -1145,8 +1205,23 @@ scenarioToGameState scenario (LaunchParams (Identity userSeed) (Identity toRun))
|
||||
(maybe True (`S.member` initialCaps) . constCaps)
|
||||
allConst
|
||||
|
||||
(genRobots, wf) = buildWorld em (scenario ^. scenarioWorld)
|
||||
theWorld = W.newWorld . wf
|
||||
-- Subworld order as encountered in the scenario YAML file is preserved for
|
||||
-- the purpose of numbering robots, other than the "root" subworld
|
||||
-- guaranteed to be first.
|
||||
genRobots = concat $ NE.toList $ NE.map (fst . snd) builtWorldTuples
|
||||
|
||||
builtWorldTuples =
|
||||
NE.map (worldName &&& buildWorld em) $
|
||||
scenario ^. scenarioWorlds
|
||||
|
||||
allSubworldsMap s =
|
||||
M.map genWorld
|
||||
. M.fromList
|
||||
. NE.toList
|
||||
$ builtWorldTuples
|
||||
where
|
||||
genWorld x = W.newWorld $ snd x s
|
||||
|
||||
theWinCondition =
|
||||
maybe
|
||||
NoWinCondition
|
||||
@ -1159,7 +1234,7 @@ scenarioToGameState scenario (LaunchParams (Identity userSeed) (Identity toRun))
|
||||
-- | Take a world description, parsed from a scenario file, and turn
|
||||
-- it into a list of located robots and a world function.
|
||||
buildWorld :: EntityMap -> WorldDescription -> ([IndexedTRobot], Seed -> WorldFun Int Entity)
|
||||
buildWorld em WorldDescription {..} = (robots, first fromEnum . wf)
|
||||
buildWorld em WorldDescription {..} = (robots worldName, first fromEnum . wf)
|
||||
where
|
||||
rs = fromIntegral $ length area
|
||||
cs = fromIntegral $ length (head area)
|
||||
@ -1177,13 +1252,13 @@ buildWorld em WorldDescription {..} = (robots, first fromEnum . wf)
|
||||
Just (Cell t e _) -> const (worldFunFromArray worldArray (t, e))
|
||||
|
||||
-- Get all the robots described in cells and set their locations appropriately
|
||||
robots :: [IndexedTRobot]
|
||||
robots =
|
||||
robots :: SubworldName -> [IndexedTRobot]
|
||||
robots swName =
|
||||
area
|
||||
& traversed Control.Lens.<.> traversed %@~ (,) -- add (r,c) indices
|
||||
& concat
|
||||
& concatMap
|
||||
( \((fromIntegral -> r, fromIntegral -> c), Cell _ _ robotList) ->
|
||||
let robotWithLoc = trobotLocation ?~ W.coordsToLoc (Coords (ulr + r, ulc + c))
|
||||
let robotWithLoc = trobotLocation ?~ Cosmic swName (W.coordsToLoc (Coords (ulr + r, ulc + c)))
|
||||
in map (fmap robotWithLoc) robotList
|
||||
)
|
||||
|
@ -30,7 +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, msum, unless, when, zipWithM)
|
||||
import Control.Monad (foldM, forM, forM_, guard, join, msum, unless, when, zipWithM)
|
||||
import Control.Monad.Except (runExceptT)
|
||||
import Data.Array (bounds, (!))
|
||||
import Data.Bifunctor (second)
|
||||
@ -75,9 +75,10 @@ import Swarm.Game.ResourceLoading (getDataFileNameSafe)
|
||||
import Swarm.Game.Robot
|
||||
import Swarm.Game.Scenario.Objective qualified as OB
|
||||
import Swarm.Game.Scenario.Objective.WinCheck qualified as WC
|
||||
import Swarm.Game.Scenario.Topography.Navigation.Portal (Navigation (..))
|
||||
import Swarm.Game.Scenario.Topography.Navigation.Portal (Navigation (..), cosmoLocation)
|
||||
import Swarm.Game.Scenario.Topography.Navigation.Waypoint (WaypointName (..))
|
||||
import Swarm.Game.State
|
||||
import Swarm.Game.Universe
|
||||
import Swarm.Game.Value
|
||||
import Swarm.Game.World qualified as W
|
||||
import Swarm.Language.Capability
|
||||
@ -378,7 +379,20 @@ getNow = sendIO $ System.Clock.getTime System.Clock.Monotonic
|
||||
--
|
||||
-- Use ID (-1) so it won't conflict with any robots currently in the robot map.
|
||||
hypotheticalRobot :: CESK -> TimeSpec -> Robot
|
||||
hypotheticalRobot c = mkRobot (-1) Nothing "hypothesis" [] zero zero defaultRobotDisplay c [] [] True False
|
||||
hypotheticalRobot c =
|
||||
mkRobot
|
||||
(-1)
|
||||
Nothing
|
||||
"hypothesis"
|
||||
[]
|
||||
defaultCosmicLocation
|
||||
zero
|
||||
defaultRobotDisplay
|
||||
c
|
||||
[]
|
||||
[]
|
||||
True
|
||||
False
|
||||
|
||||
evaluateCESK ::
|
||||
(Has (Lift IO) sig m, Has (Throw Exn) sig m, Has (State GameState) sig m) =>
|
||||
@ -413,24 +427,36 @@ 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) => StateC (W.World Int Entity) Identity b -> m b
|
||||
zoomWorld n = do
|
||||
w <- use world
|
||||
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)
|
||||
world .= w'
|
||||
multiWorld %= M.insert swName w'
|
||||
return a
|
||||
|
||||
-- | Get the entity (if any) at a given location.
|
||||
entityAt :: (Has (State GameState) sig m) => Location -> m (Maybe Entity)
|
||||
entityAt loc = zoomWorld (W.lookupEntityM @Int (W.locToCoords loc))
|
||||
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) => Location -> (Maybe Entity -> Maybe Entity) -> m ()
|
||||
updateEntityAt loc upd = do
|
||||
didChange <- zoomWorld $ W.updateM @Int (W.locToCoords loc) upd
|
||||
(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 loc
|
||||
wakeWatchingRobots cLoc
|
||||
|
||||
-- | Get the robot with a given ID.
|
||||
robotWithID :: (Has (State GameState) sig m) => RID -> m (Maybe Robot)
|
||||
@ -483,13 +509,17 @@ randomName = do
|
||||
-- | Create a log entry given current robot and game time in ticks noting whether it has been said.
|
||||
--
|
||||
-- This is the more generic version used both for (recorded) said messages and normal logs.
|
||||
createLogEntry :: (Has (State GameState) sig m, Has (State Robot) sig m) => LogSource -> Text -> m LogEntry
|
||||
createLogEntry ::
|
||||
(Has (State GameState) sig m, Has (State Robot) sig m) =>
|
||||
LogSource ->
|
||||
Text ->
|
||||
m LogEntry
|
||||
createLogEntry source msg = do
|
||||
rid <- use robotID
|
||||
rn <- use robotName
|
||||
time <- use ticks
|
||||
loc <- use robotLocation
|
||||
pure $ LogEntry time source rn rid loc msg
|
||||
pure $ LogEntry time source rn rid (Located loc) msg
|
||||
|
||||
-- | Print some text via the robot's log.
|
||||
traceLog :: (Has (State GameState) sig m, Has (State Robot) sig m) => LogSource -> Text -> m LogEntry
|
||||
@ -608,8 +638,8 @@ updateWorld ::
|
||||
WorldUpdate Entity ->
|
||||
m ()
|
||||
updateWorld c (ReplaceEntity loc eThen down) = do
|
||||
w <- use world
|
||||
let eNow = W.lookupEntity (W.locToCoords loc) w
|
||||
w <- use multiWorld
|
||||
let eNow = W.lookupCosmicEntity (fmap W.locToCoords loc) w
|
||||
-- Can fail if a robot started a multi-tick "drill" operation on some entity
|
||||
-- and meanwhile another entity swaps it out from under them.
|
||||
if Just eThen /= eNow
|
||||
@ -1034,7 +1064,13 @@ seedProgram minTime randTime thing =
|
||||
-- | Construct a "seed robot" from entity, time range and position,
|
||||
-- and add it to the world. It has low priority and will be covered
|
||||
-- by placed entities.
|
||||
addSeedBot :: Has (State GameState) sig m => Entity -> (Integer, Integer) -> Location -> TimeSpec -> m ()
|
||||
addSeedBot ::
|
||||
Has (State GameState) sig m =>
|
||||
Entity ->
|
||||
(Integer, Integer) ->
|
||||
Cosmic Location ->
|
||||
TimeSpec ->
|
||||
m ()
|
||||
addSeedBot e (minT, maxT) loc ts =
|
||||
void $
|
||||
addTRobot $
|
||||
@ -1095,7 +1131,7 @@ execConst c vs s k = do
|
||||
-- Figure out where we're going
|
||||
loc <- use robotLocation
|
||||
orient <- use robotOrientation
|
||||
let nextLoc = loc .+^ (orient ? zero)
|
||||
let nextLoc = loc `offsetBy` (orient ? zero)
|
||||
checkMoveAhead nextLoc $
|
||||
MoveFailure
|
||||
{ failIfBlocked = ThrowExn
|
||||
@ -1107,9 +1143,9 @@ execConst c vs s k = do
|
||||
-- Figure out where we're going
|
||||
loc <- use robotLocation
|
||||
orient <- use robotOrientation
|
||||
let heading = orient ? zero
|
||||
nextLoc = loc .+^ heading
|
||||
placementLoc = nextLoc .+^ heading
|
||||
let applyHeading = (`offsetBy` (orient ? zero))
|
||||
nextLoc = applyHeading loc
|
||||
placementLoc = applyHeading nextLoc
|
||||
|
||||
-- If unobstructed, the robot will move even if
|
||||
-- there is nothing to push.
|
||||
@ -1153,11 +1189,11 @@ execConst c vs s k = do
|
||||
let heading = orient ? zero
|
||||
|
||||
-- Excludes the base location.
|
||||
let locsInDirection :: [Location]
|
||||
let locsInDirection :: [Cosmic Location]
|
||||
locsInDirection =
|
||||
take (min (fromIntegral d) maxStrideRange) $
|
||||
drop 1 $
|
||||
iterate (.+^ heading) loc
|
||||
iterate (`offsetBy` heading) loc
|
||||
|
||||
failureMaybes <- mapM checkMoveFailure locsInDirection
|
||||
let maybeFirstFailure = asum failureMaybes
|
||||
@ -1182,7 +1218,7 @@ execConst c vs s k = do
|
||||
target <- getRobotWithinTouch rid
|
||||
-- either change current robot or one in robot map
|
||||
let oldLoc = target ^. robotLocation
|
||||
nextLoc = Location (fromIntegral x) (fromIntegral y)
|
||||
nextLoc = fmap (const $ Location (fromIntegral x) (fromIntegral y)) oldLoc
|
||||
|
||||
onTarget rid $ do
|
||||
checkMoveAhead nextLoc $
|
||||
@ -1364,24 +1400,26 @@ execConst c vs s k = do
|
||||
selfRid <- use robotID
|
||||
|
||||
-- Includes the base location, so we exclude the base robot later.
|
||||
let locsInDirection :: [Location]
|
||||
locsInDirection = take maxScoutRange $ iterate (.+^ heading) myLoc
|
||||
let locsInDirection :: [Cosmic Location]
|
||||
locsInDirection = take maxScoutRange $ iterate (`offsetBy` heading) myLoc
|
||||
|
||||
let hasOpaqueEntity =
|
||||
fmap (maybe False (`hasProperty` E.Opaque)) . entityAt
|
||||
|
||||
let hasVisibleBot :: Location -> Bool
|
||||
let hasVisibleBot :: Cosmic Location -> Bool
|
||||
hasVisibleBot = any botIsVisible . IS.toList . excludeSelf . botsHere
|
||||
where
|
||||
excludeSelf = (`IS.difference` IS.singleton selfRid)
|
||||
botsHere loc = M.findWithDefault mempty loc botsByLocs
|
||||
botsHere (Cosmic swName loc) =
|
||||
M.findWithDefault mempty loc $
|
||||
M.findWithDefault mempty swName botsByLocs
|
||||
botIsVisible = maybe False canSee . (`IM.lookup` rMap)
|
||||
canSee = not . (^. robotDisplay . invisible)
|
||||
|
||||
-- A robot on the same cell as an opaque entity is considered hidden.
|
||||
-- Returns (Just Bool) if the result is conclusively visible or opaque,
|
||||
-- or Nothing if we don't have a conclusive answer yet.
|
||||
let isConclusivelyVisible :: Bool -> Location -> Maybe Bool
|
||||
let isConclusivelyVisible :: Bool -> Cosmic Location -> Maybe Bool
|
||||
isConclusivelyVisible isOpaque loc
|
||||
| isOpaque = Just False
|
||||
| hasVisibleBot loc = Just True
|
||||
@ -1400,11 +1438,12 @@ execConst c vs s k = do
|
||||
_ -> badConst
|
||||
Whereami -> do
|
||||
loc <- use robotLocation
|
||||
return $ Out (asValue loc) s k
|
||||
return $ Out (asValue $ loc ^. planar) s k
|
||||
Waypoint -> case vs of
|
||||
[VText name, VInt idx] -> do
|
||||
lm <- use worldNavigation
|
||||
case M.lookup (WaypointName name) (waypoints lm) of
|
||||
Cosmic swName _ <- use robotLocation
|
||||
case M.lookup (WaypointName name) $ M.findWithDefault mempty swName $ waypoints lm of
|
||||
Nothing -> throwError $ CmdFailed Waypoint (T.unwords ["No waypoint named", name]) Nothing
|
||||
Just wps -> return $ Out (asValue (NE.length wps, indexWrapNonEmpty wps idx)) s k
|
||||
_ -> badConst
|
||||
@ -1413,8 +1452,9 @@ execConst c vs s k = do
|
||||
loc <- use robotLocation
|
||||
let locs = rectCells x1 y1 x2 y2
|
||||
-- sort offsets by (Manhattan) distance so that we return the closest occurrence
|
||||
let sortedLocs = sortOn (\(V2 x y) -> abs x + abs y) locs
|
||||
firstOne <- findM (fmap (maybe False $ isEntityNamed name) . entityAt . (loc .+^)) sortedLocs
|
||||
let sortedOffsets = sortOn (\(V2 x y) -> abs x + abs y) locs
|
||||
let f = fmap (maybe False $ isEntityNamed name) . entityAt . offsetBy loc
|
||||
firstOne <- findM f sortedOffsets
|
||||
return $ Out (asValue firstOne) s k
|
||||
_ -> badConst
|
||||
Resonate -> case vs of
|
||||
@ -1436,7 +1476,8 @@ execConst c vs s k = do
|
||||
_ -> badConst
|
||||
Surveil -> case vs of
|
||||
[VPair (VInt x) (VInt y)] -> do
|
||||
let loc = Location (fromIntegral x) (fromIntegral y)
|
||||
Cosmic swName _ <- use robotLocation
|
||||
let loc = Cosmic swName $ Location (fromIntegral x) (fromIntegral y)
|
||||
addWatchedLocation loc
|
||||
return $ Out VUnit s k
|
||||
_ -> badConst
|
||||
@ -1485,7 +1526,7 @@ execConst c vs s k = do
|
||||
Blocked -> do
|
||||
loc <- use robotLocation
|
||||
orient <- use robotOrientation
|
||||
let nextLoc = loc .+^ (orient ? zero)
|
||||
let nextLoc = loc `offsetBy` (orient ? zero)
|
||||
me <- entityAt nextLoc
|
||||
return $ Out (VBool (maybe False (`hasProperty` Unwalkable) me)) s k
|
||||
Scan -> case vs of
|
||||
@ -1576,12 +1617,18 @@ execConst c vs s k = do
|
||||
loc <- use robotLocation
|
||||
m <- traceLog Said msg -- current robot will inserted to robot set, so it needs the log
|
||||
emitMessage m
|
||||
let addLatestClosest rl = \case
|
||||
let measureToLog robLoc rawLogLoc = case rawLogLoc of
|
||||
Located logLoc -> cosmoMeasure manhattan robLoc logLoc
|
||||
Omnipresent -> Measurable 0
|
||||
addLatestClosest rl = \case
|
||||
Seq.Empty -> Seq.singleton m
|
||||
es Seq.:|> e
|
||||
| e ^. leTime < m ^. leTime -> es |> e |> m
|
||||
| manhattan rl (e ^. leLocation) > manhattan rl (m ^. leLocation) -> es |> m
|
||||
| e `isEarlierThan` m -> es |> e |> m
|
||||
| e `isFartherThan` m -> es |> m
|
||||
| otherwise -> es |> e
|
||||
where
|
||||
isEarlierThan = (<) `on` (^. leTime)
|
||||
isFartherThan = (>) `on` (measureToLog rl . view leLocation)
|
||||
let addToRobotLog :: Has (State GameState) sgn m => Robot -> m ()
|
||||
addToRobotLog r = do
|
||||
maybeRidLoc <- evalState r $ do
|
||||
@ -1729,7 +1776,7 @@ execConst c vs s k = do
|
||||
g <- get @GameState
|
||||
let neighbor =
|
||||
find ((/= rid) . (^. robotID)) -- pick one other than ourself
|
||||
. sortOn (manhattan loc . (^. robotLocation)) -- prefer closer
|
||||
. sortOn ((manhattan `on` view planar) loc . (^. robotLocation)) -- prefer closer
|
||||
$ robotsInArea loc 1 g -- all robots within Manhattan distance 1
|
||||
return $ Out (asValue neighbor) s k
|
||||
MeetAll -> case vs of
|
||||
@ -1840,7 +1887,8 @@ execConst c vs s k = do
|
||||
-- a robot can program adjacent robots
|
||||
-- privileged bots ignore distance checks
|
||||
loc <- use robotLocation
|
||||
(isPrivileged || (childRobot ^. robotLocation) `manhattan` loc <= 1)
|
||||
|
||||
isNearbyOrExempt isPrivileged loc (childRobot ^. robotLocation)
|
||||
`holdsOrFail` ["You can only reprogram an adjacent robot."]
|
||||
|
||||
-- Figure out if we can supply what the target robot requires,
|
||||
@ -2177,8 +2225,8 @@ execConst c vs s k = do
|
||||
m CESK
|
||||
doResonate p x1 y1 x2 y2 = do
|
||||
loc <- use robotLocation
|
||||
let locs = rectCells x1 y1 x2 y2
|
||||
hits <- mapM (fmap (fromEnum . p) . entityAt . (loc .+^)) locs
|
||||
let offsets = rectCells x1 y1 x2 y2
|
||||
hits <- mapM (fmap (fromEnum . p) . entityAt . offsetBy loc) offsets
|
||||
return $ Out (VInt $ fromIntegral $ sum hits) s k
|
||||
|
||||
rectCells :: Integer -> Integer -> Integer -> Integer -> [V2 Int32]
|
||||
@ -2201,10 +2249,11 @@ execConst c vs s k = do
|
||||
m (Maybe (Int32, V2 Int32))
|
||||
findNearest name = do
|
||||
loc <- use robotLocation
|
||||
findM (fmap (maybe False $ isEntityNamed name) . entityAt . (loc .+^) . snd) sortedLocs
|
||||
let f = fmap (maybe False $ isEntityNamed name) . entityAt . offsetBy loc . snd
|
||||
findM f sortedOffsets
|
||||
where
|
||||
sortedLocs :: [(Int32, V2 Int32)]
|
||||
sortedLocs = (0, zero) : concatMap genDiamondSides [1 .. maxSniffRange]
|
||||
sortedOffsets :: [(Int32, V2 Int32)]
|
||||
sortedOffsets = (0, zero) : concatMap genDiamondSides [1 .. maxSniffRange]
|
||||
|
||||
-- Grow a list of locations in a diamond shape outward, such that the nearest cells
|
||||
-- are searched first by construction, rather than having to sort.
|
||||
@ -2239,11 +2288,11 @@ execConst c vs s k = do
|
||||
when (isCardinal d) $ hasCapabilityFor COrient $ TDir d
|
||||
return $ applyTurn d $ orient ? zero
|
||||
|
||||
lookInDirection :: HasRobotStepState sig m => Direction -> m (Location, Maybe Entity)
|
||||
lookInDirection :: HasRobotStepState sig m => Direction -> m (Cosmic Location, Maybe Entity)
|
||||
lookInDirection d = do
|
||||
newHeading <- deriveHeading d
|
||||
loc <- use robotLocation
|
||||
let nextLoc = loc .+^ newHeading
|
||||
let nextLoc = loc `offsetBy` newHeading
|
||||
(nextLoc,) <$> entityAt nextLoc
|
||||
|
||||
ensureEquipped :: HasRobotStepState sig m => Text -> m Entity
|
||||
@ -2421,7 +2470,7 @@ execConst c vs s k = do
|
||||
|
||||
-- Make sure nothing is in the way. Note that system robots implicitly ignore
|
||||
-- and base throws on failure.
|
||||
checkMoveFailure :: HasRobotStepState sig m => Location -> m (Maybe MoveFailureDetails)
|
||||
checkMoveFailure :: HasRobotStepState sig m => Cosmic Location -> m (Maybe MoveFailureDetails)
|
||||
checkMoveFailure nextLoc = do
|
||||
me <- entityAt nextLoc
|
||||
systemRob <- use systemRobot
|
||||
@ -2463,7 +2512,7 @@ execConst c vs s k = do
|
||||
IgnoreFail -> return ()
|
||||
|
||||
-- Determine the move failure mode and apply the corresponding effect.
|
||||
checkMoveAhead :: HasRobotStepState sig m => Location -> MoveFailure -> m ()
|
||||
checkMoveAhead :: HasRobotStepState sig m => Cosmic Location -> MoveFailure -> m ()
|
||||
checkMoveAhead nextLoc failureHandlers = do
|
||||
maybeFailure <- checkMoveFailure nextLoc
|
||||
applyMoveFailureEffect maybeFailure failureHandlers
|
||||
@ -2571,7 +2620,7 @@ execConst c vs s k = do
|
||||
|
||||
addWatchedLocation ::
|
||||
HasRobotStepState sig m =>
|
||||
Location ->
|
||||
Cosmic Location ->
|
||||
m ()
|
||||
addWatchedLocation loc = do
|
||||
rid <- use robotID
|
||||
@ -2604,9 +2653,11 @@ isPrivilegedBot = (||) <$> use systemRobot <*> use creativeMode
|
||||
|
||||
-- | Requires that the target location is within one cell.
|
||||
-- Requirement is waived if the bot is privileged.
|
||||
isNearbyOrExempt :: Bool -> Location -> Location -> Bool
|
||||
isNearbyOrExempt :: Bool -> Cosmic Location -> Cosmic Location -> Bool
|
||||
isNearbyOrExempt privileged myLoc otherLoc =
|
||||
privileged || otherLoc `manhattan` myLoc <= 1
|
||||
privileged || case cosmoMeasure manhattan myLoc otherLoc of
|
||||
InfinitelyFar -> False
|
||||
Measurable x -> x <= 1
|
||||
|
||||
grantAchievement ::
|
||||
(Has (State GameState) sig m, Has (Lift IO) sig m) =>
|
||||
@ -2687,33 +2738,22 @@ provisionChild childID toEquip toGive = do
|
||||
-- Also implements teleportation by portals.
|
||||
updateRobotLocation ::
|
||||
(HasRobotStepState sig m) =>
|
||||
Location ->
|
||||
Location ->
|
||||
Cosmic Location ->
|
||||
Cosmic Location ->
|
||||
m ()
|
||||
updateRobotLocation oldLoc newLoc
|
||||
| oldLoc == newLoc = return ()
|
||||
| otherwise = do
|
||||
newlocWithPortal <- applyPortal newLoc
|
||||
rid <- use robotID
|
||||
robotsByLocation . at oldLoc %= deleteOne rid
|
||||
robotsByLocation . at newlocWithPortal . non Empty %= IS.insert rid
|
||||
removeRobotFromLocationMap oldLoc rid
|
||||
addRobotToLocation rid newlocWithPortal
|
||||
modify (unsafeSetRobotLocation newlocWithPortal)
|
||||
flagRedraw
|
||||
where
|
||||
applyPortal loc = do
|
||||
lms <- use worldNavigation
|
||||
return $ M.findWithDefault loc loc $ portals lms
|
||||
|
||||
-- Make sure empty sets don't hang around in the
|
||||
-- robotsByLocation map. We don't want a key with an
|
||||
-- empty set at every location any robot has ever
|
||||
-- visited!
|
||||
deleteOne _ Nothing = Nothing
|
||||
deleteOne x (Just s)
|
||||
| IS.null s' = Nothing
|
||||
| otherwise = Just s'
|
||||
where
|
||||
s' = IS.delete x s
|
||||
return . M.findWithDefault loc loc . M.map cosmoLocation $ portals lms
|
||||
|
||||
-- | Execute a stateful action on a target robot --- whether the
|
||||
-- current one or another.
|
||||
|
63
src/Swarm/Game/Universe.hs
Normal file
63
src/Swarm/Game/Universe.hs
Normal file
@ -0,0 +1,63 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
-- |
|
||||
-- SPDX-License-Identifier: BSD-3-Clause
|
||||
module Swarm.Game.Universe where
|
||||
|
||||
import Control.Lens (makeLenses, view)
|
||||
import Data.Function (on)
|
||||
import Data.Int (Int32)
|
||||
import Data.Text (Text)
|
||||
import Data.Yaml (FromJSON, ToJSON, Value (Object), parseJSON, withText, (.:))
|
||||
import GHC.Generics (Generic)
|
||||
import Linear (V2 (..))
|
||||
import Swarm.Game.Location
|
||||
|
||||
data SubworldName = DefaultRootSubworld | SubworldName Text
|
||||
deriving (Show, Eq, Ord, Generic, ToJSON)
|
||||
|
||||
instance FromJSON SubworldName where
|
||||
parseJSON = withText "subworld name" $ return . SubworldName
|
||||
|
||||
renderWorldName :: SubworldName -> Text
|
||||
renderWorldName = \case
|
||||
SubworldName s -> s
|
||||
DefaultRootSubworld -> "<default>"
|
||||
|
||||
-- | The swarm universe consists of locations
|
||||
-- indexed by subworld.
|
||||
-- Not only is this datatype useful for planar (2D)
|
||||
-- coordinates, but is also used for named waypoints.
|
||||
data Cosmic a = Cosmic
|
||||
{ _subworld :: SubworldName
|
||||
, _planar :: a
|
||||
}
|
||||
deriving (Show, Eq, Ord, Functor, Generic, ToJSON)
|
||||
|
||||
makeLenses ''Cosmic
|
||||
|
||||
instance (FromJSON a) => FromJSON (Cosmic a) where
|
||||
parseJSON x = case x of
|
||||
Object v -> objParse v
|
||||
_ -> Cosmic DefaultRootSubworld <$> parseJSON x
|
||||
where
|
||||
objParse v =
|
||||
Cosmic
|
||||
<$> v .: "subworld"
|
||||
<*> v .: "loc"
|
||||
|
||||
defaultCosmicLocation :: Cosmic Location
|
||||
defaultCosmicLocation = Cosmic DefaultRootSubworld origin
|
||||
|
||||
data DistanceMeasure b = Measurable b | InfinitelyFar
|
||||
deriving (Eq, Ord)
|
||||
|
||||
-- | Returns 'InfinitelyFar' if not within the same subworld.
|
||||
cosmoMeasure :: (a -> a -> b) -> Cosmic a -> Cosmic a -> DistanceMeasure b
|
||||
cosmoMeasure f a b
|
||||
| ((/=) `on` view subworld) a b = InfinitelyFar
|
||||
| otherwise = Measurable $ (f `on` view planar) a b
|
||||
|
||||
offsetBy :: Cosmic Location -> V2 Int32 -> Cosmic Location
|
||||
offsetBy loc v = fmap (.+^ v) loc
|
@ -23,6 +23,7 @@ module Swarm.Game.World (
|
||||
WorldFun (..),
|
||||
worldFunFromArray,
|
||||
World,
|
||||
MultiWorld,
|
||||
|
||||
-- ** Tile management
|
||||
loadCell,
|
||||
@ -31,7 +32,9 @@ module Swarm.Game.World (
|
||||
-- ** World functions
|
||||
newWorld,
|
||||
emptyWorld,
|
||||
lookupCosmicTerrain,
|
||||
lookupTerrain,
|
||||
lookupCosmicEntity,
|
||||
lookupEntity,
|
||||
update,
|
||||
|
||||
@ -55,11 +58,14 @@ import Data.Bits
|
||||
import Data.Foldable (foldl')
|
||||
import Data.Function (on)
|
||||
import Data.Int (Int32)
|
||||
import Data.Map (Map)
|
||||
import Data.Map.Strict qualified as M
|
||||
import Data.Yaml (FromJSON, ToJSON)
|
||||
import GHC.Generics (Generic)
|
||||
import Swarm.Game.Entity (Entity, entityHash)
|
||||
import Swarm.Game.Location
|
||||
import Swarm.Game.Terrain (TerrainType (BlankT))
|
||||
import Swarm.Game.Universe
|
||||
import Swarm.Util ((?))
|
||||
import Prelude hiding (lookup)
|
||||
|
||||
@ -187,6 +193,8 @@ type TerrainTile t = U.UArray TileOffset t
|
||||
-- which have to be boxed.
|
||||
type EntityTile e = A.Array TileOffset (Maybe e)
|
||||
|
||||
type MultiWorld t e = Map SubworldName (World t e)
|
||||
|
||||
-- | A 'World' consists of a 'WorldFun' that specifies the initial
|
||||
-- world, a cache of loaded square tiles to make lookups faster, and
|
||||
-- a map storing locations whose entities have changed from their
|
||||
@ -214,6 +222,14 @@ newWorld f = World f M.empty M.empty
|
||||
emptyWorld :: t -> World t e
|
||||
emptyWorld t = newWorld (WF $ const (t, Nothing))
|
||||
|
||||
lookupCosmicTerrain ::
|
||||
IArray U.UArray Int =>
|
||||
Cosmic Coords ->
|
||||
MultiWorld Int e ->
|
||||
TerrainType
|
||||
lookupCosmicTerrain (Cosmic subworldName i) multiWorld =
|
||||
maybe BlankT (toEnum . lookupTerrain i) $ M.lookup subworldName multiWorld
|
||||
|
||||
-- | Look up the terrain value at certain coordinates: try looking it
|
||||
-- up in the tile cache first, and fall back to running the 'WorldFun'
|
||||
-- otherwise.
|
||||
@ -228,11 +244,19 @@ lookupTerrain i (World f t _) =
|
||||
-- | A stateful variant of 'lookupTerrain', which first loads the tile
|
||||
-- containing the given coordinates if it is not already loaded,
|
||||
-- then looks up the terrain value.
|
||||
lookupTerrainM :: forall t e sig m. (Has (State (World t e)) sig m, IArray U.UArray t) => Coords -> m t
|
||||
lookupTerrainM ::
|
||||
forall t e sig m.
|
||||
(Has (State (World t e)) sig m, IArray U.UArray t) =>
|
||||
Coords ->
|
||||
m t
|
||||
lookupTerrainM c = do
|
||||
modify @(World t e) $ loadCell c
|
||||
lookupTerrain c <$> get @(World t e)
|
||||
|
||||
lookupCosmicEntity :: Cosmic Coords -> MultiWorld t e -> Maybe e
|
||||
lookupCosmicEntity (Cosmic subworldName i) multiWorld =
|
||||
lookupEntity i =<< M.lookup subworldName multiWorld
|
||||
|
||||
-- | Look up the entity at certain coordinates: first, see if it is in
|
||||
-- the map of locations with changed entities; then try looking it
|
||||
-- up in the tile cache first; and finally fall back to running the
|
||||
@ -246,10 +270,14 @@ lookupEntity i (World f t m) =
|
||||
? ((A.! tileOffset i) . snd <$> M.lookup (tileCoords i) t)
|
||||
? snd (runWF f i)
|
||||
|
||||
-- | A stateful variant of 'lookupTerrain', which first loads the tile
|
||||
-- | A stateful variant of 'lookupEntity', which first loads the tile
|
||||
-- containing the given coordinates if it is not already loaded,
|
||||
-- then looks up the terrain value.
|
||||
lookupEntityM :: forall t e sig m. (Has (State (World t e)) sig m, IArray U.UArray t) => Coords -> m (Maybe e)
|
||||
lookupEntityM ::
|
||||
forall t e sig m.
|
||||
(Has (State (World t e)) sig m, IArray U.UArray t) =>
|
||||
Coords ->
|
||||
m (Maybe e)
|
||||
lookupEntityM c = do
|
||||
modify @(World t e) $ loadCell c
|
||||
lookupEntity c <$> get @(World t e)
|
||||
@ -258,7 +286,11 @@ lookupEntityM c = do
|
||||
-- returning an updated 'World' and a Boolean indicating whether
|
||||
-- the update changed the entity here.
|
||||
-- See also 'updateM'.
|
||||
update :: Coords -> (Maybe Entity -> Maybe Entity) -> World t Entity -> (World t Entity, Bool)
|
||||
update ::
|
||||
Coords ->
|
||||
(Maybe Entity -> Maybe Entity) ->
|
||||
World t Entity ->
|
||||
(World t Entity, Bool)
|
||||
update i g w@(World f t m) =
|
||||
(wNew, ((/=) `on` fmap (view entityHash)) entityAfter entityBefore)
|
||||
where
|
||||
@ -283,7 +315,12 @@ loadCell c = loadRegion (c, c)
|
||||
|
||||
-- | Load all the tiles which overlap the given rectangular region
|
||||
-- (specified as an upper-left and lower-right corner, inclusive).
|
||||
loadRegion :: forall t e. (IArray U.UArray t) => (Coords, Coords) -> World t e -> World t e
|
||||
loadRegion ::
|
||||
forall t e.
|
||||
(IArray U.UArray t) =>
|
||||
(Coords, Coords) ->
|
||||
World t e ->
|
||||
World t e
|
||||
loadRegion reg (World f t m) = World f t' m
|
||||
where
|
||||
tiles = range (over both tileCoords reg)
|
||||
@ -308,7 +345,7 @@ loadRegion reg (World f t m) = World f t' m
|
||||
-- This type is used for changes by e.g. the drill command at later
|
||||
-- tick. Using ADT allows us to serialize and inspect the updates.
|
||||
data WorldUpdate e = ReplaceEntity
|
||||
{ updatedLoc :: Location
|
||||
{ updatedLoc :: Cosmic Location
|
||||
, originalEntity :: e
|
||||
, newEntity :: Maybe e
|
||||
}
|
||||
|
@ -697,7 +697,8 @@ constInfo c = case c of
|
||||
Whereami -> command 0 Intangible "Get the current x and y coordinates."
|
||||
Waypoint ->
|
||||
command 2 Intangible . doc "Get the x, y coordinates of a named waypoint, by index" $
|
||||
[ "Since waypoint names can have plural multiplicity, returns a tuple of (count, (x, y))."
|
||||
[ "Return only the waypoints in the same subworld as the calling robot."
|
||||
, "Since waypoint names can have plural multiplicity, returns a tuple of (count, (x, y))."
|
||||
, "The supplied index will be wrapped automatically, modulo the waypoint count."
|
||||
, "A robot can use the count to know whether they have iterated over the full waypoint circuit."
|
||||
]
|
||||
|
@ -378,6 +378,7 @@ handleMainEvent ev = do
|
||||
| s ^. uiState . uiCheatMode -> do
|
||||
uiState . uiWorldEditor . isWorldEditorEnabled %= not
|
||||
setFocus WorldEditorPanel
|
||||
MouseDown WorldPositionIndicator _ _ _ -> uiState . uiWorldCursor .= Nothing
|
||||
MouseDown (FocusablePanel WorldPanel) V.BMiddle _ mouseLoc ->
|
||||
-- Eye Dropper tool
|
||||
EC.handleMiddleClick mouseLoc
|
||||
@ -1341,7 +1342,7 @@ scrollView update = do
|
||||
-- always work, but there seems to be some sort of race condition
|
||||
-- where 'needsRedraw' gets reset before the UI drawing code runs.
|
||||
invalidateCacheEntry WorldCache
|
||||
gameState %= modifyViewCenter update
|
||||
gameState %= modifyViewCenter (fmap update)
|
||||
|
||||
-- | Convert a directional key into a direction.
|
||||
keyToDir :: V.Key -> Heading
|
||||
|
@ -9,8 +9,10 @@ import Brick.Focus
|
||||
import Control.Lens
|
||||
import Control.Monad (forM_, unless)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Data.Map qualified as M
|
||||
import Graphics.Vty qualified as V
|
||||
import Swarm.Game.State
|
||||
import Swarm.Game.Universe
|
||||
import Swarm.Game.World qualified as W
|
||||
import Swarm.TUI.Model
|
||||
import Swarm.TUI.Model.UI
|
||||
@ -77,17 +79,18 @@ loadVisibleRegion = do
|
||||
mext <- lookupExtent WorldExtent
|
||||
forM_ mext $ \(Extent _ _ size) -> do
|
||||
gs <- use gameState
|
||||
gameState . world %= W.loadRegion (viewingRegion gs (over both fromIntegral size))
|
||||
let vr = viewingRegion gs (over both fromIntegral size)
|
||||
gameState . multiWorld %= M.adjust (W.loadRegion (vr ^. planar)) (vr ^. subworld)
|
||||
|
||||
mouseLocToWorldCoords :: Brick.Location -> EventM Name GameState (Maybe W.Coords)
|
||||
mouseLocToWorldCoords :: Brick.Location -> EventM Name GameState (Maybe (Cosmic W.Coords))
|
||||
mouseLocToWorldCoords (Brick.Location mouseLoc) = do
|
||||
mext <- lookupExtent WorldExtent
|
||||
case mext of
|
||||
Nothing -> pure Nothing
|
||||
Just ext -> do
|
||||
region <- gets $ flip viewingRegion (bimap fromIntegral fromIntegral (extentSize ext))
|
||||
let regionStart = W.unCoords (fst region)
|
||||
let regionStart = W.unCoords (fst $ region ^. planar)
|
||||
mouseLoc' = bimap fromIntegral fromIntegral mouseLoc
|
||||
mx = snd mouseLoc' + fst regionStart
|
||||
my = fst mouseLoc' + snd regionStart
|
||||
in pure . Just $ W.Coords (mx, my)
|
||||
in pure . Just $ Cosmic (region ^. subworld) $ W.Coords (mx, my)
|
||||
|
@ -16,6 +16,7 @@ import Data.Yaml qualified as Y
|
||||
import Graphics.Vty qualified as V
|
||||
import Swarm.Game.Scenario.Topography.EntityFacade
|
||||
import Swarm.Game.State
|
||||
import Swarm.Game.Universe
|
||||
import Swarm.Game.World qualified as W
|
||||
import Swarm.TUI.Controller.Util
|
||||
import Swarm.TUI.Editor.Model
|
||||
@ -39,7 +40,7 @@ activateWorldEditorFunction AreaSelector = do
|
||||
SelectionComplete -> uiState . uiWorldEditor . editingBounds . boundsSelectionStep .= UpperLeftPending
|
||||
_ -> return ()
|
||||
activateWorldEditorFunction OutputPathSelector =
|
||||
-- TODO
|
||||
-- TODO: #1371
|
||||
liftIO $ putStrLn "File selection"
|
||||
activateWorldEditorFunction MapSaveButton = saveMapFile
|
||||
activateWorldEditorFunction ClearEntityButton =
|
||||
@ -56,7 +57,7 @@ handleCtrlLeftClick mouseLoc = do
|
||||
-- TODO (#1151): Use hoistMaybe when available
|
||||
terrain <- MaybeT . pure $ maybeTerrainType
|
||||
mouseCoords <- MaybeT $ Brick.zoom gameState $ mouseLocToWorldCoords mouseLoc
|
||||
uiState . uiWorldEditor . paintedTerrain %= M.insert mouseCoords (terrain, maybeEntityPaint)
|
||||
uiState . uiWorldEditor . paintedTerrain %= M.insert (mouseCoords ^. planar) (terrain, maybeEntityPaint)
|
||||
uiState . uiWorldEditor . lastWorldEditorMessage .= Nothing
|
||||
immediatelyRedrawWorld
|
||||
return ()
|
||||
@ -67,7 +68,7 @@ handleRightClick mouseLoc = do
|
||||
_ <- runMaybeT $ do
|
||||
guard $ worldEditor ^. isWorldEditorEnabled
|
||||
mouseCoords <- MaybeT $ Brick.zoom gameState $ mouseLocToWorldCoords mouseLoc
|
||||
uiState . uiWorldEditor . paintedTerrain %= M.delete mouseCoords
|
||||
uiState . uiWorldEditor . paintedTerrain %= M.delete (mouseCoords ^. planar)
|
||||
immediatelyRedrawWorld
|
||||
return ()
|
||||
|
||||
@ -76,7 +77,7 @@ handleMiddleClick :: B.Location -> EventM Name AppState ()
|
||||
handleMiddleClick mouseLoc = do
|
||||
worldEditor <- use $ uiState . uiWorldEditor
|
||||
when (worldEditor ^. isWorldEditorEnabled) $ do
|
||||
w <- use $ gameState . world
|
||||
w <- use $ gameState . multiWorld
|
||||
let setTerrainPaint coords = do
|
||||
let (terrain, maybeElementPaint) =
|
||||
EU.getContentAt
|
||||
@ -108,7 +109,7 @@ handleWorldEditorPanelEvent = \case
|
||||
_ -> return ()
|
||||
|
||||
-- | Return value: whether the cursor position should be updated
|
||||
updateAreaBounds :: Maybe W.Coords -> EventM Name AppState Bool
|
||||
updateAreaBounds :: Maybe (Cosmic W.Coords) -> EventM Name AppState Bool
|
||||
updateAreaBounds = \case
|
||||
Nothing -> return True
|
||||
Just mouseCoords -> do
|
||||
@ -117,10 +118,11 @@ updateAreaBounds = \case
|
||||
UpperLeftPending -> do
|
||||
uiState . uiWorldEditor . editingBounds . boundsSelectionStep .= LowerRightPending mouseCoords
|
||||
return False
|
||||
-- TODO (#1152): Validate that the lower-right click is below and to the right of the top-left coord
|
||||
-- TODO (#1152): Validate that the lower-right click is below and to the right of
|
||||
-- the top-left coord and that they are within the same subworld
|
||||
LowerRightPending upperLeftMouseCoords -> do
|
||||
uiState . uiWorldEditor . editingBounds . boundsRect
|
||||
.= Just (upperLeftMouseCoords, mouseCoords)
|
||||
.= Just (fmap (,view planar mouseCoords) upperLeftMouseCoords)
|
||||
uiState . uiWorldEditor . lastWorldEditorMessage .= Nothing
|
||||
uiState . uiWorldEditor . editingBounds . boundsSelectionStep .= SelectionComplete
|
||||
t <- liftIO $ getTime Monotonic
|
||||
@ -133,7 +135,7 @@ saveMapFile :: EventM Name AppState ()
|
||||
saveMapFile = do
|
||||
worldEditor <- use $ uiState . uiWorldEditor
|
||||
maybeBounds <- use $ uiState . uiWorldEditor . editingBounds . boundsRect
|
||||
w <- use $ gameState . world
|
||||
w <- use $ gameState . multiWorld
|
||||
let mapCellGrid = EU.getEditedMapRectangle worldEditor maybeBounds w
|
||||
|
||||
let fp = worldEditor ^. outputFilePath
|
||||
|
@ -2,6 +2,7 @@ module Swarm.TUI.Editor.Masking where
|
||||
|
||||
import Control.Lens hiding (Const, from)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Swarm.Game.Universe
|
||||
import Swarm.Game.World qualified as W
|
||||
import Swarm.TUI.Editor.Model
|
||||
import Swarm.TUI.Editor.Util qualified as EU
|
||||
@ -20,11 +21,11 @@ shouldHideWorldCell ui coords =
|
||||
False
|
||||
( do
|
||||
bounds <- we ^. editingBounds . boundsRect
|
||||
pure $ EU.isOutsideRegion bounds coords
|
||||
pure $ EU.isOutsideRegion (bounds ^. planar) coords
|
||||
)
|
||||
|
||||
isOutsideSingleSelectedCorner = fromMaybe False $ do
|
||||
cornerCoords <- case we ^. editingBounds . boundsSelectionStep of
|
||||
Cosmic _ cornerCoords <- case we ^. editingBounds . boundsSelectionStep of
|
||||
LowerRightPending cornerCoords -> Just cornerCoords
|
||||
_ -> Nothing
|
||||
pure $ EU.isOutsideTopLeftCorner cornerCoords coords
|
||||
|
@ -13,6 +13,7 @@ import Swarm.Game.Entity qualified as E
|
||||
import Swarm.Game.Scenario.Topography.EntityFacade
|
||||
import Swarm.Game.Scenario.Topography.WorldPalette
|
||||
import Swarm.Game.Terrain (TerrainType)
|
||||
import Swarm.Game.Universe
|
||||
import Swarm.Game.World qualified as W
|
||||
import Swarm.TUI.Model.Name
|
||||
import Swarm.Util
|
||||
@ -21,7 +22,7 @@ import System.Clock
|
||||
data BoundsSelectionStep
|
||||
= UpperLeftPending
|
||||
| -- | Stores the *world coords* of the upper-left click
|
||||
LowerRightPending W.Coords
|
||||
LowerRightPending (Cosmic W.Coords)
|
||||
| SelectionComplete
|
||||
|
||||
data EntityPaint
|
||||
@ -42,7 +43,7 @@ getEntityName :: EntityFacade -> EntityName
|
||||
getEntityName (EntityFacade name _) = name
|
||||
|
||||
data MapEditingBounds = MapEditingBounds
|
||||
{ _boundsRect :: Maybe W.BoundsRectangle
|
||||
{ _boundsRect :: Maybe (Cosmic W.BoundsRectangle)
|
||||
-- ^ Upper-left and lower-right coordinates
|
||||
-- of the map to be saved.
|
||||
, _boundsPersistDisplayUntil :: TimeSpec
|
||||
@ -82,6 +83,6 @@ initialWorldEditor ts =
|
||||
MapEditingBounds
|
||||
-- Note that these are in "world coordinates",
|
||||
-- not in player-facing "Location" coordinates
|
||||
(Just (W.Coords (-10, -20), W.Coords (10, 20)))
|
||||
(Just $ Cosmic DefaultRootSubworld (W.Coords (-10, -20), W.Coords (10, 20)))
|
||||
(ts - 1)
|
||||
SelectionComplete
|
||||
|
@ -27,6 +27,7 @@ import Swarm.Game.Scenario.Topography.EntityFacade
|
||||
import Swarm.Game.Scenario.Topography.Navigation.Portal (Navigation (..))
|
||||
import Swarm.Game.Scenario.Topography.WorldPalette
|
||||
import Swarm.Game.Terrain (TerrainType (BlankT), getTerrainDefaultPaletteChar)
|
||||
import Swarm.Game.Universe
|
||||
import Swarm.TUI.Editor.Json (SkeletonScenario (SkeletonScenario))
|
||||
import Swarm.Util (binTuples, histogram)
|
||||
import Swarm.Util qualified as U
|
||||
@ -86,7 +87,7 @@ makeSuggestedPalette maybeOriginalScenario cellGrid =
|
||||
originalPalette :: KM.KeyMap CellPaintDisplay
|
||||
originalPalette =
|
||||
KM.map (toCellPaintDisplay . standardCell) $
|
||||
maybe mempty (unPalette . palette . (^. scenarioWorld)) maybeOriginalScenario
|
||||
maybe mempty (unPalette . palette . NE.head . (^. scenarioWorlds)) maybeOriginalScenario
|
||||
|
||||
pairsWithDisplays :: Map (TerrainWith EntityName) (T.Text, CellPaintDisplay)
|
||||
pairsWithDisplays = M.fromList $ mapMaybe g entitiesWithModalTerrain
|
||||
@ -128,6 +129,7 @@ constructScenario maybeOriginalScenario cellGrid =
|
||||
, ul = upperLeftCoord
|
||||
, area = cellGrid
|
||||
, navigation = Navigation mempty mempty
|
||||
, worldName = DefaultRootSubworld
|
||||
}
|
||||
|
||||
suggestedPalette = makeSuggestedPalette maybeOriginalScenario cellGrid
|
||||
|
@ -14,6 +14,7 @@ import Swarm.Game.Scenario.Topography.Cell
|
||||
import Swarm.Game.Scenario.Topography.EntityFacade
|
||||
import Swarm.Game.Scenario.Topography.WorldDescription
|
||||
import Swarm.Game.Terrain (TerrainType)
|
||||
import Swarm.Game.Universe
|
||||
import Swarm.Game.World qualified as W
|
||||
import Swarm.TUI.Editor.Model
|
||||
import Swarm.TUI.Model
|
||||
@ -24,19 +25,19 @@ getEntitiesForList em =
|
||||
where
|
||||
entities = M.elems $ entitiesByName em
|
||||
|
||||
getEditingBounds :: WorldDescription -> (Bool, W.BoundsRectangle)
|
||||
getEditingBounds :: WorldDescription -> (Bool, Cosmic W.BoundsRectangle)
|
||||
getEditingBounds myWorld =
|
||||
(EA.isEmpty a, newBounds)
|
||||
where
|
||||
newBounds = (W.locToCoords upperLeftLoc, W.locToCoords lowerRightLoc)
|
||||
newBounds = Cosmic DefaultRootSubworld (W.locToCoords upperLeftLoc, W.locToCoords lowerRightLoc)
|
||||
upperLeftLoc = ul myWorld
|
||||
a = EA.getAreaDimensions $ area myWorld
|
||||
lowerRightLoc = EA.upperLeftToBottomRight a upperLeftLoc
|
||||
|
||||
getContentAt ::
|
||||
WorldEditor Name ->
|
||||
W.World Int Entity ->
|
||||
W.Coords ->
|
||||
W.MultiWorld Int Entity ->
|
||||
Cosmic W.Coords ->
|
||||
(TerrainType, Maybe EntityPaint)
|
||||
getContentAt editor w coords =
|
||||
(terrainWithOverride, entityWithOverride)
|
||||
@ -51,20 +52,21 @@ getContentAt editor w coords =
|
||||
|
||||
maybePaintedCell = do
|
||||
guard $ editor ^. isWorldEditorEnabled
|
||||
Map.lookup coords pm
|
||||
Map.lookup (coords ^. planar) pm
|
||||
|
||||
pm = editor ^. paintedTerrain
|
||||
|
||||
entityWithOverride = (Ref <$> underlyingCellEntity) <|> maybeEntityOverride
|
||||
underlyingCellEntity = W.lookupEntity coords w
|
||||
underlyingCellTerrain = toEnum $ W.lookupTerrain coords w
|
||||
underlyingCellEntity = W.lookupCosmicEntity coords w
|
||||
underlyingCellTerrain = W.lookupCosmicTerrain coords w
|
||||
|
||||
getTerrainAt ::
|
||||
WorldEditor Name ->
|
||||
W.World Int Entity ->
|
||||
W.Coords ->
|
||||
W.MultiWorld Int Entity ->
|
||||
Cosmic W.Coords ->
|
||||
TerrainType
|
||||
getTerrainAt editor w coords = fst $ getContentAt editor w coords
|
||||
getTerrainAt editor w coords =
|
||||
fst $ getContentAt editor w coords
|
||||
|
||||
isOutsideTopLeftCorner ::
|
||||
-- | top left corner coords
|
||||
@ -95,16 +97,16 @@ isOutsideRegion (tl, br) coord =
|
||||
|
||||
getEditedMapRectangle ::
|
||||
WorldEditor Name ->
|
||||
Maybe W.BoundsRectangle ->
|
||||
W.World Int Entity ->
|
||||
Maybe (Cosmic W.BoundsRectangle) ->
|
||||
W.MultiWorld Int Entity ->
|
||||
[[CellPaintDisplay]]
|
||||
getEditedMapRectangle _ Nothing _ = []
|
||||
getEditedMapRectangle worldEditor (Just coords) w =
|
||||
getEditedMapRectangle worldEditor (Just (Cosmic subworldName coords)) w =
|
||||
map renderRow [yTop .. yBottom]
|
||||
where
|
||||
(W.Coords (yTop, xLeft), W.Coords (yBottom, xRight)) = coords
|
||||
|
||||
getContent = getContentAt worldEditor w
|
||||
getContent = getContentAt worldEditor w . Cosmic subworldName
|
||||
|
||||
drawCell :: Int32 -> Int32 -> CellPaintDisplay
|
||||
drawCell rowIndex colIndex =
|
||||
|
@ -9,6 +9,7 @@ import Data.List qualified as L
|
||||
import Swarm.Game.Scenario.Topography.Area qualified as EA
|
||||
import Swarm.Game.Scenario.Topography.EntityFacade
|
||||
import Swarm.Game.Terrain (TerrainType)
|
||||
import Swarm.Game.Universe
|
||||
import Swarm.Game.World qualified as W
|
||||
import Swarm.TUI.Attr
|
||||
import Swarm.TUI.Border
|
||||
@ -92,7 +93,7 @@ drawWorldEditor toplevelFocusRing uis =
|
||||
areaContent = case worldEditor ^. editingBounds . boundsSelectionStep of
|
||||
UpperLeftPending -> str "Click top-left"
|
||||
LowerRightPending _wcoords -> str "Click bottom-right"
|
||||
SelectionComplete -> maybe emptyWidget renderBounds maybeAreaBounds
|
||||
SelectionComplete -> maybe emptyWidget (renderBounds . view planar) maybeAreaBounds
|
||||
|
||||
areaWidget =
|
||||
mkFormControl (WorldEditorPanelControl AreaSelector) $
|
||||
|
@ -133,7 +133,6 @@ import Data.Text.IO qualified as T (readFile)
|
||||
import Data.Vector qualified as V
|
||||
import GitHash (GitInfo)
|
||||
import Graphics.Vty (ColorMode (..))
|
||||
import Linear (zero)
|
||||
import Network.Wai.Handler.Warp (Port)
|
||||
import Swarm.Game.CESK (TickNumber (..))
|
||||
import Swarm.Game.Entity as E
|
||||
@ -154,6 +153,7 @@ import Swarm.TUI.Model.Menu
|
||||
import Swarm.TUI.Model.Name
|
||||
import Swarm.TUI.Model.Repl
|
||||
import Swarm.TUI.Model.UI
|
||||
import Swarm.Util (failT, showT)
|
||||
import Swarm.Util.Lens (makeLensesNoSigs)
|
||||
import Swarm.Version (NewReleaseFailure (NoMainUpstreamRelease))
|
||||
import Text.Fuzzy qualified as Fuzzy
|
||||
@ -209,7 +209,7 @@ initRuntimeState = do
|
||||
namesFile <- getDataFileNameSafe NameGeneration "names.txt"
|
||||
return (adjsFile, namesFile)
|
||||
|
||||
let markEx what a = catchError a (\e -> fail $ "Failed to " <> what <> ": " <> show e)
|
||||
let markEx what a = catchError a (\e -> failT ["Failed to", what <> ":", showT e])
|
||||
(adjs, names) <- liftIO . markEx "load name generation data" $ do
|
||||
as <- tail . T.lines <$> T.readFile adjsFile
|
||||
ns <- tail . T.lines <$> T.readFile namesFile
|
||||
@ -273,7 +273,7 @@ logEvent src (who, rid) msg el =
|
||||
& notificationsCount %~ succ
|
||||
& notificationsContent %~ (l :)
|
||||
where
|
||||
l = LogEntry (TickNumber 0) src who rid zero msg
|
||||
l = LogEntry (TickNumber 0) src who rid Omnipresent msg
|
||||
|
||||
-- | Create a 'GameStateConfig' record from the 'RuntimeState'.
|
||||
mkGameStateConfig :: RuntimeState -> GameStateConfig
|
||||
|
@ -62,6 +62,8 @@ data Name
|
||||
WorldCache
|
||||
| -- | The cached extent for the world view.
|
||||
WorldExtent
|
||||
| -- | The cursor/viewCenter display in the bottom left of the World view
|
||||
WorldPositionIndicator
|
||||
| -- | The list of possible entities to paint a map with.
|
||||
EntityPaintList
|
||||
| -- | The entity paint item position in the EntityPaintList.
|
||||
|
@ -26,6 +26,7 @@ import Control.Monad.Except (ExceptT, runExceptT)
|
||||
import Control.Monad.IO.Class (MonadIO (liftIO))
|
||||
import Control.Monad.State (MonadState, execStateT)
|
||||
import Data.List qualified as List
|
||||
import Data.List.NonEmpty qualified as NE
|
||||
import Data.Map qualified as M
|
||||
import Data.Maybe (fromMaybe, isJust)
|
||||
import Data.Text (Text)
|
||||
@ -36,7 +37,7 @@ import Swarm.Game.Achievement.Persistence
|
||||
import Swarm.Game.Failure (SystemFailure)
|
||||
import Swarm.Game.Failure.Render (prettyFailure)
|
||||
import Swarm.Game.Log (ErrorLevel (..), LogSource (ErrorTrace))
|
||||
import Swarm.Game.Scenario (loadScenario, scenarioAttrs, scenarioWorld)
|
||||
import Swarm.Game.Scenario (loadScenario, scenarioAttrs, scenarioWorlds)
|
||||
import Swarm.Game.Scenario.Scoring.Best
|
||||
import Swarm.Game.Scenario.Scoring.ConcreteMetrics
|
||||
import Swarm.Game.Scenario.Scoring.GenericMetrics
|
||||
@ -235,8 +236,7 @@ scenarioToUIState isAutoplaying siPair@(scenario, _) gs u = do
|
||||
where
|
||||
entityList = EU.getEntitiesForList $ gs ^. entityMap
|
||||
|
||||
myWorld = scenario ^. scenarioWorld
|
||||
(isEmptyArea, newBounds) = EU.getEditingBounds myWorld
|
||||
(isEmptyArea, newBounds) = EU.getEditingBounds $ NE.head $ scenario ^. scenarioWorlds
|
||||
setNewBounds maybeOldBounds =
|
||||
if isEmptyArea
|
||||
then maybeOldBounds
|
||||
|
@ -75,6 +75,7 @@ import Swarm.Game.ResourceLoading (getSwarmHistoryPath, readAppData)
|
||||
import Swarm.Game.ScenarioInfo (
|
||||
ScenarioInfoPair,
|
||||
)
|
||||
import Swarm.Game.Universe
|
||||
import Swarm.Game.World qualified as W
|
||||
import Swarm.TUI.Attr (swarmAttrMap)
|
||||
import Swarm.TUI.Editor.Model
|
||||
@ -101,7 +102,7 @@ data UIState = UIState
|
||||
, _uiCheatMode :: Bool
|
||||
, _uiFocusRing :: FocusRing Name
|
||||
, _uiLaunchConfig :: LaunchOptions
|
||||
, _uiWorldCursor :: Maybe W.Coords
|
||||
, _uiWorldCursor :: Maybe (Cosmic W.Coords)
|
||||
, _uiWorldEditor :: WorldEditor Name
|
||||
, _uiREPL :: REPLState
|
||||
, _uiInventory :: Maybe (Int, BL.List Name InventoryListEntry)
|
||||
@ -159,7 +160,7 @@ uiLaunchConfig :: Lens' UIState LaunchOptions
|
||||
uiFocusRing :: Lens' UIState (FocusRing Name)
|
||||
|
||||
-- | The last clicked position on the world view.
|
||||
uiWorldCursor :: Lens' UIState (Maybe W.Coords)
|
||||
uiWorldCursor :: Lens' UIState (Maybe (Cosmic W.Coords))
|
||||
|
||||
-- | State of all World Editor widgets
|
||||
uiWorldEditor :: Lens' UIState (WorldEditor Name)
|
||||
|
@ -87,6 +87,7 @@ import Swarm.Game.ScenarioInfo (
|
||||
scenarioItemName,
|
||||
)
|
||||
import Swarm.Game.State
|
||||
import Swarm.Game.Universe
|
||||
import Swarm.Game.World qualified as W
|
||||
import Swarm.Language.Capability (Capability (..), constCaps)
|
||||
import Swarm.Language.Pretty (prettyText)
|
||||
@ -416,11 +417,11 @@ drawGameUI s =
|
||||
]
|
||||
]
|
||||
where
|
||||
addCursorPos = case s ^. uiState . uiWorldCursor of
|
||||
Nothing -> id
|
||||
Just coord ->
|
||||
let worldCursorInfo = drawWorldCursorInfo (s ^. uiState . uiWorldEditor) (s ^. gameState) coord
|
||||
in bottomLabels . leftLabel ?~ padLeftRight 1 worldCursorInfo
|
||||
addCursorPos = bottomLabels . leftLabel ?~ padLeftRight 1 widg
|
||||
where
|
||||
widg = case s ^. uiState . uiWorldCursor of
|
||||
Nothing -> str $ renderCoordsString $ s ^. gameState . viewCenter
|
||||
Just coord -> clickable WorldPositionIndicator $ drawWorldCursorInfo (s ^. uiState . uiWorldEditor) (s ^. gameState) coord
|
||||
-- Add clock display in top right of the world view if focused robot
|
||||
-- has a clock equipped
|
||||
addClock = topLabels . rightLabel ?~ padLeftRight 1 (drawClockDisplay (s ^. uiState . lgTicksPerSecond) $ s ^. gameState)
|
||||
@ -462,14 +463,22 @@ drawGameUI s =
|
||||
)
|
||||
]
|
||||
|
||||
drawWorldCursorInfo :: WorldEditor Name -> GameState -> W.Coords -> Widget Name
|
||||
drawWorldCursorInfo worldEditor g coords =
|
||||
renderCoordsString :: Cosmic Location -> String
|
||||
renderCoordsString (Cosmic sw coords) =
|
||||
unwords $ VU.locationToString coords : suffix
|
||||
where
|
||||
suffix = case sw of
|
||||
DefaultRootSubworld -> []
|
||||
SubworldName swName -> ["in", T.unpack swName]
|
||||
|
||||
drawWorldCursorInfo :: WorldEditor Name -> GameState -> Cosmic W.Coords -> Widget Name
|
||||
drawWorldCursorInfo worldEditor g cCoords =
|
||||
case getStatic g coords of
|
||||
Just s -> renderDisplay $ displayStatic s
|
||||
Nothing -> hBox $ tileMemberWidgets ++ [coordsWidget]
|
||||
where
|
||||
coordsWidget =
|
||||
str $ VU.locationToString $ W.coordsToLoc coords
|
||||
Cosmic _ coords = cCoords
|
||||
coordsWidget = str $ renderCoordsString $ fmap W.coordsToLoc cCoords
|
||||
|
||||
tileMembers = terrain : mapMaybe merge [entity, robot]
|
||||
tileMemberWidgets =
|
||||
@ -481,9 +490,9 @@ drawWorldCursorInfo worldEditor g coords =
|
||||
where
|
||||
f cell preposition = [renderDisplay cell, txt preposition]
|
||||
|
||||
terrain = displayTerrainCell worldEditor g coords
|
||||
entity = displayEntityCell worldEditor g coords
|
||||
robot = displayRobotCell g coords
|
||||
terrain = displayTerrainCell worldEditor g cCoords
|
||||
entity = displayEntityCell worldEditor g cCoords
|
||||
robot = displayRobotCell g cCoords
|
||||
|
||||
merge = fmap sconcat . NE.nonEmpty . filter (not . (^. invisible))
|
||||
|
||||
@ -649,15 +658,16 @@ robotsListWidget s = hCenter table
|
||||
| robot ^. robotLogUpdated = "x"
|
||||
| otherwise = " "
|
||||
|
||||
locWidget = hBox [worldCell, txt $ " " <> locStr]
|
||||
locWidget = hBox [worldCell, str $ " " <> locStr]
|
||||
where
|
||||
rloc@(Location x y) = robot ^. robotLocation
|
||||
rCoords = fmap W.locToCoords rLoc
|
||||
rLoc = robot ^. robotLocation
|
||||
worldCell =
|
||||
drawLoc
|
||||
(s ^. uiState)
|
||||
g
|
||||
(W.locToCoords rloc)
|
||||
locStr = from (show x) <> " " <> from (show y)
|
||||
rCoords
|
||||
locStr = renderCoordsString rLoc
|
||||
|
||||
statusWidget = case robot ^. machine of
|
||||
Waiting {} -> txt "waiting"
|
||||
@ -666,11 +676,11 @@ robotsListWidget s = hCenter table
|
||||
| otherwise -> withAttr greenAttr $ txt "idle"
|
||||
|
||||
basePos :: Point V2 Double
|
||||
basePos = realToFrac <$> fromMaybe origin (g ^? baseRobot . robotLocation)
|
||||
basePos = realToFrac <$> fromMaybe origin (g ^? baseRobot . robotLocation . planar)
|
||||
-- Keep the base and non system robot (e.g. no seed)
|
||||
isRelevant robot = robot ^. robotID == 0 || not (robot ^. systemRobot)
|
||||
-- Keep the robot that are less than 32 unit away from the base
|
||||
isNear robot = creative || distance (realToFrac <$> robot ^. robotLocation) basePos < 32
|
||||
isNear robot = creative || distance (realToFrac <$> robot ^. robotLocation . planar) basePos < 32
|
||||
robots :: [Robot]
|
||||
robots =
|
||||
filter (\robot -> debugging || (isRelevant robot && isNear robot))
|
||||
@ -1000,8 +1010,9 @@ drawWorld ui g =
|
||||
ctx <- getContext
|
||||
let w = ctx ^. availWidthL
|
||||
h = ctx ^. availHeightL
|
||||
ixs = range (viewingRegion g (fromIntegral w, fromIntegral h))
|
||||
render . vBox . map hBox . chunksOf w . map (drawLoc ui g) $ ixs
|
||||
vr = viewingRegion g (fromIntegral w, fromIntegral h)
|
||||
ixs = range $ vr ^. planar
|
||||
render . vBox . map hBox . chunksOf w . map (drawLoc ui g . Cosmic (vr ^. subworld)) $ ixs
|
||||
|
||||
------------------------------------------------------------
|
||||
-- Robot inventory panel
|
||||
@ -1017,7 +1028,7 @@ drawRobotPanel s
|
||||
-- away and a robot that does not exist.
|
||||
| Just r <- s ^. gameState . to focusedRobot
|
||||
, Just (_, lst) <- s ^. uiState . uiInventory =
|
||||
let Location x y = r ^. robotLocation
|
||||
let Cosmic _subworldName (Location x y) = r ^. robotLocation
|
||||
drawClickableItem pos selb = clickable (InventoryListItem pos) . drawItem (lst ^. BL.listSelectedL) pos selb
|
||||
in padBottom Max $
|
||||
vBox
|
||||
|
@ -24,6 +24,7 @@ import Swarm.Game.Robot
|
||||
import Swarm.Game.Scenario.Topography.EntityFacade
|
||||
import Swarm.Game.State
|
||||
import Swarm.Game.Terrain
|
||||
import Swarm.Game.Universe
|
||||
import Swarm.Game.World qualified as W
|
||||
import Swarm.TUI.Attr
|
||||
import Swarm.TUI.Editor.Masking
|
||||
@ -39,30 +40,37 @@ renderDisplay :: Display -> Widget n
|
||||
renderDisplay disp = withAttr (disp ^. displayAttr . to toAttrName) $ str [displayChar disp]
|
||||
|
||||
-- | Render the 'Display' for a specific location.
|
||||
drawLoc :: UIState -> GameState -> W.Coords -> Widget Name
|
||||
drawLoc ui g coords =
|
||||
drawLoc :: UIState -> GameState -> Cosmic W.Coords -> Widget Name
|
||||
drawLoc ui g cCoords@(Cosmic _ coords) =
|
||||
if shouldHideWorldCell ui coords
|
||||
then str " "
|
||||
else drawCell
|
||||
where
|
||||
showRobots = ui ^. uiShowRobots
|
||||
we = ui ^. uiWorldEditor
|
||||
drawCell = renderDisplay $ displayLoc showRobots we g coords
|
||||
drawCell = renderDisplay $ displayLoc showRobots we g cCoords
|
||||
|
||||
displayTerrainCell :: WorldEditor Name -> GameState -> W.Coords -> Display
|
||||
displayTerrainCell ::
|
||||
WorldEditor Name ->
|
||||
GameState ->
|
||||
Cosmic W.Coords ->
|
||||
Display
|
||||
displayTerrainCell worldEditor g coords =
|
||||
terrainMap M.! EU.getTerrainAt worldEditor (g ^. world) coords
|
||||
terrainMap M.! EU.getTerrainAt worldEditor (g ^. multiWorld) coords
|
||||
|
||||
displayRobotCell :: GameState -> W.Coords -> [Display]
|
||||
displayRobotCell ::
|
||||
GameState ->
|
||||
Cosmic W.Coords ->
|
||||
[Display]
|
||||
displayRobotCell g coords =
|
||||
map (view robotDisplay) $
|
||||
robotsAtLocation (W.coordsToLoc coords) g
|
||||
robotsAtLocation (fmap W.coordsToLoc coords) g
|
||||
|
||||
displayEntityCell :: WorldEditor Name -> GameState -> W.Coords -> [Display]
|
||||
displayEntityCell :: WorldEditor Name -> GameState -> Cosmic W.Coords -> [Display]
|
||||
displayEntityCell worldEditor g coords =
|
||||
maybeToList $ displayForEntity <$> maybeEntity
|
||||
where
|
||||
(_, maybeEntity) = EU.getContentAt worldEditor (g ^. world) coords
|
||||
(_, maybeEntity) = EU.getContentAt worldEditor (g ^. multiWorld) coords
|
||||
|
||||
displayForEntity :: EntityPaint -> Display
|
||||
displayForEntity e = (if known e then id else hidden) $ getDisplay e
|
||||
@ -89,14 +97,19 @@ hidingMode g
|
||||
-- 'Display's for the terrain, entity, and robots at the location, and
|
||||
-- taking into account "static" based on the distance to the robot
|
||||
-- being @view@ed.
|
||||
displayLoc :: Bool -> WorldEditor Name -> GameState -> W.Coords -> Display
|
||||
displayLoc showRobots we g coords =
|
||||
displayLoc :: Bool -> WorldEditor Name -> GameState -> Cosmic W.Coords -> Display
|
||||
displayLoc showRobots we g cCoords@(Cosmic _ coords) =
|
||||
staticDisplay g coords
|
||||
<> displayLocRaw showRobots we g coords
|
||||
<> displayLocRaw showRobots we g cCoords
|
||||
|
||||
-- | Get the 'Display' for a specific location, by combining the
|
||||
-- 'Display's for the terrain, entity, and robots at the location.
|
||||
displayLocRaw :: Bool -> WorldEditor Name -> GameState -> W.Coords -> Display
|
||||
displayLocRaw ::
|
||||
Bool ->
|
||||
WorldEditor Name ->
|
||||
GameState ->
|
||||
Cosmic W.Coords ->
|
||||
Display
|
||||
displayLocRaw showRobots worldEditor g coords = sconcat $ terrain NE.:| entity <> robots
|
||||
where
|
||||
terrain = displayTerrainCell worldEditor g coords
|
||||
@ -152,7 +165,7 @@ getStatic g coords
|
||||
where
|
||||
-- Offset from the location of the view center to the location under
|
||||
-- consideration for display.
|
||||
offset = W.coordsToLoc coords .-. (g ^. viewCenter)
|
||||
offset = W.coordsToLoc coords .-. (g ^. viewCenter . planar)
|
||||
|
||||
-- Hash.
|
||||
h =
|
||||
|
@ -21,6 +21,8 @@ module Swarm.Util (
|
||||
histogram,
|
||||
findDup,
|
||||
both,
|
||||
allEqual,
|
||||
surfaceEmpty,
|
||||
|
||||
-- * Directory utilities
|
||||
readFileMay,
|
||||
@ -71,10 +73,11 @@ module Swarm.Util (
|
||||
) where
|
||||
|
||||
import Control.Algebra (Has)
|
||||
import Control.Applicative (Alternative)
|
||||
import Control.Effect.State (State, modify, state)
|
||||
import Control.Effect.Throw (Throw, throwError)
|
||||
import Control.Lens (ASetter', Lens', LensLike, LensLike', Over, lens, (<>~))
|
||||
import Control.Monad (unless, (<=<))
|
||||
import Control.Monad (guard, unless, (<=<))
|
||||
import Control.Monad.Except (ExceptT (..), runExceptT)
|
||||
import Data.Bifunctor (Bifunctor (bimap), first)
|
||||
import Data.Char (isAlphaNum)
|
||||
@ -189,6 +192,13 @@ findDup = go S.empty
|
||||
both :: Bifunctor p => (a -> d) -> p a a -> p d d
|
||||
both f = bimap f f
|
||||
|
||||
allEqual :: (Ord a) => [a] -> Bool
|
||||
allEqual [] = True
|
||||
allEqual (x : xs) = all (== x) xs
|
||||
|
||||
surfaceEmpty :: Alternative f => (a -> Bool) -> a -> f a
|
||||
surfaceEmpty isEmpty t = t <$ guard (not (isEmpty t))
|
||||
|
||||
------------------------------------------------------------
|
||||
-- Directory stuff
|
||||
|
||||
|
@ -24,6 +24,7 @@ import Data.Char (isDigit)
|
||||
import Data.Either (lefts, rights)
|
||||
import Data.Foldable (toList)
|
||||
import Data.Maybe (listToMaybe)
|
||||
import Data.Text qualified as T
|
||||
import Data.Version (Version (..), parseVersion, showVersion)
|
||||
import Data.Yaml (ParseException, Parser, decodeEither', parseEither)
|
||||
import GitHash (GitInfo, giBranch)
|
||||
@ -38,6 +39,7 @@ import Network.HTTP.Client (
|
||||
import Network.HTTP.Client.TLS (tlsManagerSettings)
|
||||
import Network.HTTP.Types (hUserAgent)
|
||||
import Paths_swarm qualified
|
||||
import Swarm.Util (failT, quote)
|
||||
import Text.ParserCombinators.ReadP (readP_to_S)
|
||||
|
||||
-- $setup
|
||||
@ -104,7 +106,7 @@ parseRelease = \case
|
||||
t <- o .: "tag_name"
|
||||
if isSwarmReleaseTag t
|
||||
then return t
|
||||
else fail $ "The release '" <> t <> "' is not main Swarm release!"
|
||||
else failT ["The release", quote $ T.pack t, "is not main Swarm release!"]
|
||||
_otherValue -> fail "The JSON release is not an Object!"
|
||||
|
||||
data NewReleaseFailure where
|
||||
|
@ -103,6 +103,7 @@ library
|
||||
Swarm.Game.Robot
|
||||
Swarm.Game.Scenario
|
||||
Swarm.Game.Scenario.Topography.Cell
|
||||
Swarm.Game.Universe
|
||||
Swarm.TUI.Launch.Controller
|
||||
Swarm.TUI.Launch.Model
|
||||
Swarm.TUI.Launch.Prep
|
||||
@ -351,6 +352,7 @@ benchmark benchmark
|
||||
mtl,
|
||||
random,
|
||||
swarm,
|
||||
text
|
||||
text,
|
||||
containers
|
||||
default-language: Haskell2010
|
||||
ghc-options: -threaded
|
||||
|
@ -303,6 +303,9 @@ testScenarioSolution rs ui _ci _em =
|
||||
, testSolution Default "Testing/1256-halt-command"
|
||||
, testSolution Default "Testing/1295-density-command"
|
||||
, testSolution Default "Testing/1356-portals/portals-flip-and-rotate.yaml"
|
||||
, testSolution Default "Testing/144-subworlds/basic-subworld.yaml"
|
||||
, testSolution Default "Testing/144-subworlds/subworld-mapped-robots.yaml"
|
||||
, testSolution Default "Testing/144-subworlds/subworld-located-robots.yaml"
|
||||
]
|
||||
]
|
||||
where
|
||||
|
Loading…
Reference in New Issue
Block a user