From b1f0e316fd4027538c1eb528f1b0d9bcd62f03c7 Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Thu, 27 Jan 2022 17:00:00 -0600 Subject: [PATCH] Challenge mode (#285) Add a "challenge mode" where the player tries to achieve some specified goal from specific starting conditions. --- .mergify.yml | 10 +- app/Main.hs | 10 +- bench/Benchmark.hs | 6 +- data/challenges/move.yaml | 41 ++++++++ data/challenges/move2.yaml | 51 ++++++++++ data/challenges/w0.yaml | 42 ++++++++ data/entities.yaml | 52 ++++++++++ src/Swarm/App.hs | 6 +- src/Swarm/Game/Challenge.hs | 164 +++++++++++++++++++++++++++++++ src/Swarm/Game/Entity.hs | 30 +++++- src/Swarm/Game/Robot.hs | 64 ++++++++++++ src/Swarm/Game/State.hs | 124 ++++++++++++++++------- src/Swarm/Game/Step.hs | 91 ++++++++++++++--- src/Swarm/Game/Terrain.hs | 17 +++- src/Swarm/Game/World.hs | 23 +++-- src/Swarm/Game/WorldGen.hs | 11 +++ src/Swarm/Language/Capability.hs | 6 ++ src/Swarm/Language/Pipeline.hs | 12 ++- src/Swarm/Language/Syntax.hs | 5 + src/Swarm/Language/Typecheck.hs | 1 + src/Swarm/TUI/Controller.hs | 18 +++- src/Swarm/TUI/Model.hs | 37 +++++-- src/Swarm/TUI/View.hs | 40 ++++---- src/Swarm/Util/Yaml.hs | 152 ++++++++++++++++++++++++++++ swarm.cabal | 5 +- test/Integration.hs | 45 +++++++-- test/Unit.hs | 6 +- 27 files changed, 952 insertions(+), 117 deletions(-) create mode 100644 data/challenges/move.yaml create mode 100644 data/challenges/move2.yaml create mode 100644 data/challenges/w0.yaml create mode 100644 src/Swarm/Game/Challenge.hs create mode 100644 src/Swarm/Util/Yaml.hs diff --git a/.mergify.yml b/.mergify.yml index e846128d..cdb6777b 100644 --- a/.mergify.yml +++ b/.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 diff --git a/app/Main.hs b/app/Main.hs index 491d7235..f4c11c37 100644 --- a/app/Main.hs +++ b/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 diff --git a/bench/Benchmark.hs b/bench/Benchmark.hs index cc92e8d3..31da5ee0 100644 --- a/bench/Benchmark.hs +++ b/bench/Benchmark.hs @@ -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)) ) diff --git a/data/challenges/move.yaml b/data/challenges/move.yaml new file mode 100644 index 00000000..adf3bd54 --- /dev/null +++ b/data/challenges/move.yaml @@ -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: | + ┌───┐ + │...│ + └───┘ diff --git a/data/challenges/move2.yaml b/data/challenges/move2.yaml new file mode 100644 index 00000000..a161e365 --- /dev/null +++ b/data/challenges/move2.yaml @@ -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: | + ┌────┐ + │...*│ + │....│ + └────┘ diff --git a/data/challenges/w0.yaml b/data/challenges/w0.yaml new file mode 100644 index 00000000..b5d544cd --- /dev/null +++ b/data/challenges/w0.yaml @@ -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: | + ┌───┐ + │...│ + └───┘ \ No newline at end of file diff --git a/data/entities.yaml b/data/entities.yaml index 064258d0..4d8d2746 100644 --- a/data/entities.yaml +++ b/data/entities.yaml @@ -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 ################################################ ############################################################ diff --git a/src/Swarm/App.hs b/src/Swarm/App.hs index 88904570..4b9f779b 100644 --- a/src/Swarm/App.hs +++ b/src/Swarm/App.hs @@ -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 diff --git a/src/Swarm/Game/Challenge.hs b/src/Swarm/Game/Challenge.hs new file mode 100644 index 00000000..7636f5d1 --- /dev/null +++ b/src/Swarm/Game/Challenge.hs @@ -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 diff --git a/src/Swarm/Game/Entity.hs b/src/Swarm/Game/Entity.hs index 2e6c91ab..84235537 100644 --- a/src/Swarm/Game/Entity.hs +++ b/src/Swarm/Game/Entity.hs @@ -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. diff --git a/src/Swarm/Game/Robot.hs b/src/Swarm/Game/Robot.hs index 22ea6b42..a71b1a65 100644 --- a/src/Swarm/Game/Robot.hs +++ b/src/Swarm/Game/Robot.hs @@ -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 #-} diff --git a/src/Swarm/Game/State.hs b/src/Swarm/Game/State.hs index 69ad0a77..7df7a0b3 100644 --- a/src/Swarm/Game/State.hs +++ b/src/Swarm/Game/State.hs @@ -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 diff --git a/src/Swarm/Game/Step.hs b/src/Swarm/Game/Step.hs index 692595b0..1b8a3868 100644 --- a/src/Swarm/Game/Step.hs +++ b/src/Swarm/Game/Step.hs @@ -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) diff --git a/src/Swarm/Game/Terrain.hs b/src/Swarm/Game/Terrain.hs index 2f55bdb2..c0e735fb 100644 --- a/src/Swarm/Game/Terrain.hs +++ b/src/Swarm/Game/Terrain.hs @@ -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) ] diff --git a/src/Swarm/Game/World.hs b/src/Swarm/Game/World.hs index 8f0ab957..deb39e2e 100644 --- a/src/Swarm/Game/World.hs +++ b/src/Swarm/Game/World.hs @@ -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 diff --git a/src/Swarm/Game/WorldGen.hs b/src/Swarm/Game/WorldGen.hs index a1c2b2b1..114ffdbc 100644 --- a/src/Swarm/Game/WorldGen.hs +++ b/src/Swarm/Game/WorldGen.hs @@ -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)) diff --git a/src/Swarm/Language/Capability.hs b/src/Swarm/Language/Capability.hs index 57346c01..333d09d4 100644 --- a/src/Swarm/Language/Capability.hs +++ b/src/Swarm/Language/Capability.hs @@ -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] diff --git a/src/Swarm/Language/Pipeline.hs b/src/Swarm/Language/Pipeline.hs index afa7ef08..8db55979 100644 --- a/src/Swarm/Language/Pipeline.hs +++ b/src/Swarm/Language/Pipeline.hs @@ -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, -- diff --git a/src/Swarm/Language/Syntax.hs b/src/Swarm/Language/Syntax.hs index 7da22858..2379e0bc 100644 --- a/src/Swarm/Language/Syntax.hs +++ b/src/Swarm/Language/Syntax.hs @@ -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} diff --git a/src/Swarm/Language/Typecheck.hs b/src/Swarm/Language/Typecheck.hs index a719960b..022b6a63 100644 --- a/src/Swarm/Language/Typecheck.hs +++ b/src/Swarm/Language/Typecheck.hs @@ -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 |] diff --git a/src/Swarm/TUI/Controller.hs b/src/Swarm/TUI/Controller.hs index b8d33610..56d06d4b 100644 --- a/src/Swarm/TUI/Controller.hs +++ b/src/Swarm/TUI/Controller.hs @@ -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 diff --git a/src/Swarm/TUI/Model.hs b/src/Swarm/TUI/Model.hs index f8877955..60fcdc6b 100644 --- a/src/Swarm/TUI/Model.hs +++ b/src/Swarm/TUI/Model.hs @@ -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 diff --git a/src/Swarm/TUI/View.hs b/src/Swarm/TUI/View.hs index a5f644eb..d11772ac 100644 --- a/src/Swarm/TUI/View.hs +++ b/src/Swarm/TUI/View.hs @@ -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 ------------------------------------------------------------ diff --git a/src/Swarm/Util/Yaml.hs b/src/Swarm/Util/Yaml.hs new file mode 100644 index 00000000..f1fc3c93 --- /dev/null +++ b/src/Swarm/Util/Yaml.hs @@ -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 diff --git a/swarm.cabal b/swarm.cabal index c572607a..95e7847a 100644 --- a/swarm.cabal +++ b/swarm.cabal @@ -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 diff --git a/test/Integration.hs b/test/Integration.hs index eaecc668..57eb4923 100644 --- a/test/Integration.hs +++ b/test/Integration.hs @@ -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) diff --git a/test/Unit.hs b/test/Unit.hs index 1a449989..09ccd309 100644 --- a/test/Unit.hs +++ b/test/Unit.hs @@ -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 []