mirror of
https://github.com/swarm-game/swarm.git
synced 2024-08-17 02:20:31 +03:00
Challenge mode (#285)
Add a "challenge mode" where the player tries to achieve some specified goal from specific starting conditions.
This commit is contained in:
parent
b267441403
commit
b1f0e316fd
10
.mergify.yml
10
.mergify.yml
@ -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
10
app/Main.hs
@ -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
|
||||
|
@ -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
41
data/challenges/move.yaml
Normal 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
51
data/challenges/move2.yaml
Normal 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
42
data/challenges/w0.yaml
Normal 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: |
|
||||
┌───┐
|
||||
│...│
|
||||
└───┘
|
@ -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 ################################################
|
||||
############################################################
|
||||
|
@ -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
164
src/Swarm/Game/Challenge.hs
Normal 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
|
@ -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.
|
||||
|
@ -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 #-}
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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)
|
||||
]
|
||||
|
@ -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
|
||||
|
@ -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))
|
||||
|
@ -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]
|
||||
|
@ -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,
|
||||
--
|
||||
|
@ -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}
|
||||
|
@ -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 |]
|
||||
|
@ -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
|
||||
|
||||
|
@ -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
|
||||
|
@ -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
152
src/Swarm/Util/Yaml.hs
Normal 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
|
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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 []
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user