swarm-game/swarm
1
1
Fork 0
mirror of https://github.com/swarm-game/swarm.git synced 2024-08-17 02:20:31 +03:00
Code Issues Projects Releases Wiki Activity

Challenge mode (#285)

Browse Source 
Add a "challenge mode" where the player tries to achieve some specified goal from specific starting conditions.
This commit is contained in:
Brent Yorgey 2022-01-27 17:00:00 -06:00 committed by GitHub
parent b267441403
commit b1f0e316fd
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
27 changed files with 952 additions and 117 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
.mergify.yml
View File

@ -1,7 +1,13 @@
queue_rules:
- name: default
conditions:
- check-success=Haskell-CI - Linux - ghc-9.0.1
- check-success=Haskell-CI - Linux - ghc-8.10.4
pull_request_rules:
- actions:
merge:
strict: smart
queue:
name: default
method: squash
commit_message: title+body
name: Automatically merge pull requests

10
app/Main.hs
View File

@ -14,7 +14,7 @@ import Swarm.Language.Pipeline (processTerm)
import System.Exit
data CLI
= Run Int
= Run Int (Maybe FilePath)
| Format Input
| LSP
@ -24,14 +24,16 @@ cliParser =
( command "format" (info (format <**> helper) (progDesc "Format a file"))
<> command "lsp" (info (pure LSP) (progDesc "Start the LSP"))
)
<|> Run <$> seed
<|> Run <$> seed <*> challenge
where
format :: Parser CLI
format =
(Format Stdin <$ switch (long "stdin" <> help "Read code from stdin"))
<|> (Format . File <$> strArgument (metavar "FILE"))
seed :: Parser Int
seed = option auto (long "seed" <> short 's' <> value 0 <> help "Seed for world generation")
seed = option auto (long "seed" <> short 's' <> value 0 <> metavar "INT" <> help "Seed for world generation")
challenge :: Parser (Maybe String)
challenge = optional $ strOption (long "challenge" <> short 'c' <> metavar "FILE" <> help "Name of a challenge to load")
cliInfo :: ParserInfo CLI
cliInfo =
@ -68,6 +70,6 @@ main :: IO ()
main = do
cli <- execParser cliInfo
case cli of
Run seed -> appMain seed
Run seed challenge -> appMain seed challenge
Format fo -> formatFile fo
LSP -> lspMain

6
bench/Benchmark.hs
View File

@ -13,7 +13,7 @@ import Data.Int (Int64)
import Linear.V2 (V2 (V2))
import Swarm.Game.CESK (emptyStore, initMachine)
import Swarm.Game.Robot (Robot, mkRobot)
import Swarm.Game.State (GameMode (Creative), GameState, addRobot, gameMode, initGameState, world)
import Swarm.Game.State (GameState, GameType (ClassicGame), addRobot, creativeMode, initGameState, world)
import Swarm.Game.Step (gameTick)
import Swarm.Game.Terrain (TerrainType (DirtT))
import Swarm.Game.World (newWorld)
@ -77,11 +77,11 @@ initRobot prog loc = mkRobot "" north loc (initMachine prog Context.empty emptyS
mkGameState :: (V2 Int64 -> Robot) -> Int -> IO GameState
mkGameState robotMaker numRobots = do
let robots = [robotMaker (V2 (fromIntegral x) 0) | x <- [0 .. numRobots -1]]
Right initState <- runExceptT (initGameState 0)
Right initState <- runExceptT (initGameState (ClassicGame 0))
execStateT
(mapM addRobot robots)
( initState
& gameMode .~ Creative
& creativeMode .~ True
& world .~ newWorld (const (fromEnum DirtT, Nothing))
)

41
data/challenges/move.yaml Normal file
View File

@ -0,0 +1,41 @@
name: Moving, part 1
entities:
- name: goal
display:
attr: device
char: 'X'
description:
- |
Robots can use the 'move' command to move forward one unit
in the direction they are currently facing. To complete
this challenge, move your robot two spaces to the right, to
the coordinates (2,0).
properties: [portable]
win: |
try {
loc <- as "base" {whereami};
return (loc == (2,0))
} { return false }
robots:
- name: base
loc: [0,0]
dir: [1,0]
devices:
- treads
- logger
inventory:
- [1, goal]
world:
palette:
'.': [grass, null]
'┌': [stone, upper left corner]
'┐': [stone, upper right corner]
'└': [stone, lower left corner]
'┘': [stone, lower right corner]
'─': [stone, horizontal wall]
'│': [stone, vertical wall]
upperleft: [-1, 1]
map: |
┌───┐
│...│
└───┘

51
data/challenges/move2.yaml Normal file
View File

@ -0,0 +1,51 @@
name: Moving, part 2
entities:
- name: goal
display:
attr: device
char: 'X'
description:
- |
In addition to 'move', you can use the 'turn' command
to turn your robot. 'turn' takes a direction as an argument,
which can be either absolute (north, west, east, south) or relative
(left, right, forward, back). Move your robot to the flower in
the northeast corner.
- name: knownflower
display:
attr: flower
char: '*'
description:
- A flower.
properties: [known]
win: |
try {
loc <- as "base" {whereami};
return (loc == (3,1))
} { return false }
robots:
- name: base
loc: [0,0]
dir: [1,0]
devices:
- treads
- logger
inventory:
- [1, goal]
world:
palette:
'.': [grass, null]
'┌': [stone, upper left corner]
'┐': [stone, upper right corner]
'└': [stone, lower left corner]
'┘': [stone, lower right corner]
'─': [stone, horizontal wall]
'│': [stone, vertical wall]
'*': [grass, knownflower]
upperleft: [-1, 2]
map: |
┌────┐
│...*│
│....│
└────┘

42
data/challenges/w0.yaml Normal file
View File

@ -0,0 +1,42 @@
name: Moving, part 1
entities:
- name: goal
display:
attr: device
char: 'X'
description:
- |
Robots can use the 'move' command to move forward one unit
in the direction they are currently facing. To complete
this challenge, move your robot two spaces to the right, to
the coordinates (2,0).
properties: [portable]
win: |
try {
loc <- as "base" {whereami};
return (loc == (2,0))
} { return false }
robots:
- name: base
loc: [0,0]
dir: [1,0]
devices:
- treads
- logger
inventory:
- [1, goal]
world:
seed: 0
palette:
'.': [grass, null]
'┌': [stone, upper left corner]
'┐': [stone, upper right corner]
'└': [stone, lower left corner]
'┘': [stone, lower right corner]
'─': [stone, horizontal wall]
'│': [stone, vertical wall]
upperleft: [-1, 1]
map: |
┌───┐
│...│
└───┘

52
data/entities.yaml
View File

@ -281,6 +281,58 @@
- A copy of the Linux operating system.
properties: [portable]
############################################################
### Utility ################################################
############################################################
- name: upper left corner
display:
attr: entity
char: '┌'
description:
- Upper left corner.
properties: [unwalkable, known]
- name: upper right corner
display:
attr: entity
char: '┐'
description:
- An upper right corner wall.
properties: [unwalkable, known]
- name: lower left corner
display:
attr: entity
char: '└'
description:
- A lower left corner wall.
properties: [unwalkable, known]
- name: lower right corner
display:
attr: entity
char: '┘'
description:
- A lower right corner wall.
properties: [unwalkable, known]
- name: horizontal wall
display:
attr: entity
char: '─'
description:
- A horizontal wall.
properties: [unwalkable, known]
- name: vertical wall
display:
attr: entity
char: '│'
description:
- A vertical wall.
properties: [unwalkable, known]
############################################################
### Devices ################################################
############################################################

6
src/Swarm/App.hs
View File

@ -38,9 +38,9 @@ app =
-- | The main @IO@ computation which initializes the state, sets up
-- some communication channels, and runs the UI.
appMain :: Seed -> IO ()
appMain seed = do
res <- runExceptT $ initAppState seed
appMain :: Seed -> Maybe String -> IO ()
appMain seed challenge = do
res <- runExceptT $ initAppState seed challenge
case res of
Left errMsg -> T.putStrLn errMsg
Right s -> do

164
src/Swarm/Game/Challenge.hs Normal file
View File

@ -0,0 +1,164 @@
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
-- |
-- Module : Swarm.Game.Challenge
-- Copyright : Brent Yorgey
-- Maintainer : byorgey@gmail.com
--
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Challenges are standalone worlds with specific starting and winning
-- conditions, which can be used both for building interactive
-- tutorials and for standalone puzzles and scenarios.
module Swarm.Game.Challenge (
-- * The Challenge type
Challenge (..),
-- ** Fields
challengeName,
challengeSeed,
challengeEntities,
challengeWorld,
challengeRobots,
challengeWin,
) where
import Control.Applicative ((<|>))
import Control.Arrow ((***))
import Control.Lens hiding (from)
import Data.Array
import Data.Bifunctor (first)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HM
import Data.Text (Text)
import qualified Data.Text as T
import Data.Yaml as Y
import GHC.Int (Int64)
import Linear.V2
import Witch (from, into)
import Swarm.Game.Entity
import Swarm.Game.Robot (Robot)
import Swarm.Game.Terrain
import Swarm.Game.World
import Swarm.Game.WorldGen (testWorld2FromArray)
import Swarm.Language.Pipeline (ProcessedTerm)
import Swarm.Util.Yaml
-- | A 'Challenge' contains all the information to describe a
-- challenge.
data Challenge = Challenge
{ _challengeName :: Text
, _challengeSeed :: Maybe Int
, _challengeEntities :: EntityMap
, _challengeWorld :: WorldFun Int Entity
, _challengeRobots :: [Robot]
, _challengeWin :: ProcessedTerm
}
makeLensesWith (lensRules & generateSignatures .~ False) ''Challenge
instance FromJSONE EntityMap Challenge where
parseJSONE = withObjectE "challenge" $ \v -> do
em <- liftE (buildEntityMap <$> (v .:? "entities" .!= []))
Challenge
<$> liftE (v .: "name")
<*> liftE (v .:? "seed") -- TODO: avoid two seeds
<*> pure em
<*> withE em (mkWorldFun (v .: "world"))
<*> withE em (v ..: "robots")
<*> liftE (v .: "win")
-- | the name of the challenge.
challengeName :: Lens' Challenge Text
-- | The seed used for the random number generator. If @Nothing@, use
-- a random seed.
challengeSeed :: Lens' Challenge (Maybe Int)
-- | Any custom entities used for this challenge.
challengeEntities :: Lens' Challenge EntityMap
-- | The starting world for the challenge.
challengeWorld :: Lens' Challenge (WorldFun Int Entity)
-- | The starting robots for the challenge. Note this should
-- include the "base".
challengeRobots :: Lens' Challenge [Robot]
-- | The winning condition for the challenge, expressed as a
-- program of type @cmd bool@. By default, this program will be
-- run to completion every tick (the usual limits on the number
-- of CESK steps per tick do not apply).
challengeWin :: Lens' Challenge ProcessedTerm
-- | 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 :: Either Int (TerrainType, Maybe Text)
, palette :: WorldPalette
, ul :: V2 Int64
, area :: Text
}
instance FromJSON WorldDescription where
parseJSON = withObject "world description" $ \v ->
WorldDescription
<$> ( Left <$> v .: "seed"
<|> Right <$> v .:? "default" .!= (BlankT, Nothing)
)
<*> v .: "palette"
<*> v .: "upperleft"
<*> v .: "map"
newtype WorldPalette = WorldPalette
{unPalette :: HashMap Text (TerrainType, Maybe Text)}
instance FromJSON WorldPalette where
parseJSON = withObject "palette" $ fmap WorldPalette . mapM parseJSON
mkWorldFun :: Parser WorldDescription -> ParserE EntityMap (WorldFun Int Entity)
mkWorldFun pwd = E $ \em -> do
wd <- pwd
let toEntity :: Char -> Parser (Int, Maybe Entity)
toEntity c = case HM.lookup (into @Text [c]) (unPalette (palette wd)) of
Nothing -> fail $ "Char not in entity palette: " ++ [c]
Just (t, mt) -> case mt of
Nothing -> return (fromEnum t, Nothing)
Just name -> case lookupEntityName name em of
Nothing -> fail $ "Unknown entity name: " ++ from @Text 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
Left seed -> do
let arr2 = bimap toEnum (fmap (^. entityName)) <$> arr
return $ (lkup em <$>) . first fromEnum <$> testWorld2FromArray arr2 seed
Right 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

30
src/Swarm/Game/Entity.hs
View File

@ -1,11 +1,13 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
-- |
@ -52,6 +54,7 @@ module Swarm.Game.Entity (
-- ** Entity map
EntityMap,
buildEntityMap,
loadEntities,
lookupEntityName,
deviceForCap,
@ -64,6 +67,7 @@ module Swarm.Game.Entity (
empty,
singleton,
fromList,
fromElems,
-- ** Lookup
lookup,
@ -102,19 +106,20 @@ import Data.Maybe (isJust, listToMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import GHC.Generics (Generic)
import Linear
import Linear (V2)
import Text.Read (readMaybe)
import Witch
import Prelude hiding (lookup)
import Data.Yaml
import Swarm.Util.Yaml
import Swarm.Game.Display
import Swarm.Language.Capability
import Swarm.Language.Syntax (toDirection)
import Swarm.Util (plural, (?))
import Paths_swarm
import Swarm.Util (plural, (?))
------------------------------------------------------------
-- Properties
@ -131,6 +136,8 @@ data EntityProperty
Growable
| -- | Robots drown if they walk on this.
Liquid
| -- | Robots automatically know what this is without having to scan it.
Known
deriving (Eq, Ord, Show, Read, Enum, Bounded, Generic, Hashable)
instance ToJSON EntityProperty where
@ -287,6 +294,13 @@ data EntityMap = EntityMap
, entitiesByCap :: Map Capability Entity
}
instance Semigroup EntityMap where
EntityMap n1 c1 <> EntityMap n2 c2 = EntityMap (n1 <> n2) (c1 <> c2)
instance Monoid EntityMap where
mempty = EntityMap M.empty M.empty
mappend = (<>)
-- | Find an entity with the given name.
lookupEntityName :: Text -> EntityMap -> Maybe Entity
lookupEntityName nm = M.lookup nm . entitiesByName
@ -329,6 +343,14 @@ instance FromJSON Entity where
where
reflow = T.unwords . T.words
-- | If we have access to an 'EntityMap', we can parse the name of an
-- 'Entity' as a string and look it up in the map.
instance FromJSONE EntityMap Entity where
parseJSONE = withTextE "entity name" $ \name ->
E $ \em -> case lookupEntityName name em of
Nothing -> fail $ "Unknown entity: " ++ from @Text name
Just e -> return e
instance ToJSON Entity where
toJSON e =
object $
@ -499,6 +521,10 @@ insert = insertCount 1
fromList :: [Entity] -> Inventory
fromList = foldl' (flip insert) empty
-- | Create an inventory from a list of entities and their counts.
fromElems :: [(Count, Entity)] -> Inventory
fromElems = foldl' (flip (uncurry insertCount)) empty
-- | Insert a certain number of copies of an entity into an inventory.
-- If the inventory already contains this entity, then only its
-- count will be incremented.

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

@ -1,3 +1,4 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
@ -48,6 +49,7 @@ module Swarm.Game.Robot (
-- ** Create
mkRobot,
mkRobot',
baseRobot,
-- ** Query
@ -67,6 +69,9 @@ import Data.Set.Lens (setOf)
import Data.Text (Text)
import Linear
import Data.Yaml ((.!=), (.:), (.:?))
import Swarm.Util.Yaml
import Data.Hashable (hashWithSalt)
import Swarm.Game.CESK
import Swarm.Game.Display
@ -325,6 +330,47 @@ mkRobot name l d m devs =
where
inst = fromList devs
-- | A more general function for creating robots.
mkRobot' ::
-- | Name of the robot.
Text ->
-- | Description of the robot.
[Text] ->
-- | Initial location.
V2 Int64 ->
-- | Initial heading/direction.
V2 Int64 ->
-- | Robot display.
Display ->
-- | Initial CESK machine.
CESK ->
-- | Installed devices.
[Entity] ->
-- | Initial inventory.
[(Count, Entity)] ->
-- | Should this be a system robot?
Bool ->
Robot
mkRobot' name descr loc dir disp m devs inv sys =
Robot
{ _robotEntity =
mkEntity disp name descr []
& entityOrientation ?~ dir
& entityInventory .~ fromElems inv
, _installedDevices = inst
, _robotCapabilities = inventoryCapabilities inst
, _robotLog = Seq.empty
, _robotLogUpdated = False
, _robotLocation = loc
, _robotContext = RobotContext empty empty empty emptyStore
, _machine = m
, _systemRobot = sys
, _selfDestruct = False
, _tickSteps = 0
}
where
inst = fromList devs
-- | The initial robot representing your "base".
baseRobot :: [Entity] -> Robot
baseRobot devs =
@ -351,6 +397,24 @@ baseRobot devs =
where
inst = fromList devs
-- | 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 Robot where
parseJSONE = withObjectE "robot" $ \v ->
mkRobot'
<$> liftE (v .: "name")
<*> liftE (v .:? "description" .!= [])
<*> liftE (v .: "loc")
<*> liftE (v .: "dir")
<*> liftE (v .:? "display" .!= defaultRobotDisplay)
<*> liftE (mkMachine <$> (v .:? "program"))
<*> v ..:? "devices" ..!= []
<*> v ..:? "inventory" ..!= []
<*> liftE (v .:? "system" .!= False)
where
mkMachine Nothing = idleMachine
mkMachine (Just pt) = initMachine pt mempty emptyStore
-- | Is the robot actively in the middle of a computation?
isActive :: Robot -> Bool
{-# INLINE isActive #-}

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

@ -1,5 +1,3 @@
-----------------------------------------------------------------------------
-----------------------------------------------------------------------------
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
@ -17,15 +15,20 @@
module Swarm.Game.State (
-- * Game state record
ViewCenterRule (..),
GameMode (..),
REPLStatus (..),
WinCondition (..),
_NoWinCondition,
_WinCondition,
_Won,
RunStatus (..),
GameType (..),
GameState,
Seed,
initGameState,
-- ** GameState fields
gameMode,
creativeMode,
winCondition,
runStatus,
paused,
robotMap,
@ -63,6 +66,7 @@ module Swarm.Game.State (
activateRobot,
) where
import Control.Arrow (Arrow ((&&&)))
import Control.Lens hiding (use, uses, view, (%=), (+=), (.=), (<+=), (<<.=))
import Control.Monad.Except
import Data.Bifunctor (first)
@ -71,25 +75,29 @@ import Data.IntMap (IntMap)
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Set (Set)
import qualified Data.Set as S
import Data.Set.Lens (setOf)
import Data.Text (Text)
import qualified Data.Text as T
import Linear
import System.Random (StdGen, mkStdGen)
import Witch (into)
import Control.Algebra (Has)
import Control.Effect.Lens
import Control.Effect.State (State)
import Data.Set (Set)
import qualified Data.Set as S
import Swarm.Game.Challenge
import Swarm.Game.Entity
import Swarm.Game.Recipe
import Swarm.Game.Robot
import Swarm.Game.Value
import qualified Swarm.Game.World as W
import Swarm.Game.WorldGen (Seed, findGoodOrigin, testWorld2)
import Swarm.Language.Pipeline (ProcessedTerm)
import Swarm.Language.Types
import Swarm.Util
import System.Random (StdGen, mkStdGen)
-- | The 'ViewCenterRule' specifies how to determine the center of the
-- world viewport.
@ -102,16 +110,6 @@ data ViewCenterRule
makePrisms ''ViewCenterRule
-- | The game mode determines various aspects of how the game works.
-- At the moment, there are only two modes, but more will be added
-- in the future.
data GameMode
= -- | Explore an open world, gather resources, and upgrade your programming abilities.
Classic
| -- | Like 'Classic' mode, but there are no constraints on the programs you can write.
Creative
deriving (Eq, Ord, Show, Read, Enum, Bounded)
-- | A data type to represent the current status of the REPL.
data REPLStatus
= -- | The REPL is not doing anything actively at the moment.
@ -123,6 +121,19 @@ data REPLStatus
REPLWorking Polytype (Maybe Value)
deriving (Eq, Show)
data WinCondition
= -- | There is no winning condition (e.g. we are in Classic or
-- Creative mode).
NoWinCondition
| -- | The player has not won yet; this 'ProcessedTerm' of type @cmd
-- bool@ is run every tick to determine whether they have won.
WinCondition ProcessedTerm
| -- | The player has won. The boolean indicates whether they have
-- already been congratulated.
Won Bool
makePrisms ''WinCondition
-- | A data type to keep track of the pause mode.
data RunStatus
= -- | The game is running.
@ -138,7 +149,8 @@ data RunStatus
-- distinct from the UI). See the lenses below for access to its
-- fields.
data GameState = GameState
{ _gameMode :: GameMode
{ _creativeMode :: Bool
, _winCondition :: WinCondition
, _runStatus :: RunStatus
, _robotMap :: Map Text Robot
, -- A set of robots to consider for the next game tick. It is guaranteed to
@ -184,8 +196,12 @@ let exclude = ['_viewCenter, '_focusedRobotName, '_viewCenterRule, '_activeRobot
)
''GameState
-- | The current 'GameMode'.
gameMode :: Lens' GameState GameMode
-- | Is the user in creative mode (i.e. able to do anything without restriction)?
creativeMode :: Lens' GameState Bool
-- | How to determine whether the player has won (e.g. when in
-- challenge mode).
winCondition :: Lens' GameState WinCondition
-- | The current 'RunStatus'.
runStatus :: Lens' GameState RunStatus
@ -370,15 +386,32 @@ addRobot r = do
internalActiveRobots %= S.insert (r' ^. robotName)
return r'
-- | Create an initial game state record, first loading entities and
-- recipies from disk.
initGameState :: Seed -> ExceptT Text IO GameState
initGameState seed = do
-- | What type of game does the user want to start?
data GameType
= ClassicGame Seed
| ChallengeGame (EntityMap -> ExceptT Text IO Challenge)
-- | The 'GameType', instantiated with loaded entites and records.
data InstGameType
= IClassicGame Seed
| IChallengeGame Challenge
instGameType :: EntityMap -> [Recipe Entity] -> GameType -> ExceptT Text IO InstGameType
instGameType em _rs gt = case gt of
ClassicGame s -> return $ IClassicGame s
ChallengeGame c -> IChallengeGame <$> c em
-- | Create an initial game state record for a particular game type,
-- first loading entities and recipies from disk.
initGameState :: GameType -> ExceptT Text IO GameState
initGameState gtype = do
liftIO $ putStrLn "Loading entities..."
entities <- loadEntities >>= (`isRightOr` id)
liftIO $ putStrLn "Loading recipes..."
recipes <- loadRecipes entities >>= (`isRightOr` id)
iGameType <- instGameType entities recipes gtype
let baseDeviceNames =
[ "solar panel"
, "3D printer"
@ -389,30 +422,51 @@ initGameState seed = do
, "logger"
]
baseDevices = mapMaybe (`lookupEntityName` entities) baseDeviceNames
let baseName = "base"
baseName = "base"
theBase = baseRobot baseDevices
robotList = case iGameType of
IClassicGame _ -> [theBase]
IChallengeGame c -> c ^. challengeRobots
creative = False
theWorld = case iGameType of
IClassicGame seed ->
W.newWorld
. fmap ((lkup entities <$>) . first fromEnum)
. findGoodOrigin
$ testWorld2 seed
IChallengeGame c -> W.newWorld (c ^. challengeWorld)
theWinCondition = case iGameType of
IClassicGame _ -> NoWinCondition
IChallengeGame c -> WinCondition (c ^. challengeWin)
seed <- case iGameType of
IClassicGame s -> return s
IChallengeGame c -> case c ^. challengeSeed of
Just s -> return s
Nothing -> return 0 -- XXX use a random seed
liftIO $ putStrLn ("Using seed... " <> show seed)
return $
GameState
{ _gameMode = Classic
{ _creativeMode = creative
, _winCondition = theWinCondition
, _runStatus = Running
, _robotMap = M.singleton baseName theBase
, _robotsByLocation = M.singleton zero (S.singleton baseName)
, _activeRobots = S.singleton baseName
, _robotMap = M.fromList $ map (view robotName &&& id) robotList
, _robotsByLocation =
M.fromListWith S.union $
map (view robotLocation &&& (S.singleton . view robotName)) robotList
, _activeRobots = setOf (traverse . robotName) robotList
, _waitingRobots = M.empty
, _gensym = 0
, _randGen = mkStdGen seed
, _entityMap = entities
, _recipesOut = outRecipeMap recipes
, _recipesIn = inRecipeMap recipes
, _world =
W.newWorld
. fmap ((lkup entities <$>) . first fromEnum)
. findGoodOrigin
$ testWorld2 seed
, _world = theWorld
, _viewCenterRule = VCRobot baseName
, _viewCenter = V2 0 0
, _needsRedraw = False

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

@ -20,7 +20,7 @@
module Swarm.Game.Step where
import Control.Lens hiding (Const, from, parts, use, uses, view, (%=), (+=), (.=), (<>=))
import Control.Monad (forM_, msum, unless, void, when)
import Control.Monad (forM_, guard, msum, unless, void, when)
import Data.Bool (bool)
import Data.Either (rights)
import Data.Int (Int64)
@ -129,9 +129,48 @@ gameTick = do
-- Possibly update the view center.
modify recalcViewCenter
-- Possibly see if the winning condition for challenge mode is met.
wc <- use winCondition
case wc of
WinCondition t -> do
v <- runThrow @Exn $ evalPT t
case v of
Left _exn -> return () -- XXX
Right (VBool True) -> winCondition .= Won False
_ -> return ()
_ -> return ()
-- Advance the game time by one.
ticks += 1
evalPT ::
(Has (Lift IO) sig m, Has (Throw Exn) sig m, Has (State GameState) sig m) =>
ProcessedTerm ->
m Value
evalPT t = evaluateCESK (initMachine t empty emptyStore)
evaluateCESK ::
(Has (Lift IO) sig m, Has (Throw Exn) sig m, Has (State GameState) sig m) =>
CESK ->
m Value
evaluateCESK cesk = evalState r . runCESK $ cesk
where
r = mkRobot "" zero zero cesk [] & systemRobot .~ True
runCESK ::
( Has (Lift IO) sig m
, Has (Throw Exn) sig m
, Has (State GameState) sig m
, Has (State Robot) sig m
) =>
CESK ->
m Value
runCESK (Up exn _ []) = throwError exn
runCESK cesk = case finalValue cesk of
Just (v, _) -> return v
Nothing -> stepCESK cesk >>= runCESK
------------------------------------------------------------
-- Some utility functions
------------------------------------------------------------
@ -199,11 +238,11 @@ traceLogShow = traceLog . from . show
-- or it is a system robot, or we are in creative mode).
ensureCanExecute :: (Has (State Robot) sig m, Has (State GameState) sig m, Has (Throw Exn) sig m) => Const -> m ()
ensureCanExecute c = do
mode <- use gameMode
creative <- use creativeMode
sys <- use systemRobot
robotCaps <- use robotCapabilities
let missingCaps = constCaps c `S.difference` robotCaps
(sys || mode == Creative || S.null missingCaps)
(sys || creative || S.null missingCaps)
`holdsOr` Incapable missingCaps (TConst c)
-- | Test whether the current robot has a given capability (either
@ -211,10 +250,10 @@ ensureCanExecute c = do
-- system robot, or we are in creative mode).
hasCapability :: (Has (State Robot) sig m, Has (State GameState) sig m) => Capability -> m Bool
hasCapability cap = do
mode <- use gameMode
creative <- use creativeMode
sys <- use systemRobot
caps <- use robotCapabilities
return (sys || mode == Creative || cap `S.member` caps)
return (sys || creative || cap `S.member` caps)
-- | Ensure that either a robot has a given capability, OR we are in creative
-- mode.
@ -863,6 +902,26 @@ execConst c vs s k = do
n <- uniform (0, hi - 1)
return $ Out (VInt n) s k
_ -> badConst
As -> case vs of
[VString name, prog] -> do
-- Get the named robot and current game state
r <- robotNamed name >>= (`isJustOrFail` ["There is no robot named ", name])
g <- get @GameState
-- Execute the given program *hypothetically*: i.e. in a fresh
-- CESK machine, using *copies* of the current store, robot
-- and game state. We discard the state afterwards so any
-- modifications made by prog do not persist. Note we also
-- set the copied robot to be a "system" robot so it is
-- capable of executing any commands; the As command
-- already requires "God" capability.
v <-
evalState @Robot (r & systemRobot .~ True) . evalState @GameState g $
runCESK (Out prog s [FApp (VCApp Force []), FExec])
-- Return the value returned by the hypothetical command.
return $ Out v s k
_ -> badConst
Say -> case vs of
[VString msg] -> do
rn <- use robotName
@ -984,7 +1043,7 @@ execConst c vs s k = do
[VString childRobotName, VDelay cmd e] -> do
r <- get
em <- use entityMap
mode <- use gameMode
creative <- use creativeMode
-- check if robot exists
childRobot <-
@ -1005,9 +1064,7 @@ execConst c vs s k = do
-- a robot can program adjacent robots
-- creative mode ignores distance checks
loc <- use robotLocation
( mode == Creative
|| (childRobot ^. robotLocation) `manhattan` loc <= 1
)
(creative || (childRobot ^. robotLocation) `manhattan` loc <= 1)
`holdsOrFail` ["You can only program adjacent robot"]
let -- Find out what capabilities are required by the program that will
@ -1022,7 +1079,7 @@ execConst c vs s k = do
missingDevices = S.filter (not . deviceOK) capDevices
-- check if robot has all devices to execute new command
(mode == Creative || S.null missingDevices)
(creative || S.null missingDevices)
`holdsOrFail` [ "the target robot does not have required devices:"
, commaList (map (^. entityName) (S.toList missingDevices))
]
@ -1063,7 +1120,7 @@ execConst c vs s k = do
[VString name, VDelay cmd e] -> do
r <- get
em <- use entityMap
mode <- use gameMode
creative <- use creativeMode
let -- Standard devices that are always installed.
-- XXX in the future, make a way to build these and just start the base
@ -1095,7 +1152,7 @@ execConst c vs s k = do
missingDevices = S.filter (not . deviceOK) capDevices
-- Make sure we're not missing any required devices.
(mode == Creative || S.null missingDevices)
(creative || S.null missingDevices)
`holdsOrFail` [ "this would require installing devices you don't have:"
, commaList (map (^. entityName) (S.toList missingDevices))
]
@ -1105,7 +1162,9 @@ execConst c vs s k = do
mkRobot
name
(r ^. robotLocation)
(r ^. robotOrientation ? east)
( ((r ^. robotOrientation) >>= \dir -> guard (dir /= zero) >> return dir)
? east
)
(In cmd e s [FExec])
(S.toList devices)
@ -1114,7 +1173,7 @@ execConst c vs s k = do
-- Remove from the inventory any devices which were installed on the new robot,
-- if not in creative mode.
unless (mode == Creative) $
unless creative $
forM_ (devices `S.difference` stdDevices) $ \d ->
robotInventory %= delete d
@ -1140,11 +1199,11 @@ execConst c vs s k = do
-- Also copy over its log, if we have one
inst <- use installedDevices
em <- use entityMap
mode <- use gameMode
creative <- use creativeMode
logger <-
lookupEntityName "logger" em
`isJustOr` Fatal "While executing 'salvage': there's no such thing as a logger!?"
when (mode == Creative || inst `E.contains` logger) $ robotLog <>= target ^. robotLog
when (creative || inst `E.contains` logger) $ robotLog <>= target ^. robotLog
-- Finally, delete the salvaged robot
deleteRobot (target ^. robotName)

17
src/Swarm/Game/Terrain.hs
View File

@ -1,9 +1,6 @@
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-----------------------------------------------------------------------------
-----------------------------------------------------------------------------
{-# LANGUAGE TypeApplications #-}
-- |
-- Module : Swarm.Game.Terrain
@ -21,8 +18,12 @@ module Swarm.Game.Terrain (
) where
import Brick (Widget)
import Data.Aeson (FromJSON (..), withText)
import Data.Map (Map, (!))
import qualified Data.Map as M
import qualified Data.Text as T
import Text.Read (readMaybe)
import Witch (into)
import Swarm.Game.Display
import Swarm.TUI.Attr
@ -34,8 +35,15 @@ data TerrainType
| DirtT
| GrassT
| IceT
| BlankT
deriving (Eq, Ord, Show, Read, Bounded, Enum)
instance FromJSON TerrainType where
parseJSON = withText "text" $ \t ->
case readMaybe (into @String (T.toTitle t) ++ "T") of
Just ter -> return ter
Nothing -> fail $ "Unknown terrain type: " ++ into @String t
-- | Display a terrain type as a single charcter widget.
displayTerrain :: TerrainType -> Widget n
displayTerrain t = displayWidget Nothing (terrainMap ! t)
@ -48,4 +56,5 @@ terrainMap =
, (DirtT, defaultTerrainDisplay '░' dirtAttr)
, (GrassT, defaultTerrainDisplay '░' grassAttr)
, (IceT, defaultTerrainDisplay ' ' iceAttr)
, (BlankT, defaultTerrainDisplay ' ' defAttr)
]

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

@ -1,5 +1,3 @@
-----------------------------------------------------------------------------
-----------------------------------------------------------------------------
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
@ -34,6 +32,7 @@ module Swarm.Game.World (
-- * Worlds
WorldFun,
worldFunFromArray,
World,
-- ** Tile management
@ -90,15 +89,27 @@ locToCoords (V2 x y) = Coords (- y, x)
coordsToLoc :: Coords -> V2 Int64
coordsToLoc (Coords (r, c)) = V2 c (- r)
------------------------------------------------------------
-- World function
------------------------------------------------------------
-- | 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)
-- XXX Allow smaller, finite worlds Too? Maybe add a variant of
-- newWorld that creates a finite world from an array. This could
-- be used e.g. to create puzzle levels, which can be loaded from a
-- file instead of generated via noise functions.
-- | 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
where
bnds = bounds arr
------------------------------------------------------------
-- Tiles and coordinates
------------------------------------------------------------
-- | The number of bits we need in each coordinate to represent all
-- the locations in a tile. In other words, each tile has a size of

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

@ -24,6 +24,7 @@ import Numeric.Noise.Perlin
import Numeric.Noise.Ridged
import Witch
import Data.Array.IArray
import Swarm.Game.Terrain
import Swarm.Game.World
@ -103,6 +104,16 @@ testWorld2 baseSeed (Coords ix@(r, c)) =
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
where
tw2 = testWorld2 seed
bnds = bounds arr
-- | Offset the world so the base starts on empty spot next to tree and grass.
findGoodOrigin :: WorldFun t Text -> WorldFun t Text
findGoodOrigin f = \(Coords (r, c)) -> f (Coords (r + rOffset, c + cOffset))

6
src/Swarm/Language/Capability.hs
View File

@ -99,6 +99,10 @@ data Capability
CReprogram
| -- | Capability to introspect and see it's own name
CWhoami
| -- | God-like capabilities. For e.g. commands intended only for
-- checking challenge mode win conditions, and not for use by
-- players.
CGod
deriving (Eq, Ord, Show, Read, Enum, Bounded, Generic, Hashable, Data)
instance ToJSON Capability where
@ -254,6 +258,8 @@ constCaps =
Salvage -> [CSalvage]
Reprogram -> [CReprogram]
Drill -> [CDrill]
-- Some God-like sensing abilities.
As -> [CGod]
-- String operations, which for now are enabled by CLog
Format -> [CLog]
Concat -> [CLog]

12
src/Swarm/Language/Pipeline.hs
View File

@ -27,6 +27,7 @@ import Data.Bifunctor (first)
import Data.Data (Data)
import Data.Set (Set)
import Data.Text (Text)
import Data.Yaml as Y
import Witch
import Swarm.Language.Capability
@ -50,7 +51,16 @@ data ProcessedTerm
-- ^ Capabilities required by the term
CapCtx
-- ^ Capability context for any definitions embedded in the term
deriving (Data)
deriving (Data, Show)
instance FromJSON ProcessedTerm where
parseJSON = withText "Term" tryProcess
where
tryProcess :: Text -> Y.Parser ProcessedTerm
tryProcess t = case processTerm t of
Left err -> fail $ "Could not parse term: " ++ from err
Right Nothing -> fail "Term was only whitespace"
Right (Just pt) -> return pt
-- | Given a 'Text' value representing a Swarm program,
--

5
src/Swarm/Language/Syntax.hs
View File

@ -327,6 +327,10 @@ data Const
-- | Application operator - helps to avoid parentheses:
-- @f $ g $ h x = f (g (h x))@
AppF
| -- God-like sensing operations
-- | Run a command as if you were another robot.
As
deriving (Eq, Ord, Enum, Bounded, Data, Show)
allConst :: [Const]
@ -455,6 +459,7 @@ constInfo c = case c of
Format -> functionLow 1
Concat -> binaryOp "++" 6 R
AppF -> binaryOp "$" 0 R
As -> commandLow 2
where
unaryOp s p side = ConstInfo {syntax = s, fixity = p, constMeta = ConstMUnOp side}
binaryOp s p side = ConstInfo {syntax = s, fixity = p, constMeta = ConstMBinOp side}

1
src/Swarm/Language/Typecheck.hs
View File

@ -477,6 +477,7 @@ inferConst c = toU $ case c of
Format -> [tyQ| a -> string |]
Concat -> [tyQ| string -> string -> string |]
AppF -> [tyQ| (a -> b) -> a -> b |]
As -> [tyQ| string -> {cmd a} -> cmd a |]
where
cmpBinT = [tyQ| a -> a -> bool |]
arithBinT = [tyQ| int -> int -> int |]

18
src/Swarm/TUI/Controller.hs
View File

@ -103,6 +103,7 @@ handleEvent s (VtyEvent (V.EvKey (V.KChar '\t') [])) = continue $ s & uiState .
handleEvent s (VtyEvent (V.EvKey V.KBackTab [])) = continue $ s & uiState . uiFocusRing %~ focusPrev
handleEvent s (VtyEvent (V.EvKey V.KEsc []))
| isJust (s ^. uiState . uiError) = continue $ s & uiState . uiError .~ Nothing
| isJust (s ^. uiState . uiModal) = continue $ s & uiState . uiModal .~ Nothing
handleEvent s ev = do
-- intercept special keys that works on all panels
case ev of
@ -365,7 +366,18 @@ updateUI = do
oldBotMore <- uiState . uiMoreInfoBot <<.= botMore
return $ oldTopMore /= topMore || oldBotMore /= botMore
let redraw = g ^. needsRedraw || inventoryUpdated || replUpdated || logUpdated || infoPanelUpdated
-- Decide whether to show a pop-up modal congratulating the user on
-- successfully completing the current challenge.
winModalUpdated <- do
w <- use (gameState . winCondition)
case w of
Won False -> do
gameState . winCondition .= Won True
uiState . uiModal .= Just WinModal
return True
_ -> return False
let redraw = g ^. needsRedraw || inventoryUpdated || replUpdated || logUpdated || infoPanelUpdated || winModalUpdated
pure redraw
-- | Make sure all tiles covering the visible part of the world are
@ -477,7 +489,7 @@ worldScrollDist = 8
handleWorldEvent :: AppState -> BrickEvent Name AppEvent -> EventM Name (Next AppState)
-- scrolling the world view in Creative mode
handleWorldEvent s (VtyEvent (V.EvKey k []))
| (s ^. gameState . gameMode) == Creative
| s ^. gameState . creativeMode
&& k
`elem` [ V.KUp
, V.KDown
@ -521,7 +533,7 @@ handleWorldEvent s (VtyEvent (V.EvKey (V.KChar 'f') [])) =
continue $ (s & uiState . uiShowFPS %~ not)
-- for testing only: toggle between classic & creative modes
handleWorldEvent s (VtyEvent (V.EvKey (V.KChar 'm') [])) =
continue (s & gameState . gameMode %~ cycleEnum)
continue (s & gameState . creativeMode %~ not)
-- Fall-through case: don't do anything.
handleWorldEvent s _ = continueWithoutRedraw s

37
src/Swarm/TUI/Model.hs
View File

@ -91,30 +91,36 @@ module Swarm.TUI.Model (
Seed,
) where
import Control.Lens
import Control.Lens hiding (from, (<.>))
import Control.Monad.Except
import Control.Monad.State
import Data.Bits (FiniteBits (finiteBitSize))
import Data.Foldable (toList)
import Data.List (findIndex, sortOn)
import Data.Maybe (fromMaybe, isJust)
import Data.Maybe (fromMaybe, isJust, listToMaybe)
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Vector as V
import Data.Yaml (prettyPrintParseException)
import System.Clock
import System.Directory (doesFileExist)
import System.FilePath ((<.>), (</>))
import Witch (from)
import Brick
import Brick.Focus
import Brick.Forms
import qualified Brick.Widgets.List as BL
import Paths_swarm (getDataFileName)
import Swarm.Game.Entity as E
import Swarm.Game.Robot
import Swarm.Game.State
import Swarm.Language.Types
import Swarm.Util
import Swarm.Util.Yaml
------------------------------------------------------------
-- Custom UI label types
@ -276,6 +282,7 @@ replIndexIsAtInput repl = repl ^. replIndex == replLength repl
data Modal
= HelpModal
| WinModal
deriving (Eq, Show)
-- | An entry in the inventory list displayed in the info panel. We
@ -538,8 +545,26 @@ gameState :: Lens' AppState GameState
uiState :: Lens' AppState UIState
-- | Initialize the 'AppState'.
initAppState :: Seed -> ExceptT Text IO AppState
initAppState seed = AppState <$> initGameState seed <*> initUIState
initAppState :: Seed -> Maybe String -> ExceptT Text IO AppState
initAppState seed challenge = do
let gtype = initGameType seed challenge
AppState <$> initGameState gtype <*> initUIState
------------------------------------------------------------
--
initGameType :: Seed -> Maybe String -> GameType
initGameType seed Nothing = ClassicGame seed
initGameType _ (Just challenge) =
ChallengeGame $ \em -> do
libChallenge <- lift $ getDataFileName $ "challenges" </> challenge
libChallengeExt <- lift $ getDataFileName $ "challenges" </> challenge <.> "yaml"
mfileName <-
lift $
listToMaybe <$> filterM doesFileExist [challenge, libChallengeExt, libChallenge]
case mfileName of
Nothing -> throwError $ "Challenge not found: " <> from @String challenge
Just fileName -> do
res <- lift $ decodeFileEitherE em fileName
case res of
Left parseExn -> throwError (from @String (prettyPrintParseException parseExn))
Right c -> return c

40
src/Swarm/TUI/View.hs
View File

@ -109,12 +109,7 @@ drawUI s =
WorldPanel
(plainBorder & bottomLabels . rightLabel ?~ padLeftRight 1 (drawTPS s))
(drawWorld $ s ^. gameState)
, drawMenu
(s ^. gameState . replWorking)
(s ^. gameState . paused)
((s ^. gameState . viewCenterRule) == VCRobot "base")
(s ^. gameState . gameMode)
(s ^. uiState)
, drawMenu s
, panel
highlightAttr
fr
@ -195,6 +190,7 @@ renderModal modal = renderDialog (dialog (Just modalTitle) Nothing maxModalWindo
(modalTitle, modalContent) =
case modal of
HelpModal -> ("Help", helpWidget)
WinModal -> ("", txt "Congratulations!")
helpWidget :: Widget Name
helpWidget = (helpKeys <=> fill ' ') <+> (helpCommands <=> fill ' ')
@ -239,8 +235,8 @@ drawDialog s = case s ^. uiModal of
-- | Draw a menu explaining what key commands are available for the
-- current panel. This menu is displayed as a single line in
-- between the world panel and the REPL.
drawMenu :: Bool -> Bool -> Bool -> GameMode -> UIState -> Widget Name
drawMenu isReplWorking isPaused viewingBase mode =
drawMenu :: AppState -> Widget Name
drawMenu s =
vLimit 1
. hBox
. (++ [gameModeWidget])
@ -248,15 +244,21 @@ drawMenu isReplWorking isPaused viewingBase mode =
. (globalKeyCmds ++)
. keyCmdsFor
. focusGetCurrent
. view uiFocusRing
. view (uiState . uiFocusRing)
$ s
where
isReplWorking = s ^. gameState . replWorking
isPaused = s ^. gameState . paused
viewingBase = (s ^. gameState . viewCenterRule) == VCRobot "base"
creative = s ^. gameState . creativeMode
gameModeWidget =
padLeft Max . padLeftRight 1
. txt
. (<> " mode")
$ case mode of
Classic -> "Classic"
Creative -> "Creative"
$ case creative of
False -> "Classic"
True -> "Creative"
globalKeyCmds =
[ ("F1", "help")
, ("Tab", "cycle panels")
@ -267,7 +269,7 @@ drawMenu isReplWorking isPaused viewingBase mode =
++ [("Enter", "execute") | not isReplWorking]
++ [("^c", "cancel") | isReplWorking]
keyCmdsFor (Just WorldPanel) =
[ ("←↓↑→ / hjkl", "scroll") | mode == Creative
[ ("←↓↑→ / hjkl", "scroll") | creative
]
++ [ ("<>", "slower/faster")
, ("p", if isPaused then "unpause" else "pause")
@ -320,7 +322,7 @@ drawWorld g =
drawLoc coords =
let (ePrio, eWidget) = drawCell hiding (g ^. world) coords
hiding =
if g ^. gameMode == Creative
if g ^. creativeMode
then HideNoEntity
else maybe HideAllEntities HideEntityUnknownTo $ focusedRobot g
in case M.lookup (W.coordsToLoc coords) robotsByLoc of
@ -343,10 +345,12 @@ drawCell edr w i = case W.lookupEntity i w of
, displayEntity (hide e)
)
where
known e = case edr of
HideAllEntities -> False
HideNoEntity -> True
HideEntityUnknownTo ro -> ro `robotKnows` e
known e =
e `hasProperty` Known
|| case edr of
HideAllEntities -> False
HideNoEntity -> True
HideEntityUnknownTo ro -> ro `robotKnows` e
hide e = (if known e then id else entityDisplay . defaultChar %~ const '?') e
------------------------------------------------------------

152
src/Swarm/Util/Yaml.hs Normal file
View File

@ -0,0 +1,152 @@
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE UndecidableInstances #-}
-- |
-- Module : Swarm.Util.Yaml
-- Copyright : Brent Yorgey
-- Maintainer : byorgey@gmail.com
--
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Various utilities related to parsing YAML files.
module Swarm.Util.Yaml (
With (..),
ParserE,
liftE,
withE,
FromJSONE (..),
decodeFileEitherE,
(..:),
(..:?),
(..!=),
withTextE,
withObjectE,
withArrayE,
) where
import Control.Monad.Reader
import Data.Aeson.Types (explicitParseField, explicitParseFieldMaybe)
import Data.Bifunctor (first)
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Vector as V
import Data.Yaml as Y
------------------------------------------------------------
-- WithEntities wrapper
------------------------------------------------------------
-- | A generic wrapper for computations which also depend on knowing a
-- value of type @e@.
newtype With e f a = E {runE :: e -> f a}
deriving (Functor)
deriving (Applicative, Monad, MonadFail) via (ReaderT e f)
-- | A 'ParserE' is a YAML 'Parser' that can also depend on knowing an
-- value of type @e@. The @E@ used to stand for @EntityMap@, but now
-- that it is generalized, it stands for Environment.
type ParserE e = With e Parser
-- | Lift a computation that does not care about the environment
-- value.
liftE :: Functor f => f a -> With e f a
liftE = E . const
withE :: Semigroup e => e -> With e f a -> With e f a
withE e (E f) = E (f . (<> e))
------------------------------------------------------------
-- FromJSONE
------------------------------------------------------------
-- | 'FromJSONE' governs values that can be parsed from a YAML (or
-- JSON) file, but which also have access to an extra, read-only
-- environment value.
--
-- For things that don't care about the environment, the default
-- implementation of 'parseJSONE' simply calls 'parseJSON' from a
-- 'FromJSON' instance.
class FromJSONE e a where
parseJSONE :: Value -> ParserE e a
default parseJSONE :: FromJSON a => Value -> ParserE e a
parseJSONE = liftE . parseJSON
parseJSONE' :: e -> Value -> Parser a
parseJSONE' e = ($e) . runE . parseJSONE
instance FromJSONE e Int
instance FromJSONE e a => FromJSONE e [a] where
parseJSONE = withArrayE "[]" (traverse parseJSONE . V.toList)
instance (FromJSONE e a, FromJSONE e b) => FromJSONE e (a, b) where
parseJSONE = withArrayE "(a, b)" $ \t ->
let n = V.length t
in if n == 2
then
(,)
<$> parseJSONE (V.unsafeIndex t 0)
<*> parseJSONE (V.unsafeIndex t 1)
else fail $ "cannot unpack array of length " ++ show n ++ " into a tuple of length 2"
------------------------------------------------------------
-- Decoding
------------------------------------------------------------
-- | Read a value from a YAML file, providing the needed extra
-- environment.
decodeFileEitherE :: FromJSONE e a => e -> FilePath -> IO (Either ParseException a)
decodeFileEitherE e file = do
res <- decodeFileEither file :: IO (Either ParseException Value)
return $ case res of
Left err -> Left err
Right v -> first AesonException $ parseEither (parseJSONE' e) v
------------------------------------------------------------
-- Accessors
------------------------------------------------------------
-- | A variant of '.:' for 'ParserE': project out a field of an
-- 'Object', passing along the extra environment.
(..:) :: FromJSONE e a => Object -> Text -> ParserE e a
v ..: x = E $ \e -> explicitParseField (parseJSONE' e) v x
-- | A variant of '.:?' for 'ParserE': project out an optional field of an
-- 'Object', passing along the extra environment.
(..:?) :: FromJSONE e a => Object -> Text -> ParserE e (Maybe a)
v ..:? x = E $ \e -> explicitParseFieldMaybe (parseJSONE' e) v x
-- | A variant of '.!=' for any functor.
(..!=) :: Functor f => f (Maybe a) -> a -> f a
p ..!= a = fromMaybe a <$> p
------------------------------------------------------------
-- Helpers
------------------------------------------------------------
withThingE ::
(forall b. String -> (thing -> Parser b) -> Value -> Parser b) ->
(String -> (thing -> ParserE e a) -> Value -> ParserE e a)
withThingE withThing name f = E . (\v es -> withThing name (($ es) . runE . f) v)
-- | @'withTextE' name f value@ applies @f@ to the 'Text' when @value@ is
-- a @String@ and fails otherwise.
withTextE :: String -> (Text -> ParserE e a) -> Value -> ParserE e a
withTextE = withThingE withText
-- | @'withObjectE' name f value@ applies @f@ to the 'Object' when @value@ is
-- an 'Object' and fails otherwise.
withObjectE :: String -> (Object -> ParserE e a) -> Value -> ParserE e a
withObjectE = withThingE withObject
-- | @'withArrayE' name f value@ applies @f@ to the 'Array' when @value@ is
-- an 'Array' and fails otherwise.
withArrayE :: String -> (Y.Array -> ParserE e a) -> Value -> ParserE e a
withArrayE = withThingE withArray

5
swarm.cabal
View File

@ -22,7 +22,7 @@ tested-with: GHC ==8.10.4 || ==9.0.1
extra-source-files: CHANGELOG.md
example/*.sw
data-dir: data/
data-files: *.yaml
data-files: *.yaml, challenges/*.yaml
source-repository head
type: git
@ -65,6 +65,7 @@ library
Swarm.Language.Pipeline
Swarm.Language.Pipeline.QQ
Swarm.Game.CESK
Swarm.Game.Challenge
Swarm.Game.Display
Swarm.Game.Entity
Swarm.Game.Exception
@ -85,6 +86,7 @@ library
Swarm.TUI.Controller
Swarm.App
Swarm.Util
Swarm.Util.Yaml
other-modules: Paths_swarm
autogen-modules: Paths_swarm
@ -176,6 +178,7 @@ test-suite swarm-integration
lens,
swarm,
text,
yaml,
witch
hs-source-dirs: test
default-language: Haskell2010

45
test/Integration.hs
View File

@ -7,34 +7,59 @@ module Main where
import Control.Monad
import Data.Functor
import Data.Text (Text)
import Data.Yaml (ParseException, prettyPrintParseException)
import System.Directory (doesFileExist, listDirectory)
import System.FilePath.Posix
import Test.Tasty
import Test.Tasty.HUnit
import Witch
import Swarm.Game.Challenge
import Swarm.Game.Entity
import Swarm.Language.Pipeline (processTerm)
import Swarm.Util.Yaml (decodeFileEitherE)
main :: IO ()
main = do
paths <- acquire
defaultMain . exampleTests $ paths
examplePaths <- acquire "example" "sw"
challengePaths <- acquire "data/challenges" "yaml"
entities <- loadEntities
case entities of
Left t -> fail $ "Couldn't load entities: " <> into @String t
Right em -> do
defaultMain $
testGroup
"Tests"
[ exampleTests examplePaths
, challengeTests em challengePaths
]
exampleTests :: [(FilePath, String)] -> TestTree
exampleTests inputs = testGroup "Test example" (map exampleTest inputs)
exampleTest :: (FilePath, String) -> TestTree
exampleTest (path, fileContent) = do
testCaseSteps ("processTerm for contents of " ++ show path) $ \_ -> do
exampleTest (path, fileContent) =
testCase ("processTerm for contents of " ++ show path) $ do
either (assertFailure . into @String) (const . return $ ()) value
where
value = processTerm $ into @Text fileContent
acquire :: IO [(FilePath, String)]
acquire = do
paths <- listDirectory exampleDirectory <&> map (exampleDirectory </>)
filePaths <- filterM (\path -> doesFileExist path <&> (&&) (swExtension path)) paths
challengeTests :: EntityMap -> [(FilePath, String)] -> TestTree
challengeTests em inputs = testGroup "Test challenges" (map (challengeTest em) inputs)
challengeTest :: EntityMap -> (FilePath, String) -> TestTree
challengeTest em (path, _) =
testCase ("parse challenge " ++ show path) $ do
res <- decodeFileEitherE em path :: IO (Either ParseException Challenge)
case res of
Left err -> assertFailure (prettyPrintParseException err)
Right _ -> return ()
acquire :: FilePath -> String -> IO [(FilePath, String)]
acquire dir ext = do
paths <- listDirectory dir <&> map (dir </>)
filePaths <- filterM (\path -> doesFileExist path <&> (&&) (hasExt path)) paths
mapM (\path -> (,) path <$> readFile path) filePaths
where
exampleDirectory = "example"
swExtension path = takeExtension path == ".sw"
hasExt path = takeExtension path == ("." ++ ext)

6
test/Unit.hs
View File

@ -25,7 +25,7 @@ import Swarm.Game.Entity qualified as E
import Swarm.Game.Exception
import Swarm.Game.Robot
import Swarm.Game.State
import Swarm.Game.Step
import Swarm.Game.Step (stepCESK)
import Swarm.Game.Value
import Swarm.Language.Context
import Swarm.Language.Pipeline (ProcessedTerm (..), processTerm)
@ -35,7 +35,7 @@ import Swarm.TUI.Model
main :: IO ()
main = do
mg <- runExceptT (initGameState 0)
mg <- runExceptT (initGameState (ClassicGame 0))
case mg of
Left err -> assertFailure (from err)
Right g -> defaultMain (tests g)
@ -471,7 +471,7 @@ eval g =
evalPT t = evaluateCESK (initMachine t empty emptyStore)
evaluateCESK :: CESK -> IO (Either Text (Value, Int))
evaluateCESK cesk = flip evalStateT (g & gameMode .~ Creative) . flip evalStateT r . runCESK 0 $ cesk
evaluateCESK cesk = flip evalStateT (g & creativeMode .~ True) . flip evalStateT r . runCESK 0 $ cesk
where
r = mkRobot "" zero zero cesk []