mirror of
https://github.com/swarm-game/swarm.git
synced 2024-09-11 14:46:33 +03:00
Ability to "paint" robot locations in world descriptions (#571)
When describing a scenario, it is now possible to use characters to draw the location of a particular robot. This can also be used to easily make many copies of the same robot. - Robots in the `robots` list with a concrete `loc` will actually be created in the world. Those without a `loc` are only templates. - A `palette` entry can now optionally have a 3-tuple, indicating terrain, entity, and robot name. - Add a Game of Life example making use of the new functionality. - Did a lot of code refactoring along the way. Closes #557 .
This commit is contained in:
parent
4a21185e8f
commit
49d714252e
@ -9,16 +9,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.Functor.Const qualified as F
|
||||
import Data.Int (Int64)
|
||||
import Linear.V2 (V2 (V2))
|
||||
import Swarm.Game.CESK (emptyStore, initMachine)
|
||||
import Swarm.Game.Display (defaultRobotDisplay)
|
||||
import Swarm.Game.Robot (URobot, mkRobot)
|
||||
import Swarm.Game.State (GameState, addURobot, classicGame0, creativeMode, world)
|
||||
import Swarm.Game.Robot (TRobot, mkRobot)
|
||||
import Swarm.Game.State (GameState, addTRobot, classicGame0, creativeMode, world)
|
||||
import Swarm.Game.Step (gameTick)
|
||||
import Swarm.Game.Terrain (TerrainType (DirtT))
|
||||
import Swarm.Game.World (newWorld)
|
||||
import Swarm.Game.World (WorldFun (..), newWorld)
|
||||
import Swarm.Language.Context qualified as Context
|
||||
import Swarm.Language.Pipeline (ProcessedTerm)
|
||||
import Swarm.Language.Pipeline.QQ (tmQ)
|
||||
@ -71,20 +70,20 @@ circlerProgram =
|
||||
|]
|
||||
|
||||
-- | Initializes a robot with program prog at location loc facing north.
|
||||
initRobot :: ProcessedTerm -> V2 Int64 -> URobot
|
||||
initRobot prog loc = mkRobot (F.Const ()) Nothing "" [] north loc defaultRobotDisplay (initMachine prog Context.empty emptyStore) [] [] False 0
|
||||
initRobot :: ProcessedTerm -> V2 Int64 -> TRobot
|
||||
initRobot prog loc = mkRobot () Nothing "" [] (Just north) loc defaultRobotDisplay (initMachine prog Context.empty emptyStore) [] [] 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.
|
||||
mkGameState :: (V2 Int64 -> URobot) -> Int -> IO GameState
|
||||
mkGameState :: (V2 Int64 -> TRobot) -> Int -> IO GameState
|
||||
mkGameState robotMaker numRobots = do
|
||||
let robots = [robotMaker (V2 (fromIntegral x) 0) | x <- [0 .. numRobots - 1]]
|
||||
Right initState <- runExceptT classicGame0
|
||||
execStateT
|
||||
(mapM addURobot robots)
|
||||
(mapM addTRobot robots)
|
||||
( initState
|
||||
& creativeMode .~ True
|
||||
& world .~ newWorld (const (fromEnum DirtT, Nothing))
|
||||
& world .~ newWorld (WF $ const (fromEnum DirtT, Nothing))
|
||||
)
|
||||
|
||||
-- | Runs numGameTicks ticks of the game.
|
||||
|
@ -2,4 +2,5 @@ classic.yaml
|
||||
creative.yaml
|
||||
Tutorials
|
||||
Challenges
|
||||
Fun
|
||||
Testing
|
||||
|
@ -41,8 +41,8 @@ robots:
|
||||
world:
|
||||
default: [ice, knownwater]
|
||||
palette:
|
||||
'.': [grass, null]
|
||||
'#': [ice, null]
|
||||
'.': [grass]
|
||||
'#': [ice]
|
||||
'┌': [stone, upper left corner]
|
||||
'┐': [stone, upper right corner]
|
||||
'└': [stone, lower left corner]
|
||||
|
@ -29,7 +29,7 @@ robots:
|
||||
world:
|
||||
default: [ice, knownwater]
|
||||
palette:
|
||||
'.': [grass, null]
|
||||
'.': [grass]
|
||||
' ': [ice, knownwater]
|
||||
'~': [ice, knownwavywater]
|
||||
'L': [grass, Linux]
|
||||
|
@ -62,8 +62,8 @@ world:
|
||||
'~': [ice, knownwavywater]
|
||||
'*': [grass, knownflower]
|
||||
'T': [grass, knowntree]
|
||||
'.': [grass, null]
|
||||
'_': [stone, null]
|
||||
'.': [grass]
|
||||
'_': [stone]
|
||||
'┌': [stone, upper left corner]
|
||||
'┐': [stone, upper right corner]
|
||||
'└': [stone, lower left corner]
|
||||
|
@ -19,9 +19,9 @@ robots:
|
||||
inventory:
|
||||
- [0, lambda]
|
||||
world:
|
||||
default: [blank, none]
|
||||
default: [blank]
|
||||
palette:
|
||||
'.': [grass, null]
|
||||
'.': [grass]
|
||||
'┌': [stone, upper left corner]
|
||||
'┐': [stone, upper right corner]
|
||||
'└': [stone, lower left corner]
|
||||
|
1
data/scenarios/Fun/00-ORDER.txt
Normal file
1
data/scenarios/Fun/00-ORDER.txt
Normal file
@ -0,0 +1 @@
|
||||
GoL.yaml
|
80
data/scenarios/Fun/GoL.yaml
Normal file
80
data/scenarios/Fun/GoL.yaml
Normal file
@ -0,0 +1,80 @@
|
||||
name: Conway's Game of Life
|
||||
description: A basic implementation of the rules of the Game of Life.
|
||||
robots:
|
||||
- name: base
|
||||
display:
|
||||
attr: robot
|
||||
char: 'Ω'
|
||||
loc: [0,0]
|
||||
dir: [1,0]
|
||||
devices:
|
||||
- treads
|
||||
- compass
|
||||
- grabber
|
||||
- clock
|
||||
- logger
|
||||
inventory:
|
||||
- [1000, rock]
|
||||
- name: cell
|
||||
system: true
|
||||
dir: [0,1]
|
||||
display:
|
||||
invisible: true
|
||||
inventory:
|
||||
- [1, rock]
|
||||
program: |
|
||||
def forever = \c. c; forever c; end;
|
||||
def cnt = \x.
|
||||
if (x == inl ()) {0} {1}
|
||||
end;
|
||||
def count3 =
|
||||
h <- scan down;
|
||||
f <- scan forward;
|
||||
b <- scan back;
|
||||
return (cnt h + cnt f + cnt b)
|
||||
end;
|
||||
def mod : int -> int -> int = \a. \b. a - (a/b)*b end;
|
||||
def waitUntil = \p.
|
||||
b <- p;
|
||||
if b {wait 1} {waitUntil p}
|
||||
end;
|
||||
forever (
|
||||
h <- scan down;
|
||||
alive <- return (h != inl ());
|
||||
n1 <- count3;
|
||||
turn left; move; turn right; n2 <- count3;
|
||||
turn right; move; move; turn left; n3 <- count3;
|
||||
turn left; move; turn right;
|
||||
total <- return (n1 + n2 + n3 - if alive {1} {0});
|
||||
if (alive && (total < 2 || total > 3))
|
||||
{ grab; return () }
|
||||
{ if (not alive && total == 3)
|
||||
{ place "rock" }
|
||||
{}
|
||||
};
|
||||
// synchronize
|
||||
waitUntil (t <- time; return (mod t 0x20 == 0))
|
||||
)
|
||||
world:
|
||||
default: [ice]
|
||||
palette:
|
||||
'o': [ice, rock, cell]
|
||||
'.': [ice, null, cell]
|
||||
upperleft: [1,-1]
|
||||
map: |
|
||||
..............................
|
||||
..............................
|
||||
......o.......................
|
||||
.......o......................
|
||||
.....ooo......................
|
||||
..............................
|
||||
..............................
|
||||
..............................
|
||||
..............................
|
||||
..............................
|
||||
..............................
|
||||
..............................
|
||||
...............oooooooooo.....
|
||||
..............................
|
||||
..............................
|
||||
..............................
|
@ -24,7 +24,7 @@ robots:
|
||||
world:
|
||||
default: [blank, null]
|
||||
palette:
|
||||
'.': [grass, null]
|
||||
'.': [grass]
|
||||
'~': [dirt, knownwater]
|
||||
'┌': [stone, upper left corner]
|
||||
'┐': [stone, upper right corner]
|
||||
|
@ -26,7 +26,7 @@ robots:
|
||||
world:
|
||||
default: [blank, null]
|
||||
palette:
|
||||
'.': [grass, null]
|
||||
'.': [grass]
|
||||
'~': [dirt, knownwater]
|
||||
'┌': [stone, upper left corner]
|
||||
'┐': [stone, upper right corner]
|
||||
|
@ -27,7 +27,7 @@ robots:
|
||||
world:
|
||||
default: [blank, null]
|
||||
palette:
|
||||
'.': [grass, null]
|
||||
'.': [grass]
|
||||
'~': [dirt, knownwater]
|
||||
'┌': [stone, upper left corner]
|
||||
'┐': [stone, upper right corner]
|
||||
|
@ -30,7 +30,7 @@ robots:
|
||||
world:
|
||||
default: [blank, null]
|
||||
palette:
|
||||
'.': [grass, null]
|
||||
'.': [grass]
|
||||
'┌': [stone, upper left corner]
|
||||
'┐': [stone, upper right corner]
|
||||
'└': [stone, lower left corner]
|
||||
|
@ -28,7 +28,7 @@ robots:
|
||||
world:
|
||||
default: [blank, null]
|
||||
palette:
|
||||
'.': [grass, null]
|
||||
'.': [grass]
|
||||
'┌': [stone, upper left corner]
|
||||
'┐': [stone, upper right corner]
|
||||
'└': [stone, lower left corner]
|
||||
|
@ -45,7 +45,7 @@ robots:
|
||||
world:
|
||||
default: [blank, null]
|
||||
palette:
|
||||
'.': [grass, null]
|
||||
'.': [grass]
|
||||
'~': [dirt, knownwater]
|
||||
'┌': [stone, upper left corner]
|
||||
'┐': [stone, upper right corner]
|
||||
|
@ -45,7 +45,7 @@ robots:
|
||||
world:
|
||||
default: [blank, null]
|
||||
palette:
|
||||
'.': [grass, null]
|
||||
'.': [grass]
|
||||
'~': [dirt, knownwater]
|
||||
'┌': [stone, upper left corner]
|
||||
'┐': [stone, upper right corner]
|
||||
|
@ -33,9 +33,9 @@ robots:
|
||||
inventory:
|
||||
- [1, detonator] # used to mark win
|
||||
world:
|
||||
default: [blank, none]
|
||||
default: [blank]
|
||||
palette:
|
||||
'.': [grass, null]
|
||||
'.': [grass]
|
||||
'M': [stone, mountain]
|
||||
'┌': [stone, upper left corner]
|
||||
'┐': [stone, upper right corner]
|
||||
|
@ -42,9 +42,9 @@ entities:
|
||||
growth: [0,0]
|
||||
yields: water
|
||||
world:
|
||||
default: [blank, none]
|
||||
default: [blank]
|
||||
palette:
|
||||
'.': [grass, null]
|
||||
'.': [grass]
|
||||
' ': [ice, knownwater]
|
||||
'┌': [stone, upper left corner]
|
||||
'┐': [stone, upper right corner]
|
||||
|
@ -30,9 +30,9 @@ robots:
|
||||
program: |
|
||||
log "I shall sleep"; wait 1; log "I have awoken"
|
||||
world:
|
||||
default: [blank, none]
|
||||
default: [blank]
|
||||
palette:
|
||||
'.': [grass, null]
|
||||
'.': [grass]
|
||||
'┌': [stone, upper left corner]
|
||||
'┐': [stone, upper right corner]
|
||||
'└': [stone, lower left corner]
|
||||
|
@ -75,9 +75,9 @@ entities:
|
||||
- You win!
|
||||
properties: [known, portable]
|
||||
world:
|
||||
default: [blank, none]
|
||||
default: [blank]
|
||||
palette:
|
||||
'.': [grass, null]
|
||||
'.': [grass]
|
||||
upperleft: [0,0]
|
||||
map: |
|
||||
.
|
||||
|
@ -57,9 +57,9 @@ entities:
|
||||
properties: [known, portable, growable]
|
||||
growth: [1,2]
|
||||
world:
|
||||
default: [blank, none]
|
||||
default: [blank]
|
||||
palette:
|
||||
'.': [grass, null]
|
||||
'.': [grass]
|
||||
upperleft: [0,0]
|
||||
map: |
|
||||
.
|
||||
|
@ -24,9 +24,9 @@ robots:
|
||||
- grabber
|
||||
- boat
|
||||
world:
|
||||
default: [blank, none]
|
||||
default: [blank]
|
||||
palette:
|
||||
'.': [grass, null]
|
||||
'.': [grass]
|
||||
'T': [stone, tree]
|
||||
'┌': [stone, upper left corner]
|
||||
'┐': [stone, upper right corner]
|
||||
|
@ -21,9 +21,9 @@ robots:
|
||||
inventory:
|
||||
- [1, tree]
|
||||
world:
|
||||
default: [blank, none]
|
||||
default: [blank]
|
||||
palette:
|
||||
'.': [grass, null]
|
||||
'.': [grass]
|
||||
'┌': [stone, upper left corner]
|
||||
'┐': [stone, upper right corner]
|
||||
'└': [stone, lower left corner]
|
||||
|
@ -29,7 +29,7 @@ robots:
|
||||
world:
|
||||
default: [ice, knownwater]
|
||||
palette:
|
||||
'.': [grass, null]
|
||||
'.': [grass]
|
||||
' ': [ice, knownwater]
|
||||
'┌': [stone, upper left corner]
|
||||
'┐': [stone, upper right corner]
|
||||
|
@ -41,7 +41,6 @@ solution: |
|
||||
place "Win"
|
||||
robots:
|
||||
- name: base
|
||||
loc: [0,0]
|
||||
dir: [1,0]
|
||||
devices:
|
||||
- treads
|
||||
@ -53,9 +52,9 @@ robots:
|
||||
- [1, Win]
|
||||
- [0, tree]
|
||||
world:
|
||||
default: [blank, none]
|
||||
default: [blank]
|
||||
palette:
|
||||
'.': [grass, null]
|
||||
'>': [grass, null, base]
|
||||
'T': [grass, tree]
|
||||
'┌': [stone, upper left corner]
|
||||
'┐': [stone, upper right corner]
|
||||
@ -66,5 +65,5 @@ world:
|
||||
upperleft: [-1, 1]
|
||||
map: |
|
||||
┌───┐
|
||||
│.TT│
|
||||
│>TT│
|
||||
└───┘
|
||||
|
@ -45,7 +45,6 @@ solution: |
|
||||
build {move; move; t <- grab; turn right; move; place t}
|
||||
robots:
|
||||
- name: base
|
||||
loc: [0,0]
|
||||
dir: [1,0]
|
||||
display:
|
||||
char: Ω
|
||||
@ -60,9 +59,10 @@ robots:
|
||||
- [10, grabber]
|
||||
- [10, treads]
|
||||
world:
|
||||
default: [blank, none]
|
||||
default: [blank]
|
||||
palette:
|
||||
'.': [grass, null]
|
||||
'Ω': [grass, null, base]
|
||||
'.': [grass]
|
||||
'~': [ice, knownwater]
|
||||
'*': [grass, pickerelweed]
|
||||
'┌': [stone, upper left corner]
|
||||
@ -74,7 +74,7 @@ world:
|
||||
upperleft: [-1, 1]
|
||||
map: |
|
||||
┌───┐
|
||||
│..*│
|
||||
│Ω.*│
|
||||
│...│
|
||||
│~~~│
|
||||
└───┘
|
||||
|
@ -19,7 +19,9 @@ solution: |
|
||||
make "branch"; make "branch predictor"
|
||||
robots:
|
||||
- name: base
|
||||
loc: [0,0]
|
||||
display:
|
||||
attr: robot
|
||||
char: 'Ω'
|
||||
dir: [1,0]
|
||||
devices:
|
||||
- workbench
|
||||
@ -27,17 +29,17 @@ robots:
|
||||
inventory:
|
||||
- [10, tree]
|
||||
world:
|
||||
default: [blank, none]
|
||||
default: [blank]
|
||||
palette:
|
||||
'Ω': [grass, null, base]
|
||||
'┌': [stone, upper left corner]
|
||||
'┐': [stone, upper right corner]
|
||||
'└': [stone, lower left corner]
|
||||
'┘': [stone, lower right corner]
|
||||
'─': [stone, horizontal wall]
|
||||
'│': [stone, vertical wall]
|
||||
' ': [grass, null]
|
||||
upperleft: [-1, 1]
|
||||
map: |
|
||||
┌─┐
|
||||
│ │
|
||||
│Ω│
|
||||
└─┘
|
||||
|
@ -60,7 +60,6 @@ solution: |
|
||||
};
|
||||
robots:
|
||||
- name: base
|
||||
loc: [0,0]
|
||||
dir: [1,0]
|
||||
display:
|
||||
char: Ω
|
||||
@ -78,7 +77,6 @@ robots:
|
||||
- [10, treads]
|
||||
- [10, grabber]
|
||||
- name: secret
|
||||
loc: [3, 0]
|
||||
dir: [0, 0]
|
||||
devices:
|
||||
- logger
|
||||
@ -88,15 +86,16 @@ robots:
|
||||
inventory:
|
||||
- [100000, Win]
|
||||
display:
|
||||
char: '▒'
|
||||
attr: grass
|
||||
invisible: true
|
||||
system: true
|
||||
program: |
|
||||
run "data/scenarios/Tutorials/secret.sw"
|
||||
world:
|
||||
default: [blank, none]
|
||||
default: [blank]
|
||||
palette:
|
||||
'.': [grass, null]
|
||||
'Ω': [grass, null, base]
|
||||
'!': [grass, null, secret]
|
||||
'.': [grass]
|
||||
'~': [ice, knownwater]
|
||||
'T': [grass, knowntree]
|
||||
'A': [stone, knownmountain]
|
||||
@ -111,5 +110,5 @@ world:
|
||||
┌─────┐
|
||||
│AAAT~│
|
||||
│..A.~│
|
||||
│....A│
|
||||
│Ω..!A│
|
||||
└─────┘
|
||||
|
@ -23,7 +23,6 @@ solution:
|
||||
move; grab;
|
||||
robots:
|
||||
- name: base
|
||||
loc: [0,0]
|
||||
dir: [1,0]
|
||||
devices:
|
||||
- treads
|
||||
@ -33,9 +32,10 @@ robots:
|
||||
inventory:
|
||||
- [0, tree]
|
||||
world:
|
||||
default: [blank, none]
|
||||
default: [blank]
|
||||
palette:
|
||||
'.': [grass, null]
|
||||
'>': [grass, null, base]
|
||||
'.': [grass]
|
||||
'T': [grass, tree]
|
||||
'┌': [stone, upper left corner]
|
||||
'┐': [stone, upper right corner]
|
||||
@ -46,5 +46,5 @@ world:
|
||||
upperleft: [-1, 1]
|
||||
map: |
|
||||
┌────────┐
|
||||
│..TTTTTT│
|
||||
│>.TTTTTT│
|
||||
└────────┘
|
||||
|
@ -41,7 +41,6 @@ solution: |
|
||||
turn south; move; grab; install base "3D printer"; build {log "Hello World!"};
|
||||
robots:
|
||||
- name: base
|
||||
loc: [0,0]
|
||||
dir: [1,0]
|
||||
devices:
|
||||
- logger
|
||||
@ -52,9 +51,10 @@ robots:
|
||||
- [10, solar panel]
|
||||
- [10, logger]
|
||||
world:
|
||||
default: [blank, none]
|
||||
default: [blank]
|
||||
palette:
|
||||
'.': [grass, null]
|
||||
'>': [grass, null, base]
|
||||
'.': [grass]
|
||||
'~': [ice, knownwater]
|
||||
'3': [grass, knownprinter]
|
||||
'┌': [stone, upper left corner]
|
||||
@ -66,7 +66,7 @@ world:
|
||||
upperleft: [-1, 1]
|
||||
map: |
|
||||
┌───┐
|
||||
│...│
|
||||
│>..│
|
||||
│3..│
|
||||
│~~~│
|
||||
└───┘
|
||||
|
@ -21,15 +21,15 @@ solution: |
|
||||
move; move
|
||||
robots:
|
||||
- name: base
|
||||
loc: [0,0]
|
||||
dir: [1,0]
|
||||
devices:
|
||||
- treads
|
||||
- logger
|
||||
world:
|
||||
default: [blank, none]
|
||||
default: [blank]
|
||||
palette:
|
||||
'.': [grass, null]
|
||||
'>': [grass, null, base]
|
||||
'.': [grass]
|
||||
'┌': [stone, upper left corner]
|
||||
'┐': [stone, upper right corner]
|
||||
'└': [stone, lower left corner]
|
||||
@ -39,5 +39,5 @@ world:
|
||||
upperleft: [-1, 1]
|
||||
map: |
|
||||
┌───┐
|
||||
│...│
|
||||
│>..│
|
||||
└───┘
|
||||
|
@ -56,7 +56,6 @@ solution: |
|
||||
turn back; h; h; h; h; h; h;
|
||||
robots:
|
||||
- name: base
|
||||
loc: [0,0]
|
||||
dir: [1,0]
|
||||
devices:
|
||||
- treads
|
||||
@ -68,9 +67,10 @@ robots:
|
||||
inventory:
|
||||
- [0, spruce]
|
||||
world:
|
||||
default: [blank, none]
|
||||
default: [blank]
|
||||
palette:
|
||||
'.': [grass, null]
|
||||
'>': [grass, null, base]
|
||||
'.': [grass]
|
||||
'T': [grass, spruce]
|
||||
'┌': [stone, upper left corner]
|
||||
'┐': [stone, upper right corner]
|
||||
@ -81,5 +81,5 @@ world:
|
||||
upperleft: [-1, 1]
|
||||
map: |
|
||||
┌────────┐
|
||||
│..T.....│
|
||||
│>.T.....│
|
||||
└────────┘
|
||||
|
@ -41,7 +41,6 @@ solution: |
|
||||
build {require "boat"; move; move; move; move; move; f <- grab; turn back; move; move; move; move; move; give base f}
|
||||
robots:
|
||||
- name: base
|
||||
loc: [0,0]
|
||||
dir: [1,0]
|
||||
display:
|
||||
char: Ω
|
||||
@ -57,9 +56,10 @@ robots:
|
||||
- [10, grabber]
|
||||
- [10, scanner]
|
||||
world:
|
||||
default: [blank, none]
|
||||
default: [blank]
|
||||
palette:
|
||||
'.': [grass, null]
|
||||
'Ω': [grass, null, base]
|
||||
'.': [grass]
|
||||
'~': [ice, knownwater]
|
||||
'*': [grass, periwinkle]
|
||||
'┌': [stone, upper left corner]
|
||||
@ -73,7 +73,7 @@ world:
|
||||
┌──────┐
|
||||
│..~~..│
|
||||
│..~~..│
|
||||
│..~~.*│
|
||||
│Ω.~~.*│
|
||||
│..~~..│
|
||||
│..~~..│
|
||||
└──────┘
|
||||
|
@ -40,7 +40,6 @@ solution: |
|
||||
build {require 4 "rock"; move; move; move; move; turn right; move; place "rock"; move; place "rock"; move; place "rock"; move; place "rock"}
|
||||
robots:
|
||||
- name: base
|
||||
loc: [0,0]
|
||||
dir: [1,0]
|
||||
display:
|
||||
char: Ω
|
||||
@ -59,12 +58,11 @@ robots:
|
||||
- [16, scanner]
|
||||
- [100, rock]
|
||||
world:
|
||||
default: [blank, none]
|
||||
default: [blank]
|
||||
palette:
|
||||
'.': [grass, null]
|
||||
'_': [stone, null]
|
||||
'~': [ice, knownwater]
|
||||
'*': [grass, periwinkle]
|
||||
'Ω': [grass, null, base]
|
||||
'.': [grass]
|
||||
'_': [stone]
|
||||
'┌': [stone, upper left corner]
|
||||
'┐': [stone, upper right corner]
|
||||
'└': [stone, lower left corner]
|
||||
@ -74,7 +72,7 @@ world:
|
||||
upperleft: [-1, 1]
|
||||
map: |
|
||||
┌─────┐
|
||||
│.....│
|
||||
│Ω....│
|
||||
│.____│
|
||||
│.____│
|
||||
│.____│
|
||||
|
@ -28,7 +28,6 @@ solution: |
|
||||
}
|
||||
robots:
|
||||
- name: base
|
||||
loc: [0,0]
|
||||
dir: [1,0]
|
||||
display:
|
||||
char: Ω
|
||||
@ -43,9 +42,10 @@ robots:
|
||||
- [10, treads]
|
||||
- [10, solar panel]
|
||||
world:
|
||||
default: [blank, none]
|
||||
default: [blank]
|
||||
palette:
|
||||
'.': [grass, null]
|
||||
'Ω': [grass, null, base]
|
||||
'.': [grass]
|
||||
'~': [ice, wavy water]
|
||||
'T': [grass, tree]
|
||||
'A': [stone, mountain]
|
||||
@ -60,5 +60,5 @@ world:
|
||||
┌─────┐
|
||||
│AAAT~│
|
||||
│..A.~│
|
||||
│....A│
|
||||
│Ω...A│
|
||||
└─────┘
|
||||
|
@ -48,16 +48,16 @@ solution: |
|
||||
|
||||
robots:
|
||||
- name: base
|
||||
loc: [0,0]
|
||||
dir: [1,0]
|
||||
devices:
|
||||
- treads
|
||||
- compass
|
||||
- logger
|
||||
world:
|
||||
default: [blank, none]
|
||||
default: [blank]
|
||||
palette:
|
||||
'.': [grass, null]
|
||||
'>': [grass, null, base]
|
||||
'.': [grass]
|
||||
'├': [stone, left T]
|
||||
'┤': [stone, right T]
|
||||
'┌': [stone, upper left corner]
|
||||
@ -74,5 +74,5 @@ world:
|
||||
│.───┤
|
||||
│....│
|
||||
├───.│
|
||||
│....│
|
||||
│>...│
|
||||
└────┘
|
||||
|
@ -45,7 +45,6 @@ solution: |
|
||||
|
||||
robots:
|
||||
- name: base
|
||||
loc: [0,0]
|
||||
dir: [1,0]
|
||||
devices:
|
||||
- treads
|
||||
@ -55,9 +54,10 @@ robots:
|
||||
inventory:
|
||||
- [1, Win]
|
||||
world:
|
||||
default: [blank, none]
|
||||
default: [blank]
|
||||
palette:
|
||||
'.': [grass, null]
|
||||
'>': [grass, null, base]
|
||||
'.': [grass]
|
||||
'┌': [stone, upper left corner]
|
||||
'┐': [stone, upper right corner]
|
||||
'└': [stone, lower left corner]
|
||||
@ -67,6 +67,6 @@ world:
|
||||
upperleft: [-1, 1]
|
||||
map: |
|
||||
┌───┐
|
||||
│...│
|
||||
│>..│
|
||||
│...│
|
||||
└───┘
|
@ -36,7 +36,7 @@ import Data.Tuple (swap)
|
||||
import Swarm.Game.Entity (Entity, EntityMap (entitiesByName), entityName, loadEntities)
|
||||
import Swarm.Game.Entity qualified as E
|
||||
import Swarm.Game.Recipe (Recipe, loadRecipes, recipeInputs, recipeOutputs, recipeRequirements)
|
||||
import Swarm.Game.Robot (installedDevices, robotInventory, setRobotID)
|
||||
import Swarm.Game.Robot (installedDevices, instantiateRobot, robotInventory)
|
||||
import Swarm.Game.Scenario (Scenario, loadScenario, scenarioRobots)
|
||||
import Swarm.Game.WorldGen (testWorld2Entites)
|
||||
import Swarm.Language.Capability (capabilityName, constCaps)
|
||||
@ -363,10 +363,10 @@ classicScenario = do
|
||||
loadScenario "data/scenarios/classic.yaml" entities
|
||||
|
||||
startingDevices :: Scenario -> Set Entity
|
||||
startingDevices = Set.fromList . map snd . E.elems . view installedDevices . setRobotID 0 . head . view scenarioRobots
|
||||
startingDevices = Set.fromList . map snd . E.elems . view installedDevices . instantiateRobot 0 . head . view scenarioRobots
|
||||
|
||||
startingInventory :: Scenario -> Map Entity Int
|
||||
startingInventory = Map.fromList . map swap . E.elems . view robotInventory . setRobotID 0 . head . view scenarioRobots
|
||||
startingInventory = Map.fromList . map swap . E.elems . view robotInventory . instantiateRobot 0 . head . view scenarioRobots
|
||||
|
||||
-- | Ignore utility entites that are just used for tutorials and challenges.
|
||||
ignoredEntites :: Set Text
|
||||
|
@ -1,7 +1,9 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
@ -23,10 +25,11 @@ module Swarm.Game.Robot (
|
||||
leTime,
|
||||
|
||||
-- * Robots
|
||||
RobotPhase (..),
|
||||
RID,
|
||||
RobotR,
|
||||
Robot,
|
||||
URobot,
|
||||
TRobot,
|
||||
|
||||
-- * Robot context
|
||||
RobotContext,
|
||||
@ -38,10 +41,12 @@ module Swarm.Game.Robot (
|
||||
-- ** Lenses
|
||||
robotEntity,
|
||||
robotName,
|
||||
trobotName,
|
||||
robotCreatedAt,
|
||||
robotDisplay,
|
||||
robotLocation,
|
||||
unsafeSetRobotLocation,
|
||||
trobotLocation,
|
||||
robotOrientation,
|
||||
robotInventory,
|
||||
installedDevices,
|
||||
@ -58,9 +63,9 @@ module Swarm.Game.Robot (
|
||||
tickSteps,
|
||||
runningAtomic,
|
||||
|
||||
-- ** Create
|
||||
-- ** Creation & instantiation
|
||||
mkRobot,
|
||||
setRobotID,
|
||||
instantiateRobot,
|
||||
|
||||
-- ** Query
|
||||
robotKnows,
|
||||
@ -73,20 +78,15 @@ import Control.Lens hiding (contains)
|
||||
import Data.Aeson (FromJSON, ToJSON)
|
||||
import Data.Hashable (hashWithSalt)
|
||||
import Data.Int (Int64)
|
||||
import Data.Maybe (isNothing)
|
||||
import Data.Maybe (fromMaybe, isNothing)
|
||||
import Data.Sequence (Seq)
|
||||
import Data.Sequence qualified as Seq
|
||||
import Data.Set (Set)
|
||||
import Data.Set.Lens (setOf)
|
||||
import Data.Text (Text)
|
||||
import Data.Yaml ((.!=), (.:), (.:?))
|
||||
import GHC.Generics (Generic)
|
||||
import Linear
|
||||
import System.Clock (TimeSpec)
|
||||
|
||||
import Data.Yaml ((.!=), (.:), (.:?))
|
||||
import Swarm.Util ()
|
||||
import Swarm.Util.Yaml
|
||||
|
||||
import Swarm.Game.CESK
|
||||
import Swarm.Game.Display (Display, curOrientation, defaultRobotDisplay)
|
||||
import Swarm.Game.Entity hiding (empty)
|
||||
@ -96,6 +96,9 @@ import Swarm.Language.Context qualified as Ctx
|
||||
import Swarm.Language.Requirement (ReqCtx)
|
||||
import Swarm.Language.Syntax (toDirection)
|
||||
import Swarm.Language.Types (TCtx)
|
||||
import Swarm.Util ()
|
||||
import Swarm.Util.Yaml
|
||||
import System.Clock (TimeSpec)
|
||||
|
||||
-- | A record that stores the information
|
||||
-- for all defintions stored in a 'Robot'
|
||||
@ -133,10 +136,30 @@ makeLenses ''LogEntry
|
||||
-- | A unique identifier for a robot.
|
||||
type RID = Int
|
||||
|
||||
-- | The phase of a robot description record.
|
||||
data RobotPhase
|
||||
= -- | The robot record has just been read in from a scenario
|
||||
-- description; it represents a /template/ that may later be
|
||||
-- instantiated as one or more concrete robots.
|
||||
TemplateRobot
|
||||
| -- | The robot record represents a concrete robot in the world.
|
||||
ConcreteRobot
|
||||
|
||||
-- | 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) :: * where
|
||||
RobotLocation 'TemplateRobot = Maybe (V2 Int64)
|
||||
RobotLocation 'ConcreteRobot = V2 Int64
|
||||
|
||||
-- | Robot templates have no ID; concrete robots definitely do.
|
||||
type family RobotID (phase :: RobotPhase) :: * where
|
||||
RobotID 'TemplateRobot = ()
|
||||
RobotID 'ConcreteRobot = RID
|
||||
|
||||
-- | A value of type 'RobotR' is a record representing the state of a
|
||||
-- single robot. The @f@ parameter is for tracking whether or not
|
||||
-- the robot has been assigned a unique ID.
|
||||
data RobotR f = RobotR
|
||||
data RobotR (phase :: RobotPhase) = RobotR
|
||||
{ _robotEntity :: Entity
|
||||
, _installedDevices :: Inventory
|
||||
, -- | A cached view of the capabilities this robot has.
|
||||
@ -144,9 +167,9 @@ data RobotR f = RobotR
|
||||
_robotCapabilities :: Set Capability
|
||||
, _robotLog :: Seq LogEntry
|
||||
, _robotLogUpdated :: Bool
|
||||
, _robotLocation :: V2 Int64
|
||||
, _robotLocation :: RobotLocation phase
|
||||
, _robotContext :: RobotContext
|
||||
, _robotID :: f RID -- Might or might not have an ID yet!
|
||||
, _robotID :: RobotID phase
|
||||
, _robotParentID :: Maybe RID
|
||||
, _machine :: CESK
|
||||
, _systemRobot :: Bool
|
||||
@ -157,12 +180,12 @@ data RobotR f = RobotR
|
||||
}
|
||||
deriving (Generic)
|
||||
|
||||
deriving instance Show (f RID) => Show (RobotR f)
|
||||
deriving instance (Show (RobotLocation phase), Show (RobotID phase)) => Show (RobotR phase)
|
||||
|
||||
-- See https://byorgey.wordpress.com/2021/09/17/automatically-updated-cached-views-with-lens/
|
||||
-- for the approach used here with lenses.
|
||||
|
||||
let exclude = ['_robotCapabilities, '_installedDevices, '_robotLog, '_robotID, '_robotLocation]
|
||||
let exclude = ['_robotCapabilities, '_installedDevices, '_robotLog]
|
||||
in makeLensesWith
|
||||
( lensRules
|
||||
& generateSignatures .~ False
|
||||
@ -171,15 +194,16 @@ let exclude = ['_robotCapabilities, '_installedDevices, '_robotLog, '_robotID, '
|
||||
)
|
||||
''RobotR
|
||||
|
||||
-- | An Unidentified robot, i.e. a robot record without a unique ID number.
|
||||
type URobot = RobotR (Const ())
|
||||
-- | A template robot, i.e. a template robot record without a unique ID number,
|
||||
-- and possibly without a location.
|
||||
type TRobot = RobotR 'TemplateRobot
|
||||
|
||||
-- | A robot with a unique ID number.
|
||||
type Robot = RobotR Identity
|
||||
-- | A concrete robot, with a unique ID number and a specific location.
|
||||
type Robot = RobotR 'ConcreteRobot
|
||||
|
||||
-- In theory we could make all these lenses over (RobotR f), but that
|
||||
-- leads to lots of type ambiguity problems later. In practice we
|
||||
-- only need lenses for Robots.
|
||||
-- In theory we could make all these lenses over (RobotR phase), but
|
||||
-- that leads to lots of type ambiguity problems later. In practice
|
||||
-- we only need lenses for Robots.
|
||||
|
||||
-- | Robots are not entities, but they have almost all the
|
||||
-- characteristics of one (or perhaps we could think of robots as
|
||||
@ -191,16 +215,24 @@ type Robot = RobotR Identity
|
||||
-- directly reference fields inside this record; for example, one
|
||||
-- can use 'robotName' instead of writing @'robotEntity'
|
||||
-- . 'entityName'@.
|
||||
robotEntity :: Lens' Robot Entity
|
||||
robotEntity :: Lens' (RobotR phase) Entity
|
||||
|
||||
-- | The creation date of the robot.
|
||||
robotCreatedAt :: Lens' Robot TimeSpec
|
||||
|
||||
-- | The name of a robot. Note that unlike entities, robot names are
|
||||
-- expected to be globally unique
|
||||
-- robotName and trobotName could be generalized to robotName' ::
|
||||
-- Lens' (RobotR phase) Text. However, type inference does not work
|
||||
-- very well with the polymorphic version, so we export both
|
||||
-- monomorphic versions instead.
|
||||
|
||||
-- | The name of a robot.
|
||||
robotName :: Lens' Robot Text
|
||||
robotName = robotEntity . entityName
|
||||
|
||||
-- | The name of a robot template.
|
||||
trobotName :: Lens' TRobot Text
|
||||
trobotName = robotEntity . entityName
|
||||
|
||||
-- | The 'Display' of a robot. This is a special lens that
|
||||
-- automatically sets the 'curOrientation' to the orientation of the
|
||||
-- robot every time you do a @get@ operation. Technically this does
|
||||
@ -220,7 +252,6 @@ robotDisplay = lens getDisplay setDisplay
|
||||
-- to update the 'robotsByLocation' map as well. You can use the
|
||||
-- 'updateRobotLocation' function for this purpose.
|
||||
robotLocation :: Getter Robot (V2 Int64)
|
||||
robotLocation = to _robotLocation
|
||||
|
||||
-- | Set a robot's location. This is unsafe and should never be
|
||||
-- called directly except by the 'updateRobotLocation' function.
|
||||
@ -229,6 +260,12 @@ robotLocation = to _robotLocation
|
||||
unsafeSetRobotLocation :: V2 Int64 -> 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 (V2 Int64))
|
||||
trobotLocation = lens _robotLocation (\r l -> r {_robotLocation = l})
|
||||
|
||||
-- | Which way the robot is currently facing.
|
||||
robotOrientation :: Lens' Robot (Maybe (V2 Int64))
|
||||
robotOrientation = robotEntity . entityOrientation
|
||||
@ -243,12 +280,18 @@ robotContext :: Lens' Robot RobotContext
|
||||
-- | The (unique) ID number of the robot. This is only a Getter since
|
||||
-- the robot ID is immutable.
|
||||
robotID :: Getter Robot RID
|
||||
robotID = to (runIdentity . _robotID)
|
||||
|
||||
-- | Set the ID number of a robot, changing it from unidentified to
|
||||
-- identified.
|
||||
setRobotID :: RID -> URobot -> Robot
|
||||
setRobotID i r = r {_robotID = Identity i}
|
||||
-- | Instantiate a robot template to make it into a concrete robot, by
|
||||
-- providing a robot ID. Concrete robots also require a location;
|
||||
-- if the robot template didn't have a location already, just set
|
||||
-- the location to (0,0) by default. If you want a different location,
|
||||
-- set it via 'trobotLocation' before calling 'instantiateRobot'.
|
||||
instantiateRobot :: RID -> TRobot -> Robot
|
||||
instantiateRobot i r =
|
||||
r
|
||||
{ _robotID = i
|
||||
, _robotLocation = fromMaybe (V2 0 0) (_robotLocation r)
|
||||
}
|
||||
|
||||
-- | The ID number of the robot's parent, that is, the robot that
|
||||
-- built (or most recently reprogrammed) this robot, if there is
|
||||
@ -373,7 +416,7 @@ runningAtomic :: Lens' Robot Bool
|
||||
-- | A general function for creating robots.
|
||||
mkRobot ::
|
||||
-- | ID number of the robot.
|
||||
f Int ->
|
||||
RobotID phase ->
|
||||
-- | ID number of the robot's parent, if it has one.
|
||||
Maybe Int ->
|
||||
-- | Name of the robot.
|
||||
@ -381,7 +424,7 @@ mkRobot ::
|
||||
-- | Description of the robot.
|
||||
[Text] ->
|
||||
-- | Initial location.
|
||||
V2 Int64 ->
|
||||
RobotLocation phase ->
|
||||
-- | Initial heading/direction.
|
||||
V2 Int64 ->
|
||||
-- | Robot display.
|
||||
@ -396,7 +439,7 @@ mkRobot ::
|
||||
Bool ->
|
||||
-- | Creation date
|
||||
TimeSpec ->
|
||||
RobotR f
|
||||
RobotR phase
|
||||
mkRobot rid pid name descr loc dir disp m devs inv sys ts =
|
||||
RobotR
|
||||
{ _robotEntity =
|
||||
@ -423,15 +466,15 @@ mkRobot rid pid name descr loc dir disp m devs inv sys ts =
|
||||
|
||||
-- | We can parse a robot from a YAML file if we have access to an
|
||||
-- 'EntityMap' in which we can look up the names of entities.
|
||||
instance FromJSONE EntityMap URobot where
|
||||
instance FromJSONE EntityMap TRobot where
|
||||
parseJSONE = withObjectE "robot" $ \v ->
|
||||
-- Note we can't generate a unique ID here since we don't have
|
||||
-- access to a 'State GameState' effect; a unique ID will be
|
||||
-- filled in later when adding the robot to the world.
|
||||
mkRobot (Const ()) Nothing
|
||||
mkRobot () Nothing
|
||||
<$> liftE (v .: "name")
|
||||
<*> liftE (v .:? "description" .!= [])
|
||||
<*> liftE (v .: "loc")
|
||||
<*> liftE (v .:? "loc")
|
||||
<*> liftE (v .: "dir")
|
||||
<*> liftE (v .:? "display" .!= defaultRobotDisplay)
|
||||
<*> liftE (mkMachine <$> (v .:? "program"))
|
||||
|
@ -3,6 +3,7 @@
|
||||
{-# LANGUAGE DerivingVia #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
-- |
|
||||
@ -16,8 +17,12 @@
|
||||
-- conditions, which can be used both for building interactive
|
||||
-- tutorials and for standalone puzzles and scenarios.
|
||||
module Swarm.Game.Scenario (
|
||||
-- * The Scenario type
|
||||
Scenario (..),
|
||||
-- * WorldDescription
|
||||
Cell (..),
|
||||
WorldDescription (..),
|
||||
|
||||
-- * Scenario
|
||||
Scenario,
|
||||
|
||||
-- ** Fields
|
||||
scenarioName,
|
||||
@ -43,14 +48,15 @@ module Swarm.Game.Scenario (
|
||||
loadScenarios,
|
||||
) where
|
||||
|
||||
import Control.Arrow ((***))
|
||||
import Control.Algebra (Has)
|
||||
import Control.Arrow ((&&&))
|
||||
import Control.Carrier.Lift (Lift, sendIO)
|
||||
import Control.Carrier.Throw.Either (Throw, runThrow, throwError)
|
||||
import Control.Lens hiding (from, (<.>))
|
||||
import Control.Monad (filterM, unless, when)
|
||||
import Data.Aeson.Key qualified as Key
|
||||
import Data.Aeson.KeyMap (KeyMap)
|
||||
import Data.Aeson.KeyMap qualified as KeyMap
|
||||
import Data.Array
|
||||
import Data.Bifunctor (first)
|
||||
import Data.Char (isSpace)
|
||||
import Data.List ((\\))
|
||||
import Data.Map (Map)
|
||||
@ -58,27 +64,138 @@ import Data.Map qualified as M
|
||||
import Data.Maybe (listToMaybe)
|
||||
import Data.Text (Text)
|
||||
import Data.Text qualified as T
|
||||
import Data.Vector qualified as V
|
||||
import Data.Yaml as Y
|
||||
import GHC.Int (Int64)
|
||||
import Linear.V2
|
||||
import Paths_swarm (getDataDir, getDataFileName)
|
||||
import Swarm.Game.Entity
|
||||
import Swarm.Game.Recipe
|
||||
import Swarm.Game.Robot (TRobot, trobotName)
|
||||
import Swarm.Game.Terrain
|
||||
import Swarm.Language.Pipeline (ProcessedTerm)
|
||||
import Swarm.Util (reflow)
|
||||
import Swarm.Util.Yaml
|
||||
import System.Directory (doesDirectoryExist, doesFileExist, listDirectory)
|
||||
import System.FilePath (takeBaseName, takeExtensions, (<.>), (</>))
|
||||
import Witch (from, into)
|
||||
|
||||
import Control.Algebra (Has)
|
||||
import Control.Carrier.Lift (Lift, sendIO)
|
||||
import Control.Carrier.Throw.Either (Throw, runThrow, throwError)
|
||||
------------------------------------------------------------
|
||||
-- Robot map
|
||||
------------------------------------------------------------
|
||||
|
||||
import Paths_swarm (getDataDir, getDataFileName)
|
||||
import Swarm.Game.Entity
|
||||
import Swarm.Game.Recipe
|
||||
import Swarm.Game.Robot (URobot)
|
||||
import Swarm.Game.Terrain
|
||||
import Swarm.Game.World
|
||||
import Swarm.Game.WorldGen (Seed, findGoodOrigin, testWorld2FromArray)
|
||||
import Swarm.Language.Pipeline (ProcessedTerm)
|
||||
import Swarm.Util (reflow)
|
||||
import Swarm.Util.Yaml
|
||||
-- | A map from names to robots, used to look up robots in scenario
|
||||
-- descriptions.
|
||||
type RobotMap = Map Text TRobot
|
||||
|
||||
-- | Create a 'RobotMap' from a list of robot templates.
|
||||
buildRobotMap :: [TRobot] -> RobotMap
|
||||
buildRobotMap = M.fromList . map (view trobotName &&& id)
|
||||
|
||||
------------------------------------------------------------
|
||||
-- Lookup utilities
|
||||
------------------------------------------------------------
|
||||
|
||||
-- | Look up a thing by name, throwing a parse error if it is not
|
||||
-- found.
|
||||
getThing :: String -> (Text -> m -> Maybe a) -> Text -> ParserE m a
|
||||
getThing thing lkup name = do
|
||||
m <- getE
|
||||
case lkup name m of
|
||||
Nothing -> fail $ "Unknown " <> thing <> " name: " ++ show name
|
||||
Just a -> return a
|
||||
|
||||
-- | Look up an entity by name in an 'EntityMap', throwing a parse
|
||||
-- error if it is not found.
|
||||
getEntity :: Text -> ParserE EntityMap Entity
|
||||
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 TRobot
|
||||
getRobot = getThing "robot" M.lookup
|
||||
|
||||
------------------------------------------------------------
|
||||
-- World cells
|
||||
------------------------------------------------------------
|
||||
|
||||
-- | A single cell in a world map, which contains a terrain value,
|
||||
-- and optionally an entity and robot.
|
||||
data Cell = Cell
|
||||
{ cellTerrain :: TerrainType
|
||||
, cellEntity :: Maybe Entity
|
||||
, cellRobot :: Maybe TRobot
|
||||
}
|
||||
|
||||
-- | Parse a tuple such as @[grass, rock, base]@ into a 'Cell'. The
|
||||
-- entity and robot, if present, are immediately looked up and
|
||||
-- converted into 'Entity' and 'TRobot' values. If they are not
|
||||
-- found, a parse error results.
|
||||
instance FromJSONE (EntityMap, RobotMap) Cell where
|
||||
parseJSONE = withArrayE "tuple" $ \v -> do
|
||||
let tup = V.toList v
|
||||
when (null tup || length tup > 3) $ fail "palette entry must have length 1, 2, or 3"
|
||||
|
||||
terr <- liftE $ parseJSON (head tup)
|
||||
|
||||
ent <- case tup ^? ix 1 of
|
||||
Nothing -> return Nothing
|
||||
Just e -> do
|
||||
meName <- liftE $ parseJSON @(Maybe Text) e
|
||||
traverse (localE fst . getEntity) meName
|
||||
|
||||
rob <- case tup ^? ix 2 of
|
||||
Nothing -> return Nothing
|
||||
Just r -> do
|
||||
mrName <- liftE $ parseJSON @(Maybe Text) r
|
||||
traverse (localE snd . getRobot) mrName
|
||||
|
||||
return $ Cell terr ent rob
|
||||
|
||||
------------------------------------------------------------
|
||||
-- World description
|
||||
------------------------------------------------------------
|
||||
|
||||
-- | A world palette maps characters to 'Cell' values.
|
||||
newtype WorldPalette = WorldPalette
|
||||
{unPalette :: KeyMap Cell}
|
||||
|
||||
instance FromJSONE (EntityMap, RobotMap) WorldPalette where
|
||||
parseJSONE = withObjectE "palette" $ fmap WorldPalette . mapM parseJSONE
|
||||
|
||||
-- | A description of a world parsed from a YAML file.
|
||||
data WorldDescription = WorldDescription
|
||||
{ defaultTerrain :: Maybe Cell
|
||||
, offsetOrigin :: Bool
|
||||
, palette :: WorldPalette
|
||||
, ul :: V2 Int64
|
||||
, area :: [[Cell]]
|
||||
}
|
||||
|
||||
instance FromJSONE (EntityMap, RobotMap) WorldDescription where
|
||||
parseJSONE = withObjectE "world description" $ \v -> do
|
||||
pal <- v ..:? "palette" ..!= WorldPalette mempty
|
||||
WorldDescription
|
||||
<$> v ..:? "default"
|
||||
<*> liftE (v .:? "offset" .!= False)
|
||||
<*> pure pal
|
||||
<*> liftE (v .:? "upperleft" .!= V2 0 0)
|
||||
<*> liftE ((v .:? "map" .!= "") >>= paintMap pal)
|
||||
|
||||
-- | "Paint" a world map using a 'WorldPalette', turning it from a raw
|
||||
-- string into a nested list of 'Cell' values by looking up each
|
||||
-- character in the palette, failing if any character in the raw map
|
||||
-- is not contained in the palette.
|
||||
paintMap :: MonadFail m => WorldPalette -> Text -> m [[Cell]]
|
||||
paintMap pal = traverse (traverse toCell . into @String) . T.lines
|
||||
where
|
||||
toCell c = case KeyMap.lookup (Key.fromString [c]) (unPalette pal) of
|
||||
Nothing -> fail $ "Char not in world palette: " ++ show c
|
||||
Just cell -> return cell
|
||||
|
||||
------------------------------------------------------------
|
||||
-- Scenario
|
||||
------------------------------------------------------------
|
||||
|
||||
-- | A 'Scenario' contains all the information to describe a
|
||||
-- scenario.
|
||||
@ -86,12 +203,12 @@ data Scenario = Scenario
|
||||
{ _scenarioName :: Text
|
||||
, _scenarioDescription :: Text
|
||||
, _scenarioGoal :: Maybe [Text]
|
||||
, _scenarioCreative :: Bool -- Maybe generalize this to a mode enumeration
|
||||
, _scenarioCreative :: Bool
|
||||
, _scenarioSeed :: Maybe Int
|
||||
, _scenarioEntities :: EntityMap
|
||||
, _scenarioRecipes :: [Recipe Entity]
|
||||
, _scenarioWorld :: Seed -> WorldFun Int Entity
|
||||
, _scenarioRobots :: [URobot]
|
||||
, _scenarioWorld :: WorldDescription
|
||||
, _scenarioRobots :: [TRobot]
|
||||
, _scenarioWin :: Maybe ProcessedTerm
|
||||
, _scenarioSolution :: Maybe ProcessedTerm
|
||||
, _scenarioStepsPerTick :: Maybe Int
|
||||
@ -102,6 +219,8 @@ makeLensesWith (lensRules & generateSignatures .~ False) ''Scenario
|
||||
instance FromJSONE EntityMap Scenario where
|
||||
parseJSONE = withObjectE "scenario" $ \v -> do
|
||||
em <- liftE (buildEntityMap <$> (v .:? "entities" .!= []))
|
||||
rs <- withE em (v ..: "robots")
|
||||
let rsMap = buildRobotMap rs
|
||||
Scenario
|
||||
<$> liftE (v .: "name")
|
||||
<*> liftE (v .:? "description" .!= "")
|
||||
@ -110,12 +229,15 @@ instance FromJSONE EntityMap Scenario where
|
||||
<*> liftE (v .:? "seed")
|
||||
<*> pure em
|
||||
<*> withE em (v ..:? "recipes" ..!= [])
|
||||
<*> withE em (mkWorldFun (v .: "world"))
|
||||
<*> withE em (v ..: "robots")
|
||||
<*> withE em (localE (,rsMap) (v ..: "world"))
|
||||
<*> pure rs
|
||||
<*> liftE (v .:? "win")
|
||||
<*> liftE (v .:? "solution")
|
||||
<*> liftE (v .:? "stepsPerTick")
|
||||
|
||||
--------------------------------------------------
|
||||
-- Lenses
|
||||
|
||||
-- | The name of the scenario.
|
||||
scenarioName :: Lens' Scenario Text
|
||||
|
||||
@ -141,11 +263,11 @@ scenarioEntities :: Lens' Scenario EntityMap
|
||||
scenarioRecipes :: Lens' Scenario [Recipe Entity]
|
||||
|
||||
-- | The starting world for the scenario.
|
||||
scenarioWorld :: Lens' Scenario (Seed -> WorldFun Int Entity)
|
||||
scenarioWorld :: Lens' Scenario WorldDescription
|
||||
|
||||
-- | The starting robots for the scenario. Note this should
|
||||
-- include the base.
|
||||
scenarioRobots :: Lens' Scenario [URobot]
|
||||
scenarioRobots :: Lens' Scenario [TRobot]
|
||||
|
||||
-- | An optional winning condition for the scenario, expressed as a
|
||||
-- program of type @cmd bool@. By default, this program will be
|
||||
@ -162,71 +284,6 @@ scenarioSolution :: Lens' Scenario (Maybe ProcessedTerm)
|
||||
-- take during a single tick.
|
||||
scenarioStepsPerTick :: Lens' Scenario (Maybe Int)
|
||||
|
||||
-- | A description of a world parsed from a YAML file. The
|
||||
-- 'mkWorldFun' function is used to turn a 'WorldDescription' into a
|
||||
-- 'WorldFun'.
|
||||
data WorldDescription = WorldDescription
|
||||
{ defaultTerrain :: Maybe (TerrainType, Maybe Text)
|
||||
, offsetOrigin :: Bool
|
||||
, palette :: WorldPalette
|
||||
, ul :: V2 Int64
|
||||
, area :: Text
|
||||
}
|
||||
|
||||
instance FromJSON WorldDescription where
|
||||
parseJSON = withObject "world description" $ \v ->
|
||||
WorldDescription
|
||||
<$> v .:? "default"
|
||||
<*> v .:? "offset" .!= False
|
||||
<*> v .:? "palette" .!= WorldPalette mempty
|
||||
<*> v .:? "upperleft" .!= V2 0 0
|
||||
<*> v .:? "map" .!= ""
|
||||
|
||||
newtype WorldPalette = WorldPalette
|
||||
{unPalette :: KeyMap (TerrainType, Maybe Text)}
|
||||
|
||||
instance FromJSON WorldPalette where
|
||||
parseJSON = withObject "palette" $ fmap WorldPalette . mapM parseJSON
|
||||
|
||||
mkWorldFun :: Parser WorldDescription -> ParserE EntityMap (Seed -> WorldFun Int Entity)
|
||||
mkWorldFun pwd = E $ \em -> do
|
||||
wd <- pwd
|
||||
let toEntity :: Char -> Parser (Int, Maybe Entity)
|
||||
toEntity c = case KeyMap.lookup (Key.fromString [c]) (unPalette (palette wd)) of
|
||||
Nothing -> fail $ "Char not in entity palette: " ++ show c
|
||||
Just (t, mt) -> case mt of
|
||||
Nothing -> return (fromEnum t, Nothing)
|
||||
Just name -> case lookupEntityName name em of
|
||||
Nothing -> fail $ "Unknown entity name: " ++ show name
|
||||
Just e -> return (fromEnum t, Just e)
|
||||
|
||||
grid = map (into @String) . T.lines $ area wd
|
||||
|
||||
rs = fromIntegral $ length grid
|
||||
cs = fromIntegral $ length (head grid)
|
||||
|
||||
Coords (ulr, ulc) = locToCoords (ul wd)
|
||||
|
||||
arr <-
|
||||
fmap (listArray ((ulr, ulc), (ulr + rs - 1, ulc + cs - 1)))
|
||||
. mapM toEntity
|
||||
. concat
|
||||
$ grid
|
||||
case defaultTerrain wd of
|
||||
Nothing -> do
|
||||
let arr2 = bimap toEnum (fmap (^. entityName)) <$> arr
|
||||
return $
|
||||
fmap ((lkup em <$>) . first fromEnum)
|
||||
. (if offsetOrigin wd then findGoodOrigin else id)
|
||||
. testWorld2FromArray arr2
|
||||
Just def -> do
|
||||
let defTerrain = (fromEnum *** (>>= (`lookupEntityName` em))) def
|
||||
return $ \_ -> worldFunFromArray arr defTerrain
|
||||
where
|
||||
lkup :: EntityMap -> Maybe Text -> Maybe Entity
|
||||
lkup _ Nothing = Nothing
|
||||
lkup em (Just t) = lookupEntityName t em
|
||||
|
||||
------------------------------------------------------------
|
||||
-- Loading scenarios
|
||||
------------------------------------------------------------
|
||||
|
@ -1,6 +1,7 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
@ -78,7 +79,7 @@ module Swarm.Game.State (
|
||||
focusedRobot,
|
||||
clearFocusedRobotLogUpdated,
|
||||
addRobot,
|
||||
addURobot,
|
||||
addTRobot,
|
||||
emitMessage,
|
||||
sleepUntil,
|
||||
sleepForever,
|
||||
@ -87,12 +88,16 @@ module Swarm.Game.State (
|
||||
activateRobot,
|
||||
) where
|
||||
|
||||
import Control.Algebra (Has)
|
||||
import Control.Applicative ((<|>))
|
||||
import Control.Arrow (Arrow ((&&&)))
|
||||
import Control.Effect.Lens
|
||||
import Control.Effect.State (State)
|
||||
import Control.Lens hiding (Const, use, uses, view, (%=), (+=), (.=), (<+=), (<<.=))
|
||||
import Control.Monad.Except
|
||||
import Data.Aeson (FromJSON, ToJSON)
|
||||
import Data.Array (Array, listArray)
|
||||
import Data.Bifunctor (first)
|
||||
import Data.Int (Int64)
|
||||
import Data.IntMap (IntMap)
|
||||
import Data.IntMap qualified as IM
|
||||
@ -102,37 +107,39 @@ import Data.IntSet.Lens (setOf)
|
||||
import Data.List (partition)
|
||||
import Data.Map (Map)
|
||||
import Data.Map qualified as M
|
||||
import Data.Maybe (fromMaybe, mapMaybe)
|
||||
import Data.Maybe (fromMaybe, isJust, mapMaybe)
|
||||
import Data.Set qualified as S
|
||||
import Data.Text (Text)
|
||||
import Data.Text qualified as T (lines)
|
||||
import Data.Text.IO qualified as T (readFile)
|
||||
import GHC.Generics (Generic)
|
||||
import Linear
|
||||
import System.Clock qualified
|
||||
import System.Random (StdGen, mkStdGen, randomRIO)
|
||||
import Witch (into)
|
||||
|
||||
import Control.Algebra (Has)
|
||||
import Control.Effect.Lens
|
||||
import Control.Effect.State (State)
|
||||
|
||||
import Linear (V2 (..))
|
||||
import Paths_swarm (getDataFileName)
|
||||
import Swarm.Game.CESK (emptyStore, initMachine)
|
||||
import Swarm.Game.Entity
|
||||
import Swarm.Game.Recipe
|
||||
import Swarm.Game.Recipe (
|
||||
Recipe,
|
||||
inRecipeMap,
|
||||
loadRecipes,
|
||||
outRecipeMap,
|
||||
)
|
||||
import Swarm.Game.Robot
|
||||
import Swarm.Game.Scenario
|
||||
import Swarm.Game.Value
|
||||
import Swarm.Game.Terrain (TerrainType (..))
|
||||
import Swarm.Game.Value (Value)
|
||||
import Swarm.Game.World (Coords (..), WorldFun (..), locToCoords, worldFunFromArray)
|
||||
import Swarm.Game.World qualified as W
|
||||
import Swarm.Game.WorldGen (Seed)
|
||||
import Swarm.Game.WorldGen (Seed, findGoodOrigin, testWorld2FromArray)
|
||||
import Swarm.Language.Capability (constCaps)
|
||||
import Swarm.Language.Context qualified as Ctx
|
||||
import Swarm.Language.Pipeline (ProcessedTerm)
|
||||
import Swarm.Language.Pipeline.QQ (tmQ)
|
||||
import Swarm.Language.Syntax (Const, Term (TString), allConst)
|
||||
import Swarm.Language.Types
|
||||
import Swarm.Util
|
||||
import Swarm.Util (isRightOr, (<+=), (<<.=), (?))
|
||||
import System.Clock qualified as Clock
|
||||
import System.Random (StdGen, mkStdGen, randomRIO)
|
||||
import Witch (into)
|
||||
|
||||
------------------------------------------------------------
|
||||
-- Subsidiary data types
|
||||
@ -361,7 +368,9 @@ recipesIn :: Lens' GameState (IntMap [Recipe Entity])
|
||||
scenarios :: Lens' GameState ScenarioCollection
|
||||
|
||||
-- | The current state of the world (terrain and entities only; robots
|
||||
-- are stored in the 'robotMap').
|
||||
-- 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)
|
||||
|
||||
------------------------------------------------------------
|
||||
@ -473,14 +482,14 @@ clearFocusedRobotLogUpdated = do
|
||||
n <- use focusedRobotID
|
||||
robotMap . ix n . robotLogUpdated .= False
|
||||
|
||||
-- | Add an unidentified to the game state: first, generate a unique
|
||||
-- ID number for it. Then, add it to the main robot map, the active
|
||||
-- robot set, and to to the index of robots by location. Return the
|
||||
-- updated robot.
|
||||
addURobot :: Has (State GameState) sig m => URobot -> m Robot
|
||||
addURobot r = do
|
||||
-- | Add a concrete instance of a robot template to the game state:
|
||||
-- first, generate a unique ID number for it. Then, add it to the
|
||||
-- main robot map, the active robot set, and to to the index of
|
||||
-- robots by location. Return the updated robot.
|
||||
addTRobot :: Has (State GameState) sig m => TRobot -> m Robot
|
||||
addTRobot r = do
|
||||
rid <- gensym <+= 1
|
||||
let r' = setRobotID rid r
|
||||
let r' = instantiateRobot rid r
|
||||
addRobot r'
|
||||
return r'
|
||||
|
||||
@ -592,7 +601,7 @@ initGameState = do
|
||||
, _recipesOut = outRecipeMap recipes
|
||||
, _recipesIn = inRecipeMap recipes
|
||||
, _scenarios = loadedScenarios
|
||||
, _world = W.emptyWorld 0
|
||||
, _world = W.emptyWorld (fromEnum StoneT)
|
||||
, _viewCenterRule = VCRobot 0
|
||||
, _viewCenter = V2 0 0
|
||||
, _needsRedraw = False
|
||||
@ -614,7 +623,7 @@ scenarioToGameState scenario userSeed toRun g = do
|
||||
Just s -> return s
|
||||
Nothing -> randomRIO (0, maxBound :: Int)
|
||||
|
||||
now <- System.Clock.getTime System.Clock.Monotonic
|
||||
now <- Clock.getTime Clock.Monotonic
|
||||
let robotList' = (robotCreatedAt .~ now) <$> robotList
|
||||
|
||||
return $
|
||||
@ -632,7 +641,7 @@ scenarioToGameState scenario userSeed toRun g = do
|
||||
, _waitingRobots = M.empty
|
||||
, _gensym = initGensym
|
||||
, _randGen = mkStdGen seed
|
||||
, _entityMap = g ^. entityMap <> scenario ^. scenarioEntities
|
||||
, _entityMap = em
|
||||
, _recipesOut = addRecipesWith outRecipeMap recipesOut
|
||||
, _recipesIn = addRecipesWith inRecipeMap recipesIn
|
||||
, _world = theWorld seed
|
||||
@ -650,24 +659,28 @@ scenarioToGameState scenario userSeed toRun g = do
|
||||
, _robotStepsPerTick = (scenario ^. scenarioStepsPerTick) ? defaultRobotStepsPerTick
|
||||
}
|
||||
where
|
||||
em = g ^. entityMap
|
||||
em = g ^. entityMap <> scenario ^. scenarioEntities
|
||||
|
||||
baseID = 0
|
||||
(things, devices) = partition (null . view entityCapabilities) (M.elems (entitiesByName em))
|
||||
-- Keep only robots from the robot list with a concrete location;
|
||||
-- the others existed only to serve as a template for robots drawn
|
||||
-- in the world map
|
||||
locatedRobots = filter (isJust . view trobotLocation) $ scenario ^. scenarioRobots
|
||||
robotList =
|
||||
zipWith setRobotID [0 ..] (scenario ^. scenarioRobots)
|
||||
zipWith instantiateRobot [baseID ..] (locatedRobots ++ genRobots)
|
||||
-- If the --run flag was used, use it to replace the CESK machine of the
|
||||
-- robot whose id is 0, i.e. the first robot listed in the scenario.
|
||||
& ix 0 . machine
|
||||
& ix baseID . machine
|
||||
%~ case toRun of
|
||||
Nothing -> id
|
||||
Just (into @Text -> f) -> const (initMachine [tmQ| run($str:f) |] Ctx.empty emptyStore)
|
||||
-- If we are in creative mode, give robot 0 all the things
|
||||
& ix 0 . robotInventory
|
||||
-- If we are in creative mode, give base all the things
|
||||
& ix baseID . robotInventory
|
||||
%~ case scenario ^. scenarioCreative of
|
||||
False -> id
|
||||
True -> union (fromElems (map (0,) things))
|
||||
& ix 0 . installedDevices
|
||||
& ix baseID . installedDevices
|
||||
%~ case scenario ^. scenarioCreative of
|
||||
False -> id
|
||||
True -> const (fromList devices)
|
||||
@ -678,11 +691,45 @@ scenarioToGameState scenario userSeed toRun g = do
|
||||
(maybe False (`S.member` initialCaps) . constCaps)
|
||||
allConst
|
||||
|
||||
theWorld = W.newWorld . (scenario ^. scenarioWorld)
|
||||
(genRobots, wf) = buildWorld em (scenario ^. scenarioWorld)
|
||||
theWorld = W.newWorld . wf
|
||||
theWinCondition = maybe NoWinCondition WinCondition (scenario ^. scenarioWin)
|
||||
initGensym = length robotList - 1
|
||||
addRecipesWith f gRs = IM.unionWith (<>) (f $ scenario ^. scenarioRecipes) (g ^. gRs)
|
||||
|
||||
-- | 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 -> ([TRobot], Seed -> WorldFun Int Entity)
|
||||
buildWorld em (WorldDescription {..}) = (robots, first fromEnum . wf)
|
||||
where
|
||||
rs = fromIntegral $ length area
|
||||
cs = fromIntegral $ length (head area)
|
||||
Coords (ulr, ulc) = locToCoords ul
|
||||
|
||||
worldGrid :: [[(TerrainType, Maybe Entity)]]
|
||||
worldGrid = (map . map) (cellTerrain &&& cellEntity) area
|
||||
|
||||
worldArray :: Array (Int64, Int64) (TerrainType, Maybe Entity)
|
||||
worldArray = listArray ((ulr, ulc), (ulr + rs - 1, ulc + cs - 1)) (concat worldGrid)
|
||||
|
||||
wf = case defaultTerrain of
|
||||
Nothing ->
|
||||
(if offsetOrigin then findGoodOrigin else id) . testWorld2FromArray em worldArray
|
||||
Just (Cell t e _) -> const (worldFunFromArray worldArray (t, e))
|
||||
|
||||
-- Get all the robots described in cells and set their locations appropriately
|
||||
robots :: [TRobot]
|
||||
robots =
|
||||
area
|
||||
& traversed <.> traversed %@~ (,) -- add (r,c) indices
|
||||
& concat
|
||||
& mapMaybe
|
||||
( \((fromIntegral -> r, fromIntegral -> c), Cell _ _ robot) ->
|
||||
robot
|
||||
& traverse . trobotLocation
|
||||
?~ W.coordsToLoc (Coords (ulr + r, ulc + c))
|
||||
)
|
||||
|
||||
-- | Create an initial game state for a specific scenario.
|
||||
initGameStateForScenario :: String -> Maybe Seed -> Maybe String -> ExceptT Text IO GameState
|
||||
initGameStateForScenario sceneName userSeed toRun = do
|
||||
|
@ -1,4 +1,5 @@
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
@ -23,7 +24,6 @@ import Data.Containers.ListUtils (nubOrd)
|
||||
import Data.Either (partitionEithers, rights)
|
||||
import Data.Foldable (traverse_)
|
||||
import Data.Functor (void)
|
||||
import Data.Functor.Const qualified as F
|
||||
import Data.Int (Int64)
|
||||
import Data.IntMap qualified as IM
|
||||
import Data.IntSet qualified as IS
|
||||
@ -152,7 +152,7 @@ evaluateCESK ::
|
||||
evaluateCESK cesk = do
|
||||
createdAt <- getNow
|
||||
-- Use ID (-1) so it won't conflict with any robots currently in the robot map.
|
||||
let r = mkRobot (Identity (-1)) Nothing "" [] zero zero defaultRobotDisplay cesk [] [] True createdAt
|
||||
let r = mkRobot (-1) Nothing "" [] zero zero defaultRobotDisplay cesk [] [] True createdAt
|
||||
addRobot r -- Add the robot to the robot map, so it can look itself up if needed
|
||||
evalState r . runCESK $ cesk
|
||||
|
||||
@ -647,13 +647,13 @@ seedProgram minTime randTime thing =
|
||||
addSeedBot :: Has (State GameState) sig m => Entity -> (Integer, Integer) -> V2 Int64 -> TimeSpec -> m ()
|
||||
addSeedBot e (minT, maxT) loc ts =
|
||||
void $
|
||||
addURobot $
|
||||
addTRobot $
|
||||
mkRobot
|
||||
(F.Const ())
|
||||
()
|
||||
Nothing
|
||||
"seed"
|
||||
["A growing seed."]
|
||||
loc
|
||||
(Just loc)
|
||||
(V2 0 0)
|
||||
( defaultEntityDisplay '.'
|
||||
& displayAttr .~ (e ^. entityDisplay . displayAttr)
|
||||
@ -1279,13 +1279,13 @@ execConst c vs s k = do
|
||||
|
||||
-- Construct the new robot and add it to the world.
|
||||
newRobot <-
|
||||
addURobot $
|
||||
addTRobot $
|
||||
mkRobot
|
||||
(F.Const ())
|
||||
()
|
||||
(Just pid)
|
||||
displayName
|
||||
["A robot built by the robot named " <> r ^. robotName <> "."]
|
||||
(r ^. robotLocation)
|
||||
(Just (r ^. robotLocation))
|
||||
( ((r ^. robotOrientation) >>= \dir -> guard (dir /= zero) >> return dir)
|
||||
? east
|
||||
)
|
||||
|
@ -23,7 +23,7 @@ module Swarm.Game.World (
|
||||
coordsToLoc,
|
||||
|
||||
-- * Worlds
|
||||
WorldFun,
|
||||
WorldFun (..),
|
||||
worldFunFromArray,
|
||||
World,
|
||||
|
||||
@ -89,14 +89,18 @@ coordsToLoc (Coords (r, c)) = V2 c (- r)
|
||||
-- | A @WorldFun t e@ represents a 2D world with terrain of type @t@
|
||||
-- (exactly one per cell) and entities of type @e@ (at most one per
|
||||
-- cell).
|
||||
type WorldFun t e = Coords -> (t, Maybe e)
|
||||
newtype WorldFun t e = WF {runWF :: Coords -> (t, Maybe e)}
|
||||
|
||||
instance Bifunctor WorldFun where
|
||||
bimap g h (WF z) = WF (bimap g (fmap h) . z)
|
||||
|
||||
-- | Create a world function from a finite array of specified cells
|
||||
-- plus a single default cell to use everywhere else.
|
||||
worldFunFromArray :: Array (Int64, Int64) (t, Maybe e) -> (t, Maybe e) -> WorldFun t e
|
||||
worldFunFromArray arr def (Coords (r, c))
|
||||
| inRange bnds (r, c) = arr ! (r, c)
|
||||
| otherwise = def
|
||||
worldFunFromArray arr def = WF $ \(Coords (r, c)) ->
|
||||
if inRange bnds (r, c)
|
||||
then arr ! (r, c)
|
||||
else def
|
||||
where
|
||||
bnds = bounds arr
|
||||
|
||||
@ -197,7 +201,7 @@ newWorld f = World f M.empty M.empty
|
||||
-- | Create a new empty 'World' consisting of nothing but the given
|
||||
-- terrain.
|
||||
emptyWorld :: t -> World t e
|
||||
emptyWorld t = newWorld (const (t, Nothing))
|
||||
emptyWorld t = newWorld (WF $ const (t, Nothing))
|
||||
|
||||
-- | Look up the terrain value at certain coordinates: try looking it
|
||||
-- up in the tile cache first, and fall back to running the 'WorldFun'
|
||||
@ -208,7 +212,7 @@ emptyWorld t = newWorld (const (t, Nothing))
|
||||
lookupTerrain :: IArray U.UArray t => Coords -> World t e -> t
|
||||
lookupTerrain i (World f t _) =
|
||||
((U.! tileOffset i) . fst <$> M.lookup (tileCoords i) t)
|
||||
? fst (f i)
|
||||
? fst (runWF f i)
|
||||
|
||||
-- | A stateful variant of 'lookupTerrain', which first loads the tile
|
||||
-- containing the given coordinates if it is not already loaded,
|
||||
@ -229,7 +233,7 @@ lookupEntity :: Coords -> World t e -> Maybe e
|
||||
lookupEntity i (World f t m) =
|
||||
M.lookup i m
|
||||
? ((A.! tileOffset i) . snd <$> M.lookup (tileCoords i) t)
|
||||
? snd (f i)
|
||||
? snd (runWF f i)
|
||||
|
||||
-- | A stateful variant of 'lookupTerrain', which first loads the tile
|
||||
-- containing the given coordinates if it is not already loaded,
|
||||
@ -270,4 +274,4 @@ loadRegion reg (World f t m) = World f t' m
|
||||
loadTile tc = (listArray tileBounds terrain, listArray tileBounds entities)
|
||||
where
|
||||
tileCorner = tileOrigin tc
|
||||
(terrain, entities) = unzip $ map (f . plusOffset tileCorner) (range tileBounds)
|
||||
(terrain, entities) = unzip $ map (runWF f . plusOffset tileCorner) (range tileBounds)
|
||||
|
@ -22,12 +22,15 @@ import Data.Text qualified as T
|
||||
import Numeric.Noise.Perlin
|
||||
import Witch
|
||||
|
||||
import Control.Lens (view)
|
||||
import Data.Array.IArray
|
||||
import Data.Bifunctor (second)
|
||||
import Swarm.Game.Entity
|
||||
import Swarm.Game.Terrain
|
||||
import Swarm.Game.World
|
||||
|
||||
-- | A simple test world I used for a while during early development.
|
||||
testWorld1 :: WorldFun TerrainType Text
|
||||
-- | A simple test world used for a while during early development.
|
||||
testWorld1 :: Coords -> (TerrainType, Maybe Text)
|
||||
testWorld1 (Coords (-5, 3)) = (StoneT, Just "flerb")
|
||||
testWorld1 (Coords (2, -1)) = (GrassT, Just "elephant")
|
||||
testWorld1 (Coords (i, j))
|
||||
@ -44,6 +47,7 @@ data Hardness = Soft | Hard deriving (Eq, Ord, Show, Read)
|
||||
data Origin = Natural | Artificial deriving (Eq, Ord, Show, Read)
|
||||
type Seed = Int
|
||||
|
||||
-- | A list of entities available in the initial world.
|
||||
testWorld2Entites :: S.Set Text
|
||||
testWorld2Entites =
|
||||
S.fromList
|
||||
@ -66,81 +70,96 @@ testWorld2Entites =
|
||||
, "copper ore"
|
||||
]
|
||||
|
||||
-- | A more featureful test world.
|
||||
testWorld2 :: Seed -> WorldFun TerrainType Text
|
||||
testWorld2 baseSeed (Coords ix@(r, c)) =
|
||||
genBiome
|
||||
(bool Small Big (sample ix pn0 > 0))
|
||||
(bool Soft Hard (sample ix pn1 > 0))
|
||||
(bool Natural Artificial (sample ix pn2 > 0))
|
||||
-- | Look up an entity name in an entity map, when we know the entity
|
||||
-- must exist. This is only used for entities which are named in
|
||||
-- 'testWorld2'.
|
||||
readEntity :: EntityMap -> Text -> Entity
|
||||
readEntity em name =
|
||||
fromMaybe
|
||||
(error $ "Unknown entity name in WorldGen: " <> show name)
|
||||
(lookupEntityName name em)
|
||||
|
||||
-- | The main world of the classic game, for historical reasons named
|
||||
-- 'testWorld2'. If new entities are added, you SHOULD ALSO UPDATE
|
||||
-- 'testWorld2Entities'.
|
||||
testWorld2 :: EntityMap -> Seed -> WorldFun TerrainType Entity
|
||||
testWorld2 em baseSeed = second (readEntity em) (WF tw2)
|
||||
where
|
||||
h = murmur3 0 (into (show ix))
|
||||
tw2 :: Coords -> (TerrainType, Maybe Text)
|
||||
tw2 (Coords ix@(r, c)) =
|
||||
genBiome
|
||||
(bool Small Big (sample ix pn0 > 0))
|
||||
(bool Soft Hard (sample ix pn1 > 0))
|
||||
(bool Natural Artificial (sample ix pn2 > 0))
|
||||
where
|
||||
h = murmur3 0 . into . show $ ix
|
||||
|
||||
genBiome Big Hard Natural
|
||||
| sample ix cl0 > 0.5 = (StoneT, Just "mountain")
|
||||
| h `mod` 30 == 0 = (StoneT, Just "boulder")
|
||||
| sample ix cl0 > 0 =
|
||||
case h `mod` 30 of
|
||||
1 -> (DirtT, Just "LaTeX")
|
||||
_ -> (DirtT, Just "tree")
|
||||
| otherwise = (GrassT, Nothing)
|
||||
genBiome Small Hard Natural
|
||||
| h `mod` 10 == 0 = (StoneT, Just "rock")
|
||||
| otherwise = (StoneT, Nothing)
|
||||
genBiome Big Soft Natural
|
||||
| abs (sample ix pn1) < 0.1 = (DirtT, Just "sand")
|
||||
| even (r + c) = (DirtT, Just "wavy water")
|
||||
| otherwise = (DirtT, Just "water")
|
||||
genBiome Small Soft Natural
|
||||
| h `mod` 10 == 0 = (GrassT, Just "flower")
|
||||
| otherwise = (GrassT, Nothing)
|
||||
genBiome Small Soft Artificial
|
||||
| h `mod` 10 == 0 = (GrassT, Just (T.concat ["bit (", from (show ((r + c) `mod` 2)), ")"]))
|
||||
| otherwise = (GrassT, Nothing)
|
||||
genBiome Big Soft Artificial
|
||||
| h `mod` 5000 == 0 = (DirtT, Just "Linux")
|
||||
| sample ix cl0 > 0.5 = (GrassT, Nothing)
|
||||
| otherwise = (DirtT, Nothing)
|
||||
genBiome Small Hard Artificial
|
||||
| h `mod` 120 == 1 = (StoneT, Just "lambda")
|
||||
| h `mod` 50 == 0 = (StoneT, Just (T.concat ["pixel (", from ["RGB" !! fromIntegral ((r + c) `mod` 3)], ")"]))
|
||||
| otherwise = (StoneT, Nothing)
|
||||
genBiome Big Hard Artificial
|
||||
| sample ix cl0 > 0.85 = (StoneT, Just "copper ore")
|
||||
| otherwise = (StoneT, Nothing)
|
||||
genBiome Big Hard Natural
|
||||
| sample ix cl0 > 0.5 = (StoneT, Just "mountain")
|
||||
| h `mod` 30 == 0 = (StoneT, Just "boulder")
|
||||
| sample ix cl0 > 0 =
|
||||
case h `mod` 30 of
|
||||
1 -> (DirtT, Just "LaTeX")
|
||||
_ -> (DirtT, Just "tree")
|
||||
| otherwise = (GrassT, Nothing)
|
||||
genBiome Small Hard Natural
|
||||
| h `mod` 10 == 0 = (StoneT, Just "rock")
|
||||
| otherwise = (StoneT, Nothing)
|
||||
genBiome Big Soft Natural
|
||||
| abs (sample ix pn1) < 0.1 = (DirtT, Just "sand")
|
||||
| even (r + c) = (DirtT, Just "wavy water")
|
||||
| otherwise = (DirtT, Just "water")
|
||||
genBiome Small Soft Natural
|
||||
| h `mod` 10 == 0 = (GrassT, Just "flower")
|
||||
| otherwise = (GrassT, Nothing)
|
||||
genBiome Small Soft Artificial
|
||||
| h `mod` 10 == 0 = (GrassT, Just (T.concat ["bit (", from (show ((r + c) `mod` 2)), ")"]))
|
||||
| otherwise = (GrassT, Nothing)
|
||||
genBiome Big Soft Artificial
|
||||
| h `mod` 5000 == 0 = (DirtT, Just "Linux")
|
||||
| sample ix cl0 > 0.5 = (GrassT, Nothing)
|
||||
| otherwise = (DirtT, Nothing)
|
||||
genBiome Small Hard Artificial
|
||||
| h `mod` 120 == 1 = (StoneT, Just "lambda")
|
||||
| h `mod` 50 == 0 = (StoneT, Just (T.concat ["pixel (", from ["RGB" !! fromIntegral ((r + c) `mod` 3)], ")"]))
|
||||
| otherwise = (StoneT, Nothing)
|
||||
genBiome Big Hard Artificial
|
||||
| sample ix cl0 > 0.85 = (StoneT, Just "copper ore")
|
||||
| otherwise = (StoneT, Nothing)
|
||||
|
||||
sample (i, j) noise = noiseValue noise (fromIntegral i / 2, fromIntegral j / 2, 0)
|
||||
sample (i, j) noise = noiseValue noise (fromIntegral i / 2, fromIntegral j / 2, 0)
|
||||
|
||||
pn :: Int -> Perlin
|
||||
pn seed = perlin (seed + baseSeed) 6 0.05 0.6
|
||||
pn :: Int -> Perlin
|
||||
pn seed = perlin (seed + baseSeed) 6 0.05 0.6
|
||||
|
||||
pn0 = pn 0
|
||||
pn1 = pn 1
|
||||
pn2 = pn 2
|
||||
pn0 = pn 0
|
||||
pn1 = pn 1
|
||||
pn2 = pn 2
|
||||
|
||||
-- alternative noise function
|
||||
-- rg :: Int -> Ridged
|
||||
-- rg seed = ridged seed 6 0.05 1 2
|
||||
-- alternative noise function
|
||||
-- rg :: Int -> Ridged
|
||||
-- rg seed = ridged seed 6 0.05 1 2
|
||||
|
||||
clumps :: Int -> Perlin
|
||||
clumps seed = perlin (seed + baseSeed) 4 0.08 0.5
|
||||
clumps :: Int -> Perlin
|
||||
clumps seed = perlin (seed + baseSeed) 4 0.08 0.5
|
||||
|
||||
cl0 = clumps 0
|
||||
cl0 = clumps 0
|
||||
|
||||
-- | Create a world function from a finite array of specified cells
|
||||
-- plus a seed to randomly generate the rest.
|
||||
testWorld2FromArray :: Array (Int64, Int64) (TerrainType, Maybe Text) -> Seed -> WorldFun TerrainType Text
|
||||
testWorld2FromArray arr seed co@(Coords (r, c))
|
||||
| inRange bnds (r, c) = arr ! (r, c)
|
||||
| otherwise = tw2 co
|
||||
testWorld2FromArray :: EntityMap -> Array (Int64, Int64) (TerrainType, Maybe Entity) -> Seed -> WorldFun TerrainType Entity
|
||||
testWorld2FromArray em arr seed = WF $ \co@(Coords (r, c)) ->
|
||||
if inRange bnds (r, c)
|
||||
then arr ! (r, c)
|
||||
else runWF tw2 co
|
||||
where
|
||||
tw2 = testWorld2 seed
|
||||
tw2 = testWorld2 em seed
|
||||
bnds = bounds arr
|
||||
|
||||
-- | Offset a world by a multiple of the @skip@ in such a way that it
|
||||
-- satisfies the given predicate.
|
||||
findOffset :: Integer -> (WorldFun t Text -> Bool) -> WorldFun t Text -> WorldFun t Text
|
||||
findOffset skip isGood f = f'
|
||||
findOffset :: Integer -> ((Coords -> (t, Maybe e)) -> Bool) -> WorldFun t e -> WorldFun t e
|
||||
findOffset skip isGood (WF f) = WF f'
|
||||
where
|
||||
offset :: Enumeration Int64
|
||||
offset = fromIntegral . (skip *) <$> int
|
||||
@ -156,16 +175,16 @@ findOffset skip isGood f = f'
|
||||
|
||||
-- | Offset the world so the base starts in a 32x32 patch containing at least one
|
||||
-- of each of a list of required entities.
|
||||
findPatchWith :: [Text] -> WorldFun t Text -> WorldFun t Text
|
||||
findPatchWith :: [Text] -> WorldFun t Entity -> WorldFun t Entity
|
||||
findPatchWith reqs = findOffset 32 isGoodPatch
|
||||
where
|
||||
patchCoords = [(r, c) | r <- [-16 .. 16], c <- [-16 .. 16]]
|
||||
isGoodPatch f = all (`S.member` es) reqs
|
||||
where
|
||||
es = S.fromList . mapMaybe (snd . f . Coords) $ patchCoords
|
||||
es = S.fromList . map (view entityName) . mapMaybe (snd . f . Coords) $ patchCoords
|
||||
|
||||
-- | Offset the world so the base starts on empty spot next to tree and grass.
|
||||
findTreeOffset :: WorldFun t Text -> WorldFun t Text
|
||||
findTreeOffset :: WorldFun t Entity -> WorldFun t Entity
|
||||
findTreeOffset = findOffset 1 isGoodPlace
|
||||
where
|
||||
isGoodPlace f =
|
||||
@ -173,11 +192,11 @@ findTreeOffset = findOffset 1 isGoodPlace
|
||||
&& any (hasEntity (Just "tree")) neighbors
|
||||
&& all (\c -> hasEntity (Just "tree") c || hasEntity Nothing c) neighbors
|
||||
where
|
||||
hasEntity mayE = (== mayE) . snd . f . Coords
|
||||
hasEntity mayE = (== mayE) . fmap (view entityName) . snd . f . Coords
|
||||
|
||||
neighbors = [(r, c) | r <- [-1 .. 1], c <- [-1 .. 1]]
|
||||
|
||||
-- | Offset the world so the base starts in a good patch (near
|
||||
-- necessary items), next to a tree.
|
||||
findGoodOrigin :: WorldFun t Text -> WorldFun t Text
|
||||
findGoodOrigin :: WorldFun t Entity -> WorldFun t Entity
|
||||
findGoodOrigin = findTreeOffset . findPatchWith ["tree", "copper ore", "bit (0)", "bit (1)", "rock", "lambda", "water", "sand"]
|
||||
|
@ -14,6 +14,7 @@ module Swarm.Util.Yaml (
|
||||
With (..),
|
||||
ParserE,
|
||||
liftE,
|
||||
localE,
|
||||
withE,
|
||||
getE,
|
||||
FromJSONE (..),
|
||||
@ -55,9 +56,13 @@ type ParserE e = With e Parser
|
||||
liftE :: Functor f => f a -> With e f a
|
||||
liftE = E . const
|
||||
|
||||
-- | Locally modify an environment.
|
||||
localE :: (e' -> e) -> With e f a -> With e' f a
|
||||
localE g (E f) = E (f . g)
|
||||
|
||||
-- | Locally merge an environment with the current one for given action.
|
||||
withE :: Semigroup e => e -> With e f a -> With e f a
|
||||
withE e (E f) = E (f . (<> e))
|
||||
withE e = localE (<> e)
|
||||
|
||||
-- | Get the current environment.
|
||||
getE :: (Monad f) => With e f e
|
||||
|
Loading…
Reference in New Issue
Block a user