swarm-game/swarm
1
1
Fork 0
mirror of https://github.com/swarm-game/swarm.git synced 2024-09-11 14:46:33 +03:00
Code Issues Projects Releases Wiki Activity

Ability to "paint" robot locations in world descriptions (#571)

Browse Source 
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:
Brent Yorgey 2022-07-20 16:08:52 -04:00 committed by GitHub
parent 4a21185e8f
commit 49d714252e
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
44 changed files with 597 additions and 343 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
bench/Benchmark.hs
View File

@ -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.

1
data/scenarios/00-ORDER.txt
View File

@ -2,4 +2,5 @@ classic.yaml
creative.yaml
Tutorials
Challenges
Fun
Testing

4
data/scenarios/Challenges/chess_horse.yaml
View File

@ -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]

2
data/scenarios/Challenges/drill_test.yaml
View File

@ -29,7 +29,7 @@ robots:
world:
default: [ice, knownwater]
palette:
'.': [grass, null]
'.': [grass]
' ': [ice, knownwater]
'~': [ice, knownwavywater]
'L': [grass, Linux]

4
data/scenarios/Challenges/teleport.yaml
View File

@ -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]

4
data/scenarios/Challenges/test.yaml
View File

@ -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
View File

@ -0,0 +1 @@
GoL.yaml

80
data/scenarios/Fun/GoL.yaml Normal file
View 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.....
..............................
..............................
..............................

2
data/scenarios/Testing/201-require/201-require-device-creative.yaml
View File

@ -24,7 +24,7 @@ robots:
world:
default: [blank, null]
palette:
'.': [grass, null]
'.': [grass]
'~': [dirt, knownwater]
'┌': [stone, upper left corner]
'┐': [stone, upper right corner]

2
data/scenarios/Testing/201-require/201-require-device-creative1.yaml
View File

@ -26,7 +26,7 @@ robots:
world:
default: [blank, null]
palette:
'.': [grass, null]
'.': [grass]
'~': [dirt, knownwater]
'┌': [stone, upper left corner]
'┐': [stone, upper right corner]

2
data/scenarios/Testing/201-require/201-require-device.yaml
View File

@ -27,7 +27,7 @@ robots:
world:
default: [blank, null]
palette:
'.': [grass, null]
'.': [grass]
'~': [dirt, knownwater]
'┌': [stone, upper left corner]
'┐': [stone, upper right corner]

2
data/scenarios/Testing/201-require/201-require-entities-def.yaml
View File

@ -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]

2
data/scenarios/Testing/201-require/201-require-entities.yaml
View File

@ -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]

2
data/scenarios/Testing/201-require/533-reprogram-simple.yaml
View File

@ -45,7 +45,7 @@ robots:
world:
default: [blank, null]
palette:
'.': [grass, null]
'.': [grass]
'~': [dirt, knownwater]
'┌': [stone, upper left corner]
'┐': [stone, upper right corner]

2
data/scenarios/Testing/201-require/533-reprogram.yaml
View File

@ -45,7 +45,7 @@ robots:
world:
default: [blank, null]
palette:
'.': [grass, null]
'.': [grass]
'~': [dirt, knownwater]
'┌': [stone, upper left corner]
'┐': [stone, upper right corner]

4
data/scenarios/Testing/394-build-drill.yaml
View File

@ -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]

4
data/scenarios/Testing/428-drowning-destroy.yaml
View File

@ -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]

4
data/scenarios/Testing/475-wait-one.yaml
View File

@ -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]

4
data/scenarios/Testing/479-atomic-race.yaml
View File

@ -75,9 +75,9 @@ entities:
- You win!
properties: [known, portable]
world:
default: [blank, none]
default: [blank]
palette:
'.': [grass, null]
'.': [grass]
upperleft: [0,0]
map: |
.

4
data/scenarios/Testing/479-atomic.yaml
View File

@ -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: |
.

4
data/scenarios/Testing/490-harvest.yaml
View File

@ -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]

4
data/scenarios/Testing/504-teleport-self.yaml
View File

@ -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]

2
data/scenarios/Testing/508-capability-subset.yaml
View File

@ -29,7 +29,7 @@ robots:
world:
default: [ice, knownwater]
palette:
'.': [grass, null]
'.': [grass]
' ': [ice, knownwater]
'┌': [stone, upper left corner]
'┐': [stone, upper right corner]

7
data/scenarios/Tutorials/bind.yaml
View File

@ -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│
└───┘

8
data/scenarios/Tutorials/build.yaml
View File

@ -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: |
┌───┐
│..*│
│Ω.*│
│...│
│~~~│
└───┘

10
data/scenarios/Tutorials/craft.yaml
View File

@ -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: |
┌─┐
│ │
│Ω│
└─┘

13
data/scenarios/Tutorials/crash.yaml
View File

@ -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│
└─────┘

8
data/scenarios/Tutorials/grab.yaml
View File

@ -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│
└────────┘

8
data/scenarios/Tutorials/install.yaml
View File

@ -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..│
│~~~│
└───┘

8
data/scenarios/Tutorials/move.yaml
View File

@ -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: |
┌───┐
│...│
│>..│
└───┘

8
data/scenarios/Tutorials/place.yaml
View File

@ -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.....│
└────────┘

8
data/scenarios/Tutorials/require.yaml
View File

@ -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:
┌──────┐
│..~~..│
│..~~..│
│..~~.*│
│Ω.~~.*│
│..~~..│
│..~~..│
└──────┘

12
data/scenarios/Tutorials/requireinv.yaml
View File

@ -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: |
┌─────┐
│.....│
│Ω....│
│.____│
│.____│
│.____│

8
data/scenarios/Tutorials/scan.yaml
View File

@ -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│
└─────┘

8
data/scenarios/Tutorials/turn.yaml
View File

@ -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:
│.───┤
│....│
├───.│
│....│
│>...│
└────┘

8
data/scenarios/Tutorials/types.yaml
View File

@ -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: |
┌───┐
│...│
│>..│
│...│
└───┘

6
src/Swarm/DocGen.hs
View File

@ -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

117
src/Swarm/Game/Robot.hs
View File

@ -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"))

237
src/Swarm/Game/Scenario.hs
View File

@ -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
------------------------------------------------------------

113
src/Swarm/Game/State.hs
View File

@ -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

16
src/Swarm/Game/Step.hs
View File

@ -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
)

22
src/Swarm/Game/World.hs
View File

@ -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)

151
src/Swarm/Game/WorldGen.hs
View File

@ -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"]

7
src/Swarm/Util/Yaml.hs
View File

@ -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