mirror of
https://github.com/swarm-game/swarm.git
synced 2024-09-11 14:46:33 +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:
|
pull_request_rules:
|
||||||
- actions:
|
- actions:
|
||||||
merge:
|
queue:
|
||||||
strict: smart
|
name: default
|
||||||
method: squash
|
method: squash
|
||||||
commit_message: title+body
|
commit_message: title+body
|
||||||
name: Automatically merge pull requests
|
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
|
import System.Exit
|
||||||
|
|
||||||
data CLI
|
data CLI
|
||||||
= Run Int
|
= Run Int (Maybe FilePath)
|
||||||
| Format Input
|
| Format Input
|
||||||
| LSP
|
| LSP
|
||||||
|
|
||||||
@ -24,14 +24,16 @@ cliParser =
|
|||||||
( command "format" (info (format <**> helper) (progDesc "Format a file"))
|
( command "format" (info (format <**> helper) (progDesc "Format a file"))
|
||||||
<> command "lsp" (info (pure LSP) (progDesc "Start the LSP"))
|
<> command "lsp" (info (pure LSP) (progDesc "Start the LSP"))
|
||||||
)
|
)
|
||||||
<|> Run <$> seed
|
<|> Run <$> seed <*> challenge
|
||||||
where
|
where
|
||||||
format :: Parser CLI
|
format :: Parser CLI
|
||||||
format =
|
format =
|
||||||
(Format Stdin <$ switch (long "stdin" <> help "Read code from stdin"))
|
(Format Stdin <$ switch (long "stdin" <> help "Read code from stdin"))
|
||||||
<|> (Format . File <$> strArgument (metavar "FILE"))
|
<|> (Format . File <$> strArgument (metavar "FILE"))
|
||||||
seed :: Parser Int
|
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 :: ParserInfo CLI
|
||||||
cliInfo =
|
cliInfo =
|
||||||
@ -68,6 +70,6 @@ main :: IO ()
|
|||||||
main = do
|
main = do
|
||||||
cli <- execParser cliInfo
|
cli <- execParser cliInfo
|
||||||
case cli of
|
case cli of
|
||||||
Run seed -> appMain seed
|
Run seed challenge -> appMain seed challenge
|
||||||
Format fo -> formatFile fo
|
Format fo -> formatFile fo
|
||||||
LSP -> lspMain
|
LSP -> lspMain
|
||||||
|
@ -13,7 +13,7 @@ import Data.Int (Int64)
|
|||||||
import Linear.V2 (V2 (V2))
|
import Linear.V2 (V2 (V2))
|
||||||
import Swarm.Game.CESK (emptyStore, initMachine)
|
import Swarm.Game.CESK (emptyStore, initMachine)
|
||||||
import Swarm.Game.Robot (Robot, mkRobot)
|
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.Step (gameTick)
|
||||||
import Swarm.Game.Terrain (TerrainType (DirtT))
|
import Swarm.Game.Terrain (TerrainType (DirtT))
|
||||||
import Swarm.Game.World (newWorld)
|
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 :: (V2 Int64 -> Robot) -> Int -> IO GameState
|
||||||
mkGameState robotMaker numRobots = do
|
mkGameState robotMaker numRobots = do
|
||||||
let robots = [robotMaker (V2 (fromIntegral x) 0) | x <- [0 .. numRobots -1]]
|
let robots = [robotMaker (V2 (fromIntegral x) 0) | x <- [0 .. numRobots -1]]
|
||||||
Right initState <- runExceptT (initGameState 0)
|
Right initState <- runExceptT (initGameState (ClassicGame 0))
|
||||||
execStateT
|
execStateT
|
||||||
(mapM addRobot robots)
|
(mapM addRobot robots)
|
||||||
( initState
|
( initState
|
||||||
& gameMode .~ Creative
|
& creativeMode .~ True
|
||||||
& world .~ newWorld (const (fromEnum DirtT, Nothing))
|
& 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.
|
- A copy of the Linux operating system.
|
||||||
properties: [portable]
|
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 ################################################
|
### Devices ################################################
|
||||||
############################################################
|
############################################################
|
||||||
|
@ -38,9 +38,9 @@ app =
|
|||||||
|
|
||||||
-- | The main @IO@ computation which initializes the state, sets up
|
-- | The main @IO@ computation which initializes the state, sets up
|
||||||
-- some communication channels, and runs the UI.
|
-- some communication channels, and runs the UI.
|
||||||
appMain :: Seed -> IO ()
|
appMain :: Seed -> Maybe String -> IO ()
|
||||||
appMain seed = do
|
appMain seed challenge = do
|
||||||
res <- runExceptT $ initAppState seed
|
res <- runExceptT $ initAppState seed challenge
|
||||||
case res of
|
case res of
|
||||||
Left errMsg -> T.putStrLn errMsg
|
Left errMsg -> T.putStrLn errMsg
|
||||||
Right s -> do
|
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 DeriveAnyClass #-}
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE RankNTypes #-}
|
{-# LANGUAGE RankNTypes #-}
|
||||||
{-# LANGUAGE StandaloneDeriving #-}
|
{-# LANGUAGE StandaloneDeriving #-}
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
{-# LANGUAGE TupleSections #-}
|
{-# LANGUAGE TupleSections #-}
|
||||||
|
{-# LANGUAGE TypeApplications #-}
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
|
||||||
-- |
|
-- |
|
||||||
@ -52,6 +54,7 @@ module Swarm.Game.Entity (
|
|||||||
|
|
||||||
-- ** Entity map
|
-- ** Entity map
|
||||||
EntityMap,
|
EntityMap,
|
||||||
|
buildEntityMap,
|
||||||
loadEntities,
|
loadEntities,
|
||||||
lookupEntityName,
|
lookupEntityName,
|
||||||
deviceForCap,
|
deviceForCap,
|
||||||
@ -64,6 +67,7 @@ module Swarm.Game.Entity (
|
|||||||
empty,
|
empty,
|
||||||
singleton,
|
singleton,
|
||||||
fromList,
|
fromList,
|
||||||
|
fromElems,
|
||||||
|
|
||||||
-- ** Lookup
|
-- ** Lookup
|
||||||
lookup,
|
lookup,
|
||||||
@ -102,19 +106,20 @@ import Data.Maybe (isJust, listToMaybe)
|
|||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import GHC.Generics (Generic)
|
import GHC.Generics (Generic)
|
||||||
import Linear
|
import Linear (V2)
|
||||||
import Text.Read (readMaybe)
|
import Text.Read (readMaybe)
|
||||||
import Witch
|
import Witch
|
||||||
import Prelude hiding (lookup)
|
import Prelude hiding (lookup)
|
||||||
|
|
||||||
import Data.Yaml
|
import Data.Yaml
|
||||||
|
import Swarm.Util.Yaml
|
||||||
|
|
||||||
import Swarm.Game.Display
|
import Swarm.Game.Display
|
||||||
import Swarm.Language.Capability
|
import Swarm.Language.Capability
|
||||||
import Swarm.Language.Syntax (toDirection)
|
import Swarm.Language.Syntax (toDirection)
|
||||||
|
import Swarm.Util (plural, (?))
|
||||||
|
|
||||||
import Paths_swarm
|
import Paths_swarm
|
||||||
import Swarm.Util (plural, (?))
|
|
||||||
|
|
||||||
------------------------------------------------------------
|
------------------------------------------------------------
|
||||||
-- Properties
|
-- Properties
|
||||||
@ -131,6 +136,8 @@ data EntityProperty
|
|||||||
Growable
|
Growable
|
||||||
| -- | Robots drown if they walk on this.
|
| -- | Robots drown if they walk on this.
|
||||||
Liquid
|
Liquid
|
||||||
|
| -- | Robots automatically know what this is without having to scan it.
|
||||||
|
Known
|
||||||
deriving (Eq, Ord, Show, Read, Enum, Bounded, Generic, Hashable)
|
deriving (Eq, Ord, Show, Read, Enum, Bounded, Generic, Hashable)
|
||||||
|
|
||||||
instance ToJSON EntityProperty where
|
instance ToJSON EntityProperty where
|
||||||
@ -287,6 +294,13 @@ data EntityMap = EntityMap
|
|||||||
, entitiesByCap :: Map Capability Entity
|
, 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.
|
-- | Find an entity with the given name.
|
||||||
lookupEntityName :: Text -> EntityMap -> Maybe Entity
|
lookupEntityName :: Text -> EntityMap -> Maybe Entity
|
||||||
lookupEntityName nm = M.lookup nm . entitiesByName
|
lookupEntityName nm = M.lookup nm . entitiesByName
|
||||||
@ -329,6 +343,14 @@ instance FromJSON Entity where
|
|||||||
where
|
where
|
||||||
reflow = T.unwords . T.words
|
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
|
instance ToJSON Entity where
|
||||||
toJSON e =
|
toJSON e =
|
||||||
object $
|
object $
|
||||||
@ -499,6 +521,10 @@ insert = insertCount 1
|
|||||||
fromList :: [Entity] -> Inventory
|
fromList :: [Entity] -> Inventory
|
||||||
fromList = foldl' (flip insert) empty
|
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.
|
-- | Insert a certain number of copies of an entity into an inventory.
|
||||||
-- If the inventory already contains this entity, then only its
|
-- If the inventory already contains this entity, then only its
|
||||||
-- count will be incremented.
|
-- count will be incremented.
|
||||||
|
@ -1,3 +1,4 @@
|
|||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
|
||||||
@ -48,6 +49,7 @@ module Swarm.Game.Robot (
|
|||||||
|
|
||||||
-- ** Create
|
-- ** Create
|
||||||
mkRobot,
|
mkRobot,
|
||||||
|
mkRobot',
|
||||||
baseRobot,
|
baseRobot,
|
||||||
|
|
||||||
-- ** Query
|
-- ** Query
|
||||||
@ -67,6 +69,9 @@ import Data.Set.Lens (setOf)
|
|||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Linear
|
import Linear
|
||||||
|
|
||||||
|
import Data.Yaml ((.!=), (.:), (.:?))
|
||||||
|
import Swarm.Util.Yaml
|
||||||
|
|
||||||
import Data.Hashable (hashWithSalt)
|
import Data.Hashable (hashWithSalt)
|
||||||
import Swarm.Game.CESK
|
import Swarm.Game.CESK
|
||||||
import Swarm.Game.Display
|
import Swarm.Game.Display
|
||||||
@ -325,6 +330,47 @@ mkRobot name l d m devs =
|
|||||||
where
|
where
|
||||||
inst = fromList devs
|
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".
|
-- | The initial robot representing your "base".
|
||||||
baseRobot :: [Entity] -> Robot
|
baseRobot :: [Entity] -> Robot
|
||||||
baseRobot devs =
|
baseRobot devs =
|
||||||
@ -351,6 +397,24 @@ baseRobot devs =
|
|||||||
where
|
where
|
||||||
inst = fromList devs
|
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?
|
-- | Is the robot actively in the middle of a computation?
|
||||||
isActive :: Robot -> Bool
|
isActive :: Robot -> Bool
|
||||||
{-# INLINE isActive #-}
|
{-# INLINE isActive #-}
|
||||||
|
@ -1,5 +1,3 @@
|
|||||||
-----------------------------------------------------------------------------
|
|
||||||
-----------------------------------------------------------------------------
|
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
@ -17,15 +15,20 @@
|
|||||||
module Swarm.Game.State (
|
module Swarm.Game.State (
|
||||||
-- * Game state record
|
-- * Game state record
|
||||||
ViewCenterRule (..),
|
ViewCenterRule (..),
|
||||||
GameMode (..),
|
|
||||||
REPLStatus (..),
|
REPLStatus (..),
|
||||||
|
WinCondition (..),
|
||||||
|
_NoWinCondition,
|
||||||
|
_WinCondition,
|
||||||
|
_Won,
|
||||||
RunStatus (..),
|
RunStatus (..),
|
||||||
|
GameType (..),
|
||||||
GameState,
|
GameState,
|
||||||
Seed,
|
Seed,
|
||||||
initGameState,
|
initGameState,
|
||||||
|
|
||||||
-- ** GameState fields
|
-- ** GameState fields
|
||||||
gameMode,
|
creativeMode,
|
||||||
|
winCondition,
|
||||||
runStatus,
|
runStatus,
|
||||||
paused,
|
paused,
|
||||||
robotMap,
|
robotMap,
|
||||||
@ -63,6 +66,7 @@ module Swarm.Game.State (
|
|||||||
activateRobot,
|
activateRobot,
|
||||||
) where
|
) where
|
||||||
|
|
||||||
|
import Control.Arrow (Arrow ((&&&)))
|
||||||
import Control.Lens hiding (use, uses, view, (%=), (+=), (.=), (<+=), (<<.=))
|
import Control.Lens hiding (use, uses, view, (%=), (+=), (.=), (<+=), (<<.=))
|
||||||
import Control.Monad.Except
|
import Control.Monad.Except
|
||||||
import Data.Bifunctor (first)
|
import Data.Bifunctor (first)
|
||||||
@ -71,25 +75,29 @@ import Data.IntMap (IntMap)
|
|||||||
import Data.Map (Map)
|
import Data.Map (Map)
|
||||||
import qualified Data.Map as M
|
import qualified Data.Map as M
|
||||||
import Data.Maybe (fromMaybe, mapMaybe)
|
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 Data.Text (Text)
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import Linear
|
import Linear
|
||||||
|
import System.Random (StdGen, mkStdGen)
|
||||||
import Witch (into)
|
import Witch (into)
|
||||||
|
|
||||||
import Control.Algebra (Has)
|
import Control.Algebra (Has)
|
||||||
import Control.Effect.Lens
|
import Control.Effect.Lens
|
||||||
import Control.Effect.State (State)
|
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.Entity
|
||||||
import Swarm.Game.Recipe
|
import Swarm.Game.Recipe
|
||||||
import Swarm.Game.Robot
|
import Swarm.Game.Robot
|
||||||
import Swarm.Game.Value
|
import Swarm.Game.Value
|
||||||
import qualified Swarm.Game.World as W
|
import qualified Swarm.Game.World as W
|
||||||
import Swarm.Game.WorldGen (Seed, findGoodOrigin, testWorld2)
|
import Swarm.Game.WorldGen (Seed, findGoodOrigin, testWorld2)
|
||||||
|
import Swarm.Language.Pipeline (ProcessedTerm)
|
||||||
import Swarm.Language.Types
|
import Swarm.Language.Types
|
||||||
import Swarm.Util
|
import Swarm.Util
|
||||||
import System.Random (StdGen, mkStdGen)
|
|
||||||
|
|
||||||
-- | The 'ViewCenterRule' specifies how to determine the center of the
|
-- | The 'ViewCenterRule' specifies how to determine the center of the
|
||||||
-- world viewport.
|
-- world viewport.
|
||||||
@ -102,16 +110,6 @@ data ViewCenterRule
|
|||||||
|
|
||||||
makePrisms ''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.
|
-- | A data type to represent the current status of the REPL.
|
||||||
data REPLStatus
|
data REPLStatus
|
||||||
= -- | The REPL is not doing anything actively at the moment.
|
= -- | The REPL is not doing anything actively at the moment.
|
||||||
@ -123,6 +121,19 @@ data REPLStatus
|
|||||||
REPLWorking Polytype (Maybe Value)
|
REPLWorking Polytype (Maybe Value)
|
||||||
deriving (Eq, Show)
|
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.
|
-- | A data type to keep track of the pause mode.
|
||||||
data RunStatus
|
data RunStatus
|
||||||
= -- | The game is running.
|
= -- | The game is running.
|
||||||
@ -138,7 +149,8 @@ data RunStatus
|
|||||||
-- distinct from the UI). See the lenses below for access to its
|
-- distinct from the UI). See the lenses below for access to its
|
||||||
-- fields.
|
-- fields.
|
||||||
data GameState = GameState
|
data GameState = GameState
|
||||||
{ _gameMode :: GameMode
|
{ _creativeMode :: Bool
|
||||||
|
, _winCondition :: WinCondition
|
||||||
, _runStatus :: RunStatus
|
, _runStatus :: RunStatus
|
||||||
, _robotMap :: Map Text Robot
|
, _robotMap :: Map Text Robot
|
||||||
, -- A set of robots to consider for the next game tick. It is guaranteed to
|
, -- 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
|
''GameState
|
||||||
|
|
||||||
-- | The current 'GameMode'.
|
-- | Is the user in creative mode (i.e. able to do anything without restriction)?
|
||||||
gameMode :: Lens' GameState GameMode
|
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'.
|
-- | The current 'RunStatus'.
|
||||||
runStatus :: Lens' GameState RunStatus
|
runStatus :: Lens' GameState RunStatus
|
||||||
@ -370,15 +386,32 @@ addRobot r = do
|
|||||||
internalActiveRobots %= S.insert (r' ^. robotName)
|
internalActiveRobots %= S.insert (r' ^. robotName)
|
||||||
return r'
|
return r'
|
||||||
|
|
||||||
-- | Create an initial game state record, first loading entities and
|
-- | What type of game does the user want to start?
|
||||||
-- recipies from disk.
|
data GameType
|
||||||
initGameState :: Seed -> ExceptT Text IO GameState
|
= ClassicGame Seed
|
||||||
initGameState seed = do
|
| 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..."
|
liftIO $ putStrLn "Loading entities..."
|
||||||
entities <- loadEntities >>= (`isRightOr` id)
|
entities <- loadEntities >>= (`isRightOr` id)
|
||||||
liftIO $ putStrLn "Loading recipes..."
|
liftIO $ putStrLn "Loading recipes..."
|
||||||
recipes <- loadRecipes entities >>= (`isRightOr` id)
|
recipes <- loadRecipes entities >>= (`isRightOr` id)
|
||||||
|
|
||||||
|
iGameType <- instGameType entities recipes gtype
|
||||||
|
|
||||||
let baseDeviceNames =
|
let baseDeviceNames =
|
||||||
[ "solar panel"
|
[ "solar panel"
|
||||||
, "3D printer"
|
, "3D printer"
|
||||||
@ -389,30 +422,51 @@ initGameState seed = do
|
|||||||
, "logger"
|
, "logger"
|
||||||
]
|
]
|
||||||
baseDevices = mapMaybe (`lookupEntityName` entities) baseDeviceNames
|
baseDevices = mapMaybe (`lookupEntityName` entities) baseDeviceNames
|
||||||
|
baseName = "base"
|
||||||
let baseName = "base"
|
|
||||||
theBase = baseRobot baseDevices
|
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)
|
liftIO $ putStrLn ("Using seed... " <> show seed)
|
||||||
|
|
||||||
return $
|
return $
|
||||||
GameState
|
GameState
|
||||||
{ _gameMode = Classic
|
{ _creativeMode = creative
|
||||||
|
, _winCondition = theWinCondition
|
||||||
, _runStatus = Running
|
, _runStatus = Running
|
||||||
, _robotMap = M.singleton baseName theBase
|
, _robotMap = M.fromList $ map (view robotName &&& id) robotList
|
||||||
, _robotsByLocation = M.singleton zero (S.singleton baseName)
|
, _robotsByLocation =
|
||||||
, _activeRobots = S.singleton baseName
|
M.fromListWith S.union $
|
||||||
|
map (view robotLocation &&& (S.singleton . view robotName)) robotList
|
||||||
|
, _activeRobots = setOf (traverse . robotName) robotList
|
||||||
, _waitingRobots = M.empty
|
, _waitingRobots = M.empty
|
||||||
, _gensym = 0
|
, _gensym = 0
|
||||||
, _randGen = mkStdGen seed
|
, _randGen = mkStdGen seed
|
||||||
, _entityMap = entities
|
, _entityMap = entities
|
||||||
, _recipesOut = outRecipeMap recipes
|
, _recipesOut = outRecipeMap recipes
|
||||||
, _recipesIn = inRecipeMap recipes
|
, _recipesIn = inRecipeMap recipes
|
||||||
, _world =
|
, _world = theWorld
|
||||||
W.newWorld
|
|
||||||
. fmap ((lkup entities <$>) . first fromEnum)
|
|
||||||
. findGoodOrigin
|
|
||||||
$ testWorld2 seed
|
|
||||||
, _viewCenterRule = VCRobot baseName
|
, _viewCenterRule = VCRobot baseName
|
||||||
, _viewCenter = V2 0 0
|
, _viewCenter = V2 0 0
|
||||||
, _needsRedraw = False
|
, _needsRedraw = False
|
||||||
|
@ -20,7 +20,7 @@
|
|||||||
module Swarm.Game.Step where
|
module Swarm.Game.Step where
|
||||||
|
|
||||||
import Control.Lens hiding (Const, from, parts, use, uses, view, (%=), (+=), (.=), (<>=))
|
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.Bool (bool)
|
||||||
import Data.Either (rights)
|
import Data.Either (rights)
|
||||||
import Data.Int (Int64)
|
import Data.Int (Int64)
|
||||||
@ -129,9 +129,48 @@ gameTick = do
|
|||||||
|
|
||||||
-- Possibly update the view center.
|
-- Possibly update the view center.
|
||||||
modify recalcViewCenter
|
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.
|
-- Advance the game time by one.
|
||||||
ticks += 1
|
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
|
-- Some utility functions
|
||||||
------------------------------------------------------------
|
------------------------------------------------------------
|
||||||
@ -199,11 +238,11 @@ traceLogShow = traceLog . from . show
|
|||||||
-- or it is a system robot, or we are in creative mode).
|
-- 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 :: (Has (State Robot) sig m, Has (State GameState) sig m, Has (Throw Exn) sig m) => Const -> m ()
|
||||||
ensureCanExecute c = do
|
ensureCanExecute c = do
|
||||||
mode <- use gameMode
|
creative <- use creativeMode
|
||||||
sys <- use systemRobot
|
sys <- use systemRobot
|
||||||
robotCaps <- use robotCapabilities
|
robotCaps <- use robotCapabilities
|
||||||
let missingCaps = constCaps c `S.difference` robotCaps
|
let missingCaps = constCaps c `S.difference` robotCaps
|
||||||
(sys || mode == Creative || S.null missingCaps)
|
(sys || creative || S.null missingCaps)
|
||||||
`holdsOr` Incapable missingCaps (TConst c)
|
`holdsOr` Incapable missingCaps (TConst c)
|
||||||
|
|
||||||
-- | Test whether the current robot has a given capability (either
|
-- | 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).
|
-- system robot, or we are in creative mode).
|
||||||
hasCapability :: (Has (State Robot) sig m, Has (State GameState) sig m) => Capability -> m Bool
|
hasCapability :: (Has (State Robot) sig m, Has (State GameState) sig m) => Capability -> m Bool
|
||||||
hasCapability cap = do
|
hasCapability cap = do
|
||||||
mode <- use gameMode
|
creative <- use creativeMode
|
||||||
sys <- use systemRobot
|
sys <- use systemRobot
|
||||||
caps <- use robotCapabilities
|
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
|
-- | Ensure that either a robot has a given capability, OR we are in creative
|
||||||
-- mode.
|
-- mode.
|
||||||
@ -863,6 +902,26 @@ execConst c vs s k = do
|
|||||||
n <- uniform (0, hi - 1)
|
n <- uniform (0, hi - 1)
|
||||||
return $ Out (VInt n) s k
|
return $ Out (VInt n) s k
|
||||||
_ -> badConst
|
_ -> 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
|
Say -> case vs of
|
||||||
[VString msg] -> do
|
[VString msg] -> do
|
||||||
rn <- use robotName
|
rn <- use robotName
|
||||||
@ -984,7 +1043,7 @@ execConst c vs s k = do
|
|||||||
[VString childRobotName, VDelay cmd e] -> do
|
[VString childRobotName, VDelay cmd e] -> do
|
||||||
r <- get
|
r <- get
|
||||||
em <- use entityMap
|
em <- use entityMap
|
||||||
mode <- use gameMode
|
creative <- use creativeMode
|
||||||
|
|
||||||
-- check if robot exists
|
-- check if robot exists
|
||||||
childRobot <-
|
childRobot <-
|
||||||
@ -1005,9 +1064,7 @@ execConst c vs s k = do
|
|||||||
-- a robot can program adjacent robots
|
-- a robot can program adjacent robots
|
||||||
-- creative mode ignores distance checks
|
-- creative mode ignores distance checks
|
||||||
loc <- use robotLocation
|
loc <- use robotLocation
|
||||||
( mode == Creative
|
(creative || (childRobot ^. robotLocation) `manhattan` loc <= 1)
|
||||||
|| (childRobot ^. robotLocation) `manhattan` loc <= 1
|
|
||||||
)
|
|
||||||
`holdsOrFail` ["You can only program adjacent robot"]
|
`holdsOrFail` ["You can only program adjacent robot"]
|
||||||
|
|
||||||
let -- Find out what capabilities are required by the program that will
|
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
|
missingDevices = S.filter (not . deviceOK) capDevices
|
||||||
|
|
||||||
-- check if robot has all devices to execute new command
|
-- 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:"
|
`holdsOrFail` [ "the target robot does not have required devices:"
|
||||||
, commaList (map (^. entityName) (S.toList missingDevices))
|
, commaList (map (^. entityName) (S.toList missingDevices))
|
||||||
]
|
]
|
||||||
@ -1063,7 +1120,7 @@ execConst c vs s k = do
|
|||||||
[VString name, VDelay cmd e] -> do
|
[VString name, VDelay cmd e] -> do
|
||||||
r <- get
|
r <- get
|
||||||
em <- use entityMap
|
em <- use entityMap
|
||||||
mode <- use gameMode
|
creative <- use creativeMode
|
||||||
|
|
||||||
let -- Standard devices that are always installed.
|
let -- Standard devices that are always installed.
|
||||||
-- XXX in the future, make a way to build these and just start the base
|
-- 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
|
missingDevices = S.filter (not . deviceOK) capDevices
|
||||||
|
|
||||||
-- Make sure we're not missing any required devices.
|
-- 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:"
|
`holdsOrFail` [ "this would require installing devices you don't have:"
|
||||||
, commaList (map (^. entityName) (S.toList missingDevices))
|
, commaList (map (^. entityName) (S.toList missingDevices))
|
||||||
]
|
]
|
||||||
@ -1105,7 +1162,9 @@ execConst c vs s k = do
|
|||||||
mkRobot
|
mkRobot
|
||||||
name
|
name
|
||||||
(r ^. robotLocation)
|
(r ^. robotLocation)
|
||||||
(r ^. robotOrientation ? east)
|
( ((r ^. robotOrientation) >>= \dir -> guard (dir /= zero) >> return dir)
|
||||||
|
? east
|
||||||
|
)
|
||||||
(In cmd e s [FExec])
|
(In cmd e s [FExec])
|
||||||
(S.toList devices)
|
(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,
|
-- Remove from the inventory any devices which were installed on the new robot,
|
||||||
-- if not in creative mode.
|
-- if not in creative mode.
|
||||||
unless (mode == Creative) $
|
unless creative $
|
||||||
forM_ (devices `S.difference` stdDevices) $ \d ->
|
forM_ (devices `S.difference` stdDevices) $ \d ->
|
||||||
robotInventory %= delete d
|
robotInventory %= delete d
|
||||||
|
|
||||||
@ -1140,11 +1199,11 @@ execConst c vs s k = do
|
|||||||
-- Also copy over its log, if we have one
|
-- Also copy over its log, if we have one
|
||||||
inst <- use installedDevices
|
inst <- use installedDevices
|
||||||
em <- use entityMap
|
em <- use entityMap
|
||||||
mode <- use gameMode
|
creative <- use creativeMode
|
||||||
logger <-
|
logger <-
|
||||||
lookupEntityName "logger" em
|
lookupEntityName "logger" em
|
||||||
`isJustOr` Fatal "While executing 'salvage': there's no such thing as a logger!?"
|
`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
|
-- Finally, delete the salvaged robot
|
||||||
deleteRobot (target ^. robotName)
|
deleteRobot (target ^. robotName)
|
||||||
|
@ -1,9 +1,6 @@
|
|||||||
{-# LANGUAGE MagicHash #-}
|
{-# LANGUAGE MagicHash #-}
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
{-# LANGUAGE TypeApplications #-}
|
||||||
-----------------------------------------------------------------------------
|
|
||||||
|
|
||||||
-----------------------------------------------------------------------------
|
|
||||||
|
|
||||||
-- |
|
-- |
|
||||||
-- Module : Swarm.Game.Terrain
|
-- Module : Swarm.Game.Terrain
|
||||||
@ -21,8 +18,12 @@ module Swarm.Game.Terrain (
|
|||||||
) where
|
) where
|
||||||
|
|
||||||
import Brick (Widget)
|
import Brick (Widget)
|
||||||
|
import Data.Aeson (FromJSON (..), withText)
|
||||||
import Data.Map (Map, (!))
|
import Data.Map (Map, (!))
|
||||||
import qualified Data.Map as M
|
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.Game.Display
|
||||||
import Swarm.TUI.Attr
|
import Swarm.TUI.Attr
|
||||||
@ -34,8 +35,15 @@ data TerrainType
|
|||||||
| DirtT
|
| DirtT
|
||||||
| GrassT
|
| GrassT
|
||||||
| IceT
|
| IceT
|
||||||
|
| BlankT
|
||||||
deriving (Eq, Ord, Show, Read, Bounded, Enum)
|
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.
|
-- | Display a terrain type as a single charcter widget.
|
||||||
displayTerrain :: TerrainType -> Widget n
|
displayTerrain :: TerrainType -> Widget n
|
||||||
displayTerrain t = displayWidget Nothing (terrainMap ! t)
|
displayTerrain t = displayWidget Nothing (terrainMap ! t)
|
||||||
@ -48,4 +56,5 @@ terrainMap =
|
|||||||
, (DirtT, defaultTerrainDisplay '░' dirtAttr)
|
, (DirtT, defaultTerrainDisplay '░' dirtAttr)
|
||||||
, (GrassT, defaultTerrainDisplay '░' grassAttr)
|
, (GrassT, defaultTerrainDisplay '░' grassAttr)
|
||||||
, (IceT, defaultTerrainDisplay ' ' iceAttr)
|
, (IceT, defaultTerrainDisplay ' ' iceAttr)
|
||||||
|
, (BlankT, defaultTerrainDisplay ' ' defAttr)
|
||||||
]
|
]
|
||||||
|
@ -1,5 +1,3 @@
|
|||||||
-----------------------------------------------------------------------------
|
|
||||||
-----------------------------------------------------------------------------
|
|
||||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
@ -34,6 +32,7 @@ module Swarm.Game.World (
|
|||||||
|
|
||||||
-- * Worlds
|
-- * Worlds
|
||||||
WorldFun,
|
WorldFun,
|
||||||
|
worldFunFromArray,
|
||||||
World,
|
World,
|
||||||
|
|
||||||
-- ** Tile management
|
-- ** Tile management
|
||||||
@ -90,15 +89,27 @@ locToCoords (V2 x y) = Coords (- y, x)
|
|||||||
coordsToLoc :: Coords -> V2 Int64
|
coordsToLoc :: Coords -> V2 Int64
|
||||||
coordsToLoc (Coords (r, c)) = V2 c (- r)
|
coordsToLoc (Coords (r, c)) = V2 c (- r)
|
||||||
|
|
||||||
|
------------------------------------------------------------
|
||||||
|
-- World function
|
||||||
|
------------------------------------------------------------
|
||||||
|
|
||||||
-- | A @WorldFun t e@ represents a 2D world with terrain of type @t@
|
-- | 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
|
-- (exactly one per cell) and entities of type @e@ (at most one per
|
||||||
-- cell).
|
-- cell).
|
||||||
type WorldFun t e = Coords -> (t, Maybe e)
|
type WorldFun t e = Coords -> (t, Maybe e)
|
||||||
|
|
||||||
-- XXX Allow smaller, finite worlds Too? Maybe add a variant of
|
-- | Create a world function from a finite array of specified cells
|
||||||
-- newWorld that creates a finite world from an array. This could
|
-- plus a single default cell to use everywhere else.
|
||||||
-- be used e.g. to create puzzle levels, which can be loaded from a
|
worldFunFromArray :: Array (Int64, Int64) (t, Maybe e) -> (t, Maybe e) -> WorldFun t e
|
||||||
-- file instead of generated via noise functions.
|
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 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
|
-- 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 Numeric.Noise.Ridged
|
||||||
import Witch
|
import Witch
|
||||||
|
|
||||||
|
import Data.Array.IArray
|
||||||
import Swarm.Game.Terrain
|
import Swarm.Game.Terrain
|
||||||
import Swarm.Game.World
|
import Swarm.Game.World
|
||||||
|
|
||||||
@ -103,6 +104,16 @@ testWorld2 baseSeed (Coords ix@(r, c)) =
|
|||||||
|
|
||||||
cl0 = clumps 0
|
cl0 = clumps 0
|
||||||
|
|
||||||
|
-- | Create a world function from a finite array of specified cells
|
||||||
|
-- plus a seed to randomly generate the rest.
|
||||||
|
testWorld2FromArray :: Array (Int64, Int64) (TerrainType, Maybe Text) -> Seed -> WorldFun TerrainType Text
|
||||||
|
testWorld2FromArray arr seed co@(Coords (r, c))
|
||||||
|
| inRange bnds (r, c) = arr ! (r, c)
|
||||||
|
| otherwise = tw2 co
|
||||||
|
where
|
||||||
|
tw2 = testWorld2 seed
|
||||||
|
bnds = bounds arr
|
||||||
|
|
||||||
-- | Offset the world so the base starts on empty spot next to tree and grass.
|
-- | Offset the world so the base starts on empty spot next to tree and grass.
|
||||||
findGoodOrigin :: WorldFun t Text -> WorldFun t Text
|
findGoodOrigin :: WorldFun t Text -> WorldFun t Text
|
||||||
findGoodOrigin f = \(Coords (r, c)) -> f (Coords (r + rOffset, c + cOffset))
|
findGoodOrigin f = \(Coords (r, c)) -> f (Coords (r + rOffset, c + cOffset))
|
||||||
|
@ -99,6 +99,10 @@ data Capability
|
|||||||
CReprogram
|
CReprogram
|
||||||
| -- | Capability to introspect and see it's own name
|
| -- | Capability to introspect and see it's own name
|
||||||
CWhoami
|
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)
|
deriving (Eq, Ord, Show, Read, Enum, Bounded, Generic, Hashable, Data)
|
||||||
|
|
||||||
instance ToJSON Capability where
|
instance ToJSON Capability where
|
||||||
@ -254,6 +258,8 @@ constCaps =
|
|||||||
Salvage -> [CSalvage]
|
Salvage -> [CSalvage]
|
||||||
Reprogram -> [CReprogram]
|
Reprogram -> [CReprogram]
|
||||||
Drill -> [CDrill]
|
Drill -> [CDrill]
|
||||||
|
-- Some God-like sensing abilities.
|
||||||
|
As -> [CGod]
|
||||||
-- String operations, which for now are enabled by CLog
|
-- String operations, which for now are enabled by CLog
|
||||||
Format -> [CLog]
|
Format -> [CLog]
|
||||||
Concat -> [CLog]
|
Concat -> [CLog]
|
||||||
|
@ -27,6 +27,7 @@ import Data.Bifunctor (first)
|
|||||||
import Data.Data (Data)
|
import Data.Data (Data)
|
||||||
import Data.Set (Set)
|
import Data.Set (Set)
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
|
import Data.Yaml as Y
|
||||||
import Witch
|
import Witch
|
||||||
|
|
||||||
import Swarm.Language.Capability
|
import Swarm.Language.Capability
|
||||||
@ -50,7 +51,16 @@ data ProcessedTerm
|
|||||||
-- ^ Capabilities required by the term
|
-- ^ Capabilities required by the term
|
||||||
CapCtx
|
CapCtx
|
||||||
-- ^ Capability context for any definitions embedded in the term
|
-- ^ 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,
|
-- | Given a 'Text' value representing a Swarm program,
|
||||||
--
|
--
|
||||||
|
@ -327,6 +327,10 @@ data Const
|
|||||||
-- | Application operator - helps to avoid parentheses:
|
-- | Application operator - helps to avoid parentheses:
|
||||||
-- @f $ g $ h x = f (g (h x))@
|
-- @f $ g $ h x = f (g (h x))@
|
||||||
AppF
|
AppF
|
||||||
|
| -- God-like sensing operations
|
||||||
|
|
||||||
|
-- | Run a command as if you were another robot.
|
||||||
|
As
|
||||||
deriving (Eq, Ord, Enum, Bounded, Data, Show)
|
deriving (Eq, Ord, Enum, Bounded, Data, Show)
|
||||||
|
|
||||||
allConst :: [Const]
|
allConst :: [Const]
|
||||||
@ -455,6 +459,7 @@ constInfo c = case c of
|
|||||||
Format -> functionLow 1
|
Format -> functionLow 1
|
||||||
Concat -> binaryOp "++" 6 R
|
Concat -> binaryOp "++" 6 R
|
||||||
AppF -> binaryOp "$" 0 R
|
AppF -> binaryOp "$" 0 R
|
||||||
|
As -> commandLow 2
|
||||||
where
|
where
|
||||||
unaryOp s p side = ConstInfo {syntax = s, fixity = p, constMeta = ConstMUnOp side}
|
unaryOp s p side = ConstInfo {syntax = s, fixity = p, constMeta = ConstMUnOp side}
|
||||||
binaryOp s p side = ConstInfo {syntax = s, fixity = p, constMeta = ConstMBinOp 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 |]
|
Format -> [tyQ| a -> string |]
|
||||||
Concat -> [tyQ| string -> string -> string |]
|
Concat -> [tyQ| string -> string -> string |]
|
||||||
AppF -> [tyQ| (a -> b) -> a -> b |]
|
AppF -> [tyQ| (a -> b) -> a -> b |]
|
||||||
|
As -> [tyQ| string -> {cmd a} -> cmd a |]
|
||||||
where
|
where
|
||||||
cmpBinT = [tyQ| a -> a -> bool |]
|
cmpBinT = [tyQ| a -> a -> bool |]
|
||||||
arithBinT = [tyQ| int -> int -> int |]
|
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.KBackTab [])) = continue $ s & uiState . uiFocusRing %~ focusPrev
|
||||||
handleEvent s (VtyEvent (V.EvKey V.KEsc []))
|
handleEvent s (VtyEvent (V.EvKey V.KEsc []))
|
||||||
| isJust (s ^. uiState . uiError) = continue $ s & uiState . uiError .~ Nothing
|
| isJust (s ^. uiState . uiError) = continue $ s & uiState . uiError .~ Nothing
|
||||||
|
| isJust (s ^. uiState . uiModal) = continue $ s & uiState . uiModal .~ Nothing
|
||||||
handleEvent s ev = do
|
handleEvent s ev = do
|
||||||
-- intercept special keys that works on all panels
|
-- intercept special keys that works on all panels
|
||||||
case ev of
|
case ev of
|
||||||
@ -365,7 +366,18 @@ updateUI = do
|
|||||||
oldBotMore <- uiState . uiMoreInfoBot <<.= botMore
|
oldBotMore <- uiState . uiMoreInfoBot <<.= botMore
|
||||||
return $ oldTopMore /= topMore || oldBotMore /= 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
|
pure redraw
|
||||||
|
|
||||||
-- | Make sure all tiles covering the visible part of the world are
|
-- | 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)
|
handleWorldEvent :: AppState -> BrickEvent Name AppEvent -> EventM Name (Next AppState)
|
||||||
-- scrolling the world view in Creative mode
|
-- scrolling the world view in Creative mode
|
||||||
handleWorldEvent s (VtyEvent (V.EvKey k []))
|
handleWorldEvent s (VtyEvent (V.EvKey k []))
|
||||||
| (s ^. gameState . gameMode) == Creative
|
| s ^. gameState . creativeMode
|
||||||
&& k
|
&& k
|
||||||
`elem` [ V.KUp
|
`elem` [ V.KUp
|
||||||
, V.KDown
|
, V.KDown
|
||||||
@ -521,7 +533,7 @@ handleWorldEvent s (VtyEvent (V.EvKey (V.KChar 'f') [])) =
|
|||||||
continue $ (s & uiState . uiShowFPS %~ not)
|
continue $ (s & uiState . uiShowFPS %~ not)
|
||||||
-- for testing only: toggle between classic & creative modes
|
-- for testing only: toggle between classic & creative modes
|
||||||
handleWorldEvent s (VtyEvent (V.EvKey (V.KChar 'm') [])) =
|
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.
|
-- Fall-through case: don't do anything.
|
||||||
handleWorldEvent s _ = continueWithoutRedraw s
|
handleWorldEvent s _ = continueWithoutRedraw s
|
||||||
|
|
||||||
|
@ -91,30 +91,36 @@ module Swarm.TUI.Model (
|
|||||||
Seed,
|
Seed,
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Lens
|
import Control.Lens hiding (from, (<.>))
|
||||||
import Control.Monad.Except
|
import Control.Monad.Except
|
||||||
import Control.Monad.State
|
import Control.Monad.State
|
||||||
import Data.Bits (FiniteBits (finiteBitSize))
|
import Data.Bits (FiniteBits (finiteBitSize))
|
||||||
import Data.Foldable (toList)
|
import Data.Foldable (toList)
|
||||||
import Data.List (findIndex, sortOn)
|
import Data.List (findIndex, sortOn)
|
||||||
import Data.Maybe (fromMaybe, isJust)
|
import Data.Maybe (fromMaybe, isJust, listToMaybe)
|
||||||
import Data.Sequence (Seq)
|
import Data.Sequence (Seq)
|
||||||
import qualified Data.Sequence as Seq
|
import qualified Data.Sequence as Seq
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import qualified Data.Vector as V
|
import qualified Data.Vector as V
|
||||||
|
import Data.Yaml (prettyPrintParseException)
|
||||||
import System.Clock
|
import System.Clock
|
||||||
|
import System.Directory (doesFileExist)
|
||||||
|
import System.FilePath ((<.>), (</>))
|
||||||
|
import Witch (from)
|
||||||
|
|
||||||
import Brick
|
import Brick
|
||||||
import Brick.Focus
|
import Brick.Focus
|
||||||
import Brick.Forms
|
import Brick.Forms
|
||||||
import qualified Brick.Widgets.List as BL
|
import qualified Brick.Widgets.List as BL
|
||||||
|
|
||||||
|
import Paths_swarm (getDataFileName)
|
||||||
import Swarm.Game.Entity as E
|
import Swarm.Game.Entity as E
|
||||||
import Swarm.Game.Robot
|
import Swarm.Game.Robot
|
||||||
import Swarm.Game.State
|
import Swarm.Game.State
|
||||||
import Swarm.Language.Types
|
import Swarm.Language.Types
|
||||||
import Swarm.Util
|
import Swarm.Util
|
||||||
|
import Swarm.Util.Yaml
|
||||||
|
|
||||||
------------------------------------------------------------
|
------------------------------------------------------------
|
||||||
-- Custom UI label types
|
-- Custom UI label types
|
||||||
@ -276,6 +282,7 @@ replIndexIsAtInput repl = repl ^. replIndex == replLength repl
|
|||||||
|
|
||||||
data Modal
|
data Modal
|
||||||
= HelpModal
|
= HelpModal
|
||||||
|
| WinModal
|
||||||
deriving (Eq, Show)
|
deriving (Eq, Show)
|
||||||
|
|
||||||
-- | An entry in the inventory list displayed in the info panel. We
|
-- | An entry in the inventory list displayed in the info panel. We
|
||||||
@ -538,8 +545,26 @@ gameState :: Lens' AppState GameState
|
|||||||
uiState :: Lens' AppState UIState
|
uiState :: Lens' AppState UIState
|
||||||
|
|
||||||
-- | Initialize the 'AppState'.
|
-- | Initialize the 'AppState'.
|
||||||
initAppState :: Seed -> ExceptT Text IO AppState
|
initAppState :: Seed -> Maybe String -> ExceptT Text IO AppState
|
||||||
initAppState seed = AppState <$> initGameState seed <*> initUIState
|
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
|
WorldPanel
|
||||||
(plainBorder & bottomLabels . rightLabel ?~ padLeftRight 1 (drawTPS s))
|
(plainBorder & bottomLabels . rightLabel ?~ padLeftRight 1 (drawTPS s))
|
||||||
(drawWorld $ s ^. gameState)
|
(drawWorld $ s ^. gameState)
|
||||||
, drawMenu
|
, drawMenu s
|
||||||
(s ^. gameState . replWorking)
|
|
||||||
(s ^. gameState . paused)
|
|
||||||
((s ^. gameState . viewCenterRule) == VCRobot "base")
|
|
||||||
(s ^. gameState . gameMode)
|
|
||||||
(s ^. uiState)
|
|
||||||
, panel
|
, panel
|
||||||
highlightAttr
|
highlightAttr
|
||||||
fr
|
fr
|
||||||
@ -195,6 +190,7 @@ renderModal modal = renderDialog (dialog (Just modalTitle) Nothing maxModalWindo
|
|||||||
(modalTitle, modalContent) =
|
(modalTitle, modalContent) =
|
||||||
case modal of
|
case modal of
|
||||||
HelpModal -> ("Help", helpWidget)
|
HelpModal -> ("Help", helpWidget)
|
||||||
|
WinModal -> ("", txt "Congratulations!")
|
||||||
|
|
||||||
helpWidget :: Widget Name
|
helpWidget :: Widget Name
|
||||||
helpWidget = (helpKeys <=> fill ' ') <+> (helpCommands <=> fill ' ')
|
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
|
-- | Draw a menu explaining what key commands are available for the
|
||||||
-- current panel. This menu is displayed as a single line in
|
-- current panel. This menu is displayed as a single line in
|
||||||
-- between the world panel and the REPL.
|
-- between the world panel and the REPL.
|
||||||
drawMenu :: Bool -> Bool -> Bool -> GameMode -> UIState -> Widget Name
|
drawMenu :: AppState -> Widget Name
|
||||||
drawMenu isReplWorking isPaused viewingBase mode =
|
drawMenu s =
|
||||||
vLimit 1
|
vLimit 1
|
||||||
. hBox
|
. hBox
|
||||||
. (++ [gameModeWidget])
|
. (++ [gameModeWidget])
|
||||||
@ -248,15 +244,21 @@ drawMenu isReplWorking isPaused viewingBase mode =
|
|||||||
. (globalKeyCmds ++)
|
. (globalKeyCmds ++)
|
||||||
. keyCmdsFor
|
. keyCmdsFor
|
||||||
. focusGetCurrent
|
. focusGetCurrent
|
||||||
. view uiFocusRing
|
. view (uiState . uiFocusRing)
|
||||||
|
$ s
|
||||||
where
|
where
|
||||||
|
isReplWorking = s ^. gameState . replWorking
|
||||||
|
isPaused = s ^. gameState . paused
|
||||||
|
viewingBase = (s ^. gameState . viewCenterRule) == VCRobot "base"
|
||||||
|
creative = s ^. gameState . creativeMode
|
||||||
|
|
||||||
gameModeWidget =
|
gameModeWidget =
|
||||||
padLeft Max . padLeftRight 1
|
padLeft Max . padLeftRight 1
|
||||||
. txt
|
. txt
|
||||||
. (<> " mode")
|
. (<> " mode")
|
||||||
$ case mode of
|
$ case creative of
|
||||||
Classic -> "Classic"
|
False -> "Classic"
|
||||||
Creative -> "Creative"
|
True -> "Creative"
|
||||||
globalKeyCmds =
|
globalKeyCmds =
|
||||||
[ ("F1", "help")
|
[ ("F1", "help")
|
||||||
, ("Tab", "cycle panels")
|
, ("Tab", "cycle panels")
|
||||||
@ -267,7 +269,7 @@ drawMenu isReplWorking isPaused viewingBase mode =
|
|||||||
++ [("Enter", "execute") | not isReplWorking]
|
++ [("Enter", "execute") | not isReplWorking]
|
||||||
++ [("^c", "cancel") | isReplWorking]
|
++ [("^c", "cancel") | isReplWorking]
|
||||||
keyCmdsFor (Just WorldPanel) =
|
keyCmdsFor (Just WorldPanel) =
|
||||||
[ ("←↓↑→ / hjkl", "scroll") | mode == Creative
|
[ ("←↓↑→ / hjkl", "scroll") | creative
|
||||||
]
|
]
|
||||||
++ [ ("<>", "slower/faster")
|
++ [ ("<>", "slower/faster")
|
||||||
, ("p", if isPaused then "unpause" else "pause")
|
, ("p", if isPaused then "unpause" else "pause")
|
||||||
@ -320,7 +322,7 @@ drawWorld g =
|
|||||||
drawLoc coords =
|
drawLoc coords =
|
||||||
let (ePrio, eWidget) = drawCell hiding (g ^. world) coords
|
let (ePrio, eWidget) = drawCell hiding (g ^. world) coords
|
||||||
hiding =
|
hiding =
|
||||||
if g ^. gameMode == Creative
|
if g ^. creativeMode
|
||||||
then HideNoEntity
|
then HideNoEntity
|
||||||
else maybe HideAllEntities HideEntityUnknownTo $ focusedRobot g
|
else maybe HideAllEntities HideEntityUnknownTo $ focusedRobot g
|
||||||
in case M.lookup (W.coordsToLoc coords) robotsByLoc of
|
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)
|
, displayEntity (hide e)
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
known e = case edr of
|
known e =
|
||||||
HideAllEntities -> False
|
e `hasProperty` Known
|
||||||
HideNoEntity -> True
|
|| case edr of
|
||||||
HideEntityUnknownTo ro -> ro `robotKnows` e
|
HideAllEntities -> False
|
||||||
|
HideNoEntity -> True
|
||||||
|
HideEntityUnknownTo ro -> ro `robotKnows` e
|
||||||
hide e = (if known e then id else entityDisplay . defaultChar %~ const '?') 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
|
extra-source-files: CHANGELOG.md
|
||||||
example/*.sw
|
example/*.sw
|
||||||
data-dir: data/
|
data-dir: data/
|
||||||
data-files: *.yaml
|
data-files: *.yaml, challenges/*.yaml
|
||||||
|
|
||||||
source-repository head
|
source-repository head
|
||||||
type: git
|
type: git
|
||||||
@ -65,6 +65,7 @@ library
|
|||||||
Swarm.Language.Pipeline
|
Swarm.Language.Pipeline
|
||||||
Swarm.Language.Pipeline.QQ
|
Swarm.Language.Pipeline.QQ
|
||||||
Swarm.Game.CESK
|
Swarm.Game.CESK
|
||||||
|
Swarm.Game.Challenge
|
||||||
Swarm.Game.Display
|
Swarm.Game.Display
|
||||||
Swarm.Game.Entity
|
Swarm.Game.Entity
|
||||||
Swarm.Game.Exception
|
Swarm.Game.Exception
|
||||||
@ -85,6 +86,7 @@ library
|
|||||||
Swarm.TUI.Controller
|
Swarm.TUI.Controller
|
||||||
Swarm.App
|
Swarm.App
|
||||||
Swarm.Util
|
Swarm.Util
|
||||||
|
Swarm.Util.Yaml
|
||||||
other-modules: Paths_swarm
|
other-modules: Paths_swarm
|
||||||
autogen-modules: Paths_swarm
|
autogen-modules: Paths_swarm
|
||||||
|
|
||||||
@ -176,6 +178,7 @@ test-suite swarm-integration
|
|||||||
lens,
|
lens,
|
||||||
swarm,
|
swarm,
|
||||||
text,
|
text,
|
||||||
|
yaml,
|
||||||
witch
|
witch
|
||||||
hs-source-dirs: test
|
hs-source-dirs: test
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
|
@ -7,34 +7,59 @@ module Main where
|
|||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Data.Functor
|
import Data.Functor
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
|
import Data.Yaml (ParseException, prettyPrintParseException)
|
||||||
import System.Directory (doesFileExist, listDirectory)
|
import System.Directory (doesFileExist, listDirectory)
|
||||||
import System.FilePath.Posix
|
import System.FilePath.Posix
|
||||||
import Test.Tasty
|
import Test.Tasty
|
||||||
import Test.Tasty.HUnit
|
import Test.Tasty.HUnit
|
||||||
import Witch
|
import Witch
|
||||||
|
|
||||||
|
import Swarm.Game.Challenge
|
||||||
|
import Swarm.Game.Entity
|
||||||
import Swarm.Language.Pipeline (processTerm)
|
import Swarm.Language.Pipeline (processTerm)
|
||||||
|
import Swarm.Util.Yaml (decodeFileEitherE)
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = do
|
main = do
|
||||||
paths <- acquire
|
examplePaths <- acquire "example" "sw"
|
||||||
defaultMain . exampleTests $ paths
|
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 :: [(FilePath, String)] -> TestTree
|
||||||
exampleTests inputs = testGroup "Test example" (map exampleTest inputs)
|
exampleTests inputs = testGroup "Test example" (map exampleTest inputs)
|
||||||
|
|
||||||
exampleTest :: (FilePath, String) -> TestTree
|
exampleTest :: (FilePath, String) -> TestTree
|
||||||
exampleTest (path, fileContent) = do
|
exampleTest (path, fileContent) =
|
||||||
testCaseSteps ("processTerm for contents of " ++ show path) $ \_ -> do
|
testCase ("processTerm for contents of " ++ show path) $ do
|
||||||
either (assertFailure . into @String) (const . return $ ()) value
|
either (assertFailure . into @String) (const . return $ ()) value
|
||||||
where
|
where
|
||||||
value = processTerm $ into @Text fileContent
|
value = processTerm $ into @Text fileContent
|
||||||
|
|
||||||
acquire :: IO [(FilePath, String)]
|
challengeTests :: EntityMap -> [(FilePath, String)] -> TestTree
|
||||||
acquire = do
|
challengeTests em inputs = testGroup "Test challenges" (map (challengeTest em) inputs)
|
||||||
paths <- listDirectory exampleDirectory <&> map (exampleDirectory </>)
|
|
||||||
filePaths <- filterM (\path -> doesFileExist path <&> (&&) (swExtension path)) paths
|
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
|
mapM (\path -> (,) path <$> readFile path) filePaths
|
||||||
where
|
where
|
||||||
exampleDirectory = "example"
|
hasExt path = takeExtension path == ("." ++ ext)
|
||||||
swExtension path = takeExtension path == ".sw"
|
|
||||||
|
@ -25,7 +25,7 @@ import Swarm.Game.Entity qualified as E
|
|||||||
import Swarm.Game.Exception
|
import Swarm.Game.Exception
|
||||||
import Swarm.Game.Robot
|
import Swarm.Game.Robot
|
||||||
import Swarm.Game.State
|
import Swarm.Game.State
|
||||||
import Swarm.Game.Step
|
import Swarm.Game.Step (stepCESK)
|
||||||
import Swarm.Game.Value
|
import Swarm.Game.Value
|
||||||
import Swarm.Language.Context
|
import Swarm.Language.Context
|
||||||
import Swarm.Language.Pipeline (ProcessedTerm (..), processTerm)
|
import Swarm.Language.Pipeline (ProcessedTerm (..), processTerm)
|
||||||
@ -35,7 +35,7 @@ import Swarm.TUI.Model
|
|||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = do
|
main = do
|
||||||
mg <- runExceptT (initGameState 0)
|
mg <- runExceptT (initGameState (ClassicGame 0))
|
||||||
case mg of
|
case mg of
|
||||||
Left err -> assertFailure (from err)
|
Left err -> assertFailure (from err)
|
||||||
Right g -> defaultMain (tests g)
|
Right g -> defaultMain (tests g)
|
||||||
@ -471,7 +471,7 @@ eval g =
|
|||||||
evalPT t = evaluateCESK (initMachine t empty emptyStore)
|
evalPT t = evaluateCESK (initMachine t empty emptyStore)
|
||||||
|
|
||||||
evaluateCESK :: CESK -> IO (Either Text (Value, Int))
|
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
|
where
|
||||||
r = mkRobot "" zero zero cesk []
|
r = mkRobot "" zero zero cesk []
|
||||||
|
|
||||||
|
Loading…
Reference in New Issue
Block a user