From 3d6285b09fe3ef02f051e9138598c6d838412aac Mon Sep 17 00:00:00 2001 From: Karl Ostmo Date: Sun, 18 Dec 2022 17:42:59 -0800 Subject: [PATCH] Boolean expressions of objective prerequisites Closes #795 --- .gitignore | 1 + .../Challenges/Ranching/gated-paddock.yaml | 8 + data/scenarios/Challenges/bucket-brigade.yaml | 4 + data/scenarios/Testing/00-ORDER.txt | 1 + data/scenarios/Testing/378-objectives.yaml | 4 + .../Testing/795-prerequisite/00-ORDER.txt | 4 + .../795-prerequisite-and.yaml | 50 +++ .../795-prerequisite-cycle-with-not.yaml | 46 +++ .../795-prerequisite-mutually-exclusive.yaml | 60 +++ .../795-prerequisite/795-prerequisite-or.yaml | 49 +++ .../_Validation/795-prerequisite-cycle.yaml | 42 ++ ...95-prerequisite-nonexistent-reference.yaml | 40 ++ .../795-prerequisite-self-reference.yaml | 33 ++ data/scenarios/Tutorials/bind2.yaml | 4 + data/scenarios/Tutorials/farming.yaml | 4 + data/scenarios/Tutorials/move.yaml | 12 + data/scenarios/Tutorials/world101.yaml | 8 + src/Data/BoolExpr.hs | 386 ++++++++++++++++++ src/Data/LICENSE | 30 ++ src/Swarm/Game/Display.hs | 1 + src/Swarm/Game/Entity.hs | 1 + src/Swarm/Game/Scenario.hs | 15 +- src/Swarm/Game/Scenario/Objective.hs | 142 ++++++- src/Swarm/Game/Scenario/Objective/Graph.hs | 140 +++++++ src/Swarm/Game/Scenario/Objective/Logic.hs | 41 ++ .../Scenario/Objective/Presentation/Model.hs | 99 +++++ .../Scenario/Objective/Presentation/Render.hs | 86 ++++ src/Swarm/Game/Scenario/Objective/Simplify.hs | 49 +++ .../Game/Scenario/Objective/Validation.hs | 47 +++ src/Swarm/Game/Scenario/Objective/WinCheck.hs | 82 ++++ src/Swarm/Game/ScenarioInfo.hs | 4 +- src/Swarm/Game/State.hs | 49 ++- src/Swarm/Game/Step.hs | 146 +++++-- src/Swarm/Game/World.hs | 1 + src/Swarm/Language/Capability.hs | 2 + src/Swarm/Language/Requirement.hs | 2 + src/Swarm/Language/Syntax.hs | 1 + src/Swarm/Language/Typed.hs | 1 + src/Swarm/Language/Types.hs | 1 + src/Swarm/TUI/Attr.hs | 5 +- src/Swarm/TUI/Controller.hs | 113 +++-- .../TUI/Model/Achievement/Definitions.hs | 10 +- src/Swarm/TUI/Model/Menu.hs | 3 +- src/Swarm/TUI/Model/Name.hs | 2 + src/Swarm/TUI/Model/StateUpdate.hs | 3 +- src/Swarm/TUI/Model/UI.hs | 8 +- src/Swarm/TUI/View.hs | 25 +- src/Swarm/TUI/View/Util.hs | 24 +- src/Swarm/Util.hs | 1 + src/Swarm/Util/Location.hs | 1 + src/Swarm/Web.hs | 35 ++ swarm.cabal | 12 +- test/integration/Main.hs | 25 +- test/unit/Main.hs | 2 + test/unit/TestBoolExpr.hs | 103 +++++ 55 files changed, 1954 insertions(+), 114 deletions(-) create mode 100644 data/scenarios/Testing/795-prerequisite/00-ORDER.txt create mode 100644 data/scenarios/Testing/795-prerequisite/795-prerequisite-and.yaml create mode 100644 data/scenarios/Testing/795-prerequisite/795-prerequisite-cycle-with-not.yaml create mode 100644 data/scenarios/Testing/795-prerequisite/795-prerequisite-mutually-exclusive.yaml create mode 100644 data/scenarios/Testing/795-prerequisite/795-prerequisite-or.yaml create mode 100644 data/scenarios/Testing/_Validation/795-prerequisite-cycle.yaml create mode 100644 data/scenarios/Testing/_Validation/795-prerequisite-nonexistent-reference.yaml create mode 100644 data/scenarios/Testing/_Validation/795-prerequisite-self-reference.yaml create mode 100644 src/Data/BoolExpr.hs create mode 100644 src/Data/LICENSE create mode 100644 src/Swarm/Game/Scenario/Objective/Graph.hs create mode 100644 src/Swarm/Game/Scenario/Objective/Logic.hs create mode 100644 src/Swarm/Game/Scenario/Objective/Presentation/Model.hs create mode 100644 src/Swarm/Game/Scenario/Objective/Presentation/Render.hs create mode 100644 src/Swarm/Game/Scenario/Objective/Simplify.hs create mode 100644 src/Swarm/Game/Scenario/Objective/Validation.hs create mode 100644 src/Swarm/Game/Scenario/Objective/WinCheck.hs create mode 100644 test/unit/TestBoolExpr.hs diff --git a/.gitignore b/.gitignore index c7160fccf1..cf7fb7f4f5 100644 --- a/.gitignore +++ b/.gitignore @@ -14,6 +14,7 @@ stan.html .swarm_history +*.orig *.aux *.log docs/ott/*.tex diff --git a/data/scenarios/Challenges/Ranching/gated-paddock.yaml b/data/scenarios/Challenges/Ranching/gated-paddock.yaml index b510485ce3..aa6d7e369e 100644 --- a/data/scenarios/Challenges/Ranching/gated-paddock.yaml +++ b/data/scenarios/Challenges/Ranching/gated-paddock.yaml @@ -274,6 +274,7 @@ objectives: } { return false; } + id: enclose_sheep - goal: - | Safe! Your sheep are now hungry. @@ -311,6 +312,10 @@ objectives: end; anySheep (has "clover") 3; + id: feed_sheep + prerequisite: + logic: + id: enclose_sheep - goal: - | Yum! Contented, well-fed sheep may drop wool. @@ -323,6 +328,9 @@ objectives: as base { has "sweater"; }; + prerequisite: + logic: + id: feed_sheep robots: - name: base dir: [0, 1] diff --git a/data/scenarios/Challenges/bucket-brigade.yaml b/data/scenarios/Challenges/bucket-brigade.yaml index 21ab88229b..f03a676be0 100644 --- a/data/scenarios/Challenges/bucket-brigade.yaml +++ b/data/scenarios/Challenges/bucket-brigade.yaml @@ -66,6 +66,7 @@ objectives: You'll have to make do... condition: | as base {has "coal lump"} + id: deliver_coal_lump - goal: - Your base got some coal! - Now fashion more of it into a "coal briquette", and place it @@ -75,6 +76,9 @@ objectives: condition: | hauler <- robotnamed "hauler"; as hauler {has "coal briquette"} + prerequisite: + logic: + id: deliver_coal_lump solution: | run "scenarios/Challenges/_bucket-brigade/brigade.sw" entities: diff --git a/data/scenarios/Testing/00-ORDER.txt b/data/scenarios/Testing/00-ORDER.txt index 1d4b48914c..6c5aa8e6fa 100644 --- a/data/scenarios/Testing/00-ORDER.txt +++ b/data/scenarios/Testing/00-ORDER.txt @@ -14,5 +14,6 @@ 684-swap.yaml 699-movement-fail 858-inventory +795-prerequisite 710-multi-robot.yaml 920-meet.yaml diff --git a/data/scenarios/Testing/378-objectives.yaml b/data/scenarios/Testing/378-objectives.yaml index 9601370bc8..d9efb04c14 100644 --- a/data/scenarios/Testing/378-objectives.yaml +++ b/data/scenarios/Testing/378-objectives.yaml @@ -10,10 +10,14 @@ objectives: n <- as base {count "tree"}; return (n >= 3) } { return false } + id: get_trees - goal: - Nice job. Now, build a harvester. condition: | try { as base {has "harvester"} } {return false} + prerequisite: + logic: + id: get_trees solution: | build {turn right; move; move; grab; move; grab; move; grab; turn back; move; move; move; move}; wait 16; diff --git a/data/scenarios/Testing/795-prerequisite/00-ORDER.txt b/data/scenarios/Testing/795-prerequisite/00-ORDER.txt new file mode 100644 index 0000000000..c26aa7b5e3 --- /dev/null +++ b/data/scenarios/Testing/795-prerequisite/00-ORDER.txt @@ -0,0 +1,4 @@ +795-prerequisite-or.yaml +795-prerequisite-and.yaml +795-prerequisite-mutually-exclusive.yaml +795-prerequisite-cycle-with-not.yaml \ No newline at end of file diff --git a/data/scenarios/Testing/795-prerequisite/795-prerequisite-and.yaml b/data/scenarios/Testing/795-prerequisite/795-prerequisite-and.yaml new file mode 100644 index 0000000000..975c720a0f --- /dev/null +++ b/data/scenarios/Testing/795-prerequisite/795-prerequisite-and.yaml @@ -0,0 +1,50 @@ +version: 1 +name: | + Prerequisite objectives: AND +description: | + Complete an objective with a prerequisite of either of two other objectives. +objectives: + - goal: + - Achieve both of two other objectives + condition: | + return true; + prerequisite: + previewable: true + logic: + and: + - id: have_furnace + - id: have_gear + - goal: + - Make a "furnace". + condition: | + as base {has "furnace"}; + id: have_furnace + optional: true + - goal: + - Make a "wooden gear". + condition: | + as base {has "wooden gear"}; + id: have_gear + optional: true +solution: | + make "furnace"; + make "wooden gear"; +robots: + - name: base + display: + char: 'Ω' + attr: robot + dir: [0, 1] + devices: + - workbench + - grabber + inventory: + - [2, board] + - [5, rock] +world: + default: [blank] + palette: + 'x': [grass, null, base] + upperleft: [0, 0] + map: | + x diff --git a/data/scenarios/Testing/795-prerequisite/795-prerequisite-cycle-with-not.yaml b/data/scenarios/Testing/795-prerequisite/795-prerequisite-cycle-with-not.yaml new file mode 100644 index 0000000000..d384599de3 --- /dev/null +++ b/data/scenarios/Testing/795-prerequisite/795-prerequisite-cycle-with-not.yaml @@ -0,0 +1,46 @@ +version: 1 +name: | + Prerequisite objectives: non-dependency cycle due to the NOT +description: | + This should NOT be rejected by the parser. + The two objectives do reference each other, + but the NOT is a distinct reference from the non-negated goal. +objectives: + - goal: + - Make a "furnace". + condition: | + as base {has "furnace"}; + id: have_furnace + prerequisite: + logic: + not: + id: have_gear + - goal: + - Make a "wooden gear". + condition: | + as base {has "wooden gear"}; + id: have_gear + prerequisite: + logic: + id: have_furnace +solution: | + make "wooden gear"; + make "furnace"; +robots: + - name: base + display: + char: 'Ω' + attr: robot + dir: [0, 1] + devices: + - workbench + inventory: + - [2, board] + - [5, rock] +world: + default: [blank] + palette: + 'x': [grass, null, base] + upperleft: [0, 0] + map: | + x diff --git a/data/scenarios/Testing/795-prerequisite/795-prerequisite-mutually-exclusive.yaml b/data/scenarios/Testing/795-prerequisite/795-prerequisite-mutually-exclusive.yaml new file mode 100644 index 0000000000..513f9ce3b5 --- /dev/null +++ b/data/scenarios/Testing/795-prerequisite/795-prerequisite-mutually-exclusive.yaml @@ -0,0 +1,60 @@ +version: 1 +name: | + Prerequisite objectives: OR +description: | + Complete an objective with a prerequisite of either of two other objectives. +objectives: + - goal: + - Achieve one of two other objectives + condition: | + return true; + prerequisite: + previewable: true + logic: + or: + - and: + - id: have_furnace + - not: + id: have_flower + - and: + - id: have_gear + - id: have_flower + - goal: + - Make a "furnace". + condition: | + as base {has "furnace"}; + id: have_furnace + optional: true + - goal: + - Make a "wooden gear". + condition: | + as base {has "wooden gear"}; + id: have_gear + optional: true + - goal: + - Possess a "flower". + condition: | + as base {has "flower"}; + id: have_flower + optional: true +solution: | + make "furnace" +robots: + - name: base + display: + char: 'Ω' + attr: robot + dir: [0, 1] + devices: + - workbench + - grabber + inventory: + - [2, board] + - [5, rock] +world: + default: [blank] + palette: + 'x': [grass, flower, base] + upperleft: [0, 0] + map: | + x diff --git a/data/scenarios/Testing/795-prerequisite/795-prerequisite-or.yaml b/data/scenarios/Testing/795-prerequisite/795-prerequisite-or.yaml new file mode 100644 index 0000000000..84de25670f --- /dev/null +++ b/data/scenarios/Testing/795-prerequisite/795-prerequisite-or.yaml @@ -0,0 +1,49 @@ +version: 1 +name: | + Prerequisite objectives: OR +description: | + Complete an objective with a prerequisite of either of two other objectives. +objectives: + - goal: + - Achieve one of two other objectives + condition: | + return true; + prerequisite: + previewable: true + logic: + or: + - id: have_furnace + - id: have_gear + - goal: + - Make a "furnace". + condition: | + as base {has "furnace"}; + id: have_furnace + optional: true + - goal: + - Make a "wooden gear". + condition: | + as base {has "wooden gear"}; + id: have_gear + optional: true +solution: | + make "wooden gear" +robots: + - name: base + display: + char: 'Ω' + attr: robot + dir: [0, 1] + devices: + - workbench + - grabber + inventory: + - [2, board] + - [5, rock] +world: + default: [blank] + palette: + 'x': [grass, flower, base] + upperleft: [0, 0] + map: | + x diff --git a/data/scenarios/Testing/_Validation/795-prerequisite-cycle.yaml b/data/scenarios/Testing/_Validation/795-prerequisite-cycle.yaml new file mode 100644 index 0000000000..8075d12d2e --- /dev/null +++ b/data/scenarios/Testing/_Validation/795-prerequisite-cycle.yaml @@ -0,0 +1,42 @@ +version: 1 +name: | + Prerequisite objectives: dependency cycle +description: | + This should be rejected by the parser. +objectives: + - goal: + - Make a "furnace". + condition: | + as base {has "furnace"}; + id: have_furnace + prerequisite: + logic: + id: have_gear + - goal: + - Make a "wooden gear". + condition: | + as base {has "wooden gear"}; + id: have_gear + prerequisite: + logic: + id: have_furnace +solution: | + make "wooden gear" +robots: + - name: base + display: + char: 'Ω' + attr: robot + dir: [0, 1] + devices: + - workbench + inventory: + - [2, board] + - [5, rock] +world: + default: [blank] + palette: + 'x': [grass, null, base] + upperleft: [0, 0] + map: | + x diff --git a/data/scenarios/Testing/_Validation/795-prerequisite-nonexistent-reference.yaml b/data/scenarios/Testing/_Validation/795-prerequisite-nonexistent-reference.yaml new file mode 100644 index 0000000000..ac4e6218c7 --- /dev/null +++ b/data/scenarios/Testing/_Validation/795-prerequisite-nonexistent-reference.yaml @@ -0,0 +1,40 @@ +version: 1 +name: | + Prerequisite objectives: Nonexistent reference +description: | + This scenario should be unparseable due to typo "shave_furnace" vs "have_furnace" +objectives: + - goal: + - Achieve one of two other objectives + condition: | + return true; + prerequisite: + logic: + id: shave_furnace + - goal: + - Make a "furnace". + condition: | + as base {has "furnace"}; + id: have_furnace + optional: true +solution: | + make "furnace" +robots: + - name: base + display: + char: 'Ω' + attr: robot + dir: [0, 1] + devices: + - workbench + - grabber + inventory: + - [2, board] + - [5, rock] +world: + default: [blank] + palette: + 'x': [grass, flower, base] + upperleft: [0, 0] + map: | + x diff --git a/data/scenarios/Testing/_Validation/795-prerequisite-self-reference.yaml b/data/scenarios/Testing/_Validation/795-prerequisite-self-reference.yaml new file mode 100644 index 0000000000..3ad8da3e0b --- /dev/null +++ b/data/scenarios/Testing/_Validation/795-prerequisite-self-reference.yaml @@ -0,0 +1,33 @@ +version: 1 +name: | + Prerequisite objectives: dependency cycle (self-reference) +description: | + This should be rejected by the parser. +objectives: + - goal: + - Make a "furnace". + condition: | + as base {has "furnace"}; + id: have_furnace + prerequisite: + logic: + id: have_furnace +solution: | + make "furnace" +robots: + - name: base + display: + char: 'Ω' + attr: robot + dir: [0, 1] + devices: + - workbench + inventory: + - [5, rock] +world: + default: [blank] + palette: + 'x': [grass, null, base] + upperleft: [0, 0] + map: | + x diff --git a/data/scenarios/Tutorials/bind2.yaml b/data/scenarios/Tutorials/bind2.yaml index 8ea4852848..22d85eb4ee 100644 --- a/data/scenarios/Tutorials/bind2.yaml +++ b/data/scenarios/Tutorials/bind2.yaml @@ -19,6 +19,7 @@ objectives: w <- as p {ishere "Hastur"}; return (not w); } { return false } + id: grab_artifact - goal: - | Your robot obtained the misplaced artifact! Next you need to put it back @@ -56,6 +57,9 @@ objectives: w <- as p {ishere "Hastur"}; return w; } { return false } + prerequisite: + logic: + id: grab_artifact solution: | run "data/scenarios/Tutorials/bind2-solution.sw" entities: diff --git a/data/scenarios/Tutorials/farming.yaml b/data/scenarios/Tutorials/farming.yaml index 4c21ee5e05..cba5d7acf7 100644 --- a/data/scenarios/Tutorials/farming.yaml +++ b/data/scenarios/Tutorials/farming.yaml @@ -30,6 +30,7 @@ objectives: return (n >= 256) } } { return false } + id: get_many_lambdas - goal: - Congratulations! You have completed the most difficult simulated exercise and are ready to begin exploring the new planet in earnest. Of course there @@ -47,6 +48,9 @@ objectives: - Now go forth and build your swarm! condition: | try {as base {has "curry"}} {return false} + prerequisite: + logic: + id: get_many_lambdas solution: | run "scenarios/Tutorials/farming.sw"; run "scenarios/Tutorials/make_curry.sw"; diff --git a/data/scenarios/Tutorials/move.yaml b/data/scenarios/Tutorials/move.yaml index a2aa24a600..b11b6ac17b 100644 --- a/data/scenarios/Tutorials/move.yaml +++ b/data/scenarios/Tutorials/move.yaml @@ -14,6 +14,7 @@ objectives: condition: | r <- robotNamed "check1"; loc <- as r {has "Win"}; + id: move_to_first_flower - goal: - Good! Now you need to learn how to effectively repeat actions. - | @@ -29,6 +30,10 @@ objectives: condition: | r <- robotNamed "check2"; loc <- as r {has "Win"}; + id: move_along_corridor + prerequisite: + logic: + id: move_to_first_flower - goal: - Well done! In addition to `move`, you can use the `turn` command to turn your robot, for example, `turn right` or `turn east`. @@ -51,6 +56,10 @@ objectives: condition: | r <- robotNamed "check3"; loc <- as r {has "Win"}; + id: move_northeast_corner + prerequisite: + logic: + id: move_along_corridor - goal: - Good job! You are now ready to move and turn on your own. - To complete this challenge, move your robot to the northeast corner, @@ -61,6 +70,9 @@ objectives: condition: | r <- robotNamed "check4"; loc <- as r {has "Win"}; + prerequisite: + logic: + id: move_northeast_corner solution: | // 0 move;move; diff --git a/data/scenarios/Tutorials/world101.yaml b/data/scenarios/Tutorials/world101.yaml index a5f7555d6f..2dd583c823 100644 --- a/data/scenarios/Tutorials/world101.yaml +++ b/data/scenarios/Tutorials/world101.yaml @@ -26,6 +26,7 @@ objectives: n <- as base {count "tree"}; return (n >= 3) } { return false } + id: get_trees - goal: - Nice work! Now, use the trees to make a harvester device. This will require several intermediate products; try making @@ -34,6 +35,10 @@ objectives: you may end up needing some additional trees. condition: | try { as base {has "harvester"} } {return false} + id: get_harvester + prerequisite: + logic: + id: get_trees - goal: - Now that you have a harvester, you can use `harvest` instead of `grab` whenever you pick up a growing item (check for the word "growing" at the @@ -50,6 +55,9 @@ objectives: coordinates." condition: | try { as base {has "lambda"} } {return false} + prerequisite: + logic: + id: get_harvester robots: - name: base display: diff --git a/src/Data/BoolExpr.hs b/src/Data/BoolExpr.hs new file mode 100644 index 0000000000..fd472fcb3b --- /dev/null +++ b/src/Data/BoolExpr.hs @@ -0,0 +1,386 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-missing-methods #-} + +-------------------------------------------------------------------- + +-------------------------------------------------------------------- + +-- | +-- Module : Data.BoolExpr +-- Copyright : (c) Nicolas Pouillard 2008,2009 +-- License : BSD3 +-- +-- Maintainer: Nicolas Pouillard +-- Stability : provisional +-- Portability: +-- +-- Boolean expressions and various representations. +module Data.BoolExpr ( + -- * A boolean class + Boolean (..), + + -- * Generic functions derived from Boolean + bAnd, + bAll, + bOr, + bAny, + + -- * Boolean trees + BoolExpr (..), + reduceBoolExpr, + evalBoolExpr, + + -- * Boolean evaluation semantic + Eval (..), + runEvalId, + + -- * Signed constants + Signed (..), + negateSigned, + evalSigned, + reduceSigned, + constants, + negateConstant, + + -- * Conjunctive Normal Form + CNF (..), + Conj (..), + fromCNF, + boolTreeToCNF, + reduceCNF, + + -- * Disjunctive Normal Form + Disj (..), + DNF (..), + fromDNF, + boolTreeToDNF, + reduceDNF, + + -- * Other transformations + dualize, + fromBoolExpr, + pushNotInwards, +) +where + +-- import Test.QuickCheck hiding (Positive) +-- import Control.Applicative +import Control.Monad (ap) +import Data.Traversable + +import Data.Aeson +import Data.Char (toLower) +import GHC.Generics (Generic) + +-- | Signed values are either positive or negative. +data Signed a = Positive a | Negative a + deriving (Eq, Ord, Generic, Show, Read) + +instance Functor Signed where + fmap f (Positive x) = Positive (f x) + fmap f (Negative x) = Negative (f x) + +instance Traversable Signed where + traverse f (Positive x) = Positive <$> f x + traverse f (Negative x) = Negative <$> f x + +instance Foldable Signed where + foldMap = foldMapDefault + +instance Applicative Signed where + pure = Positive + (<*>) = ap + +instance Monad Signed where + Positive x >>= f = f x + Negative x >>= f = negateSigned $ f x + +infix 9 /\ +infix 9 \/ + +-- | A boolean type class. +class Boolean f where + (/\) :: f a -> f a -> f a + (\/) :: f a -> f a -> f a + bNot :: f a -> f a + bTrue :: f a + bFalse :: f a + bConst :: Signed a -> f a + +-- | Generalized 'Data.Foldable.and'. +bAnd :: (Foldable t, Boolean f) => t (f b) -> f b +bAnd = foldr (/\) bTrue + +-- | Generalized 'Data.Foldable.all'. +bAll :: (Foldable t, Boolean f) => (a -> f b) -> t a -> f b +bAll f = foldr (\x y -> f x /\ y) bTrue + +-- | Generalized 'Data.Foldable.or'. +bOr :: (Foldable t, Boolean f) => t (f b) -> f b +bOr = foldr (\/) bFalse + +-- | Generalized 'Data.Foldable.any'. +bAny :: (Foldable t, Boolean f) => (a -> f b) -> t a -> f b +bAny f = foldr (\x y -> f x \/ y) bFalse + +-- | Syntax of boolean expressions parameterized over a +-- set of leaves, named constants. +data BoolExpr a + = BAnd (BoolExpr a) (BoolExpr a) + | BOr (BoolExpr a) (BoolExpr a) + | BNot (BoolExpr a) + | BTrue + | BFalse + | BConst (Signed a) + deriving (Eq, Ord, Generic, Show {-! derive : Arbitrary !-}) + +prerequisiteOptions :: Options +prerequisiteOptions = + defaultOptions + { sumEncoding = ObjectWithSingleField + , constructorTagModifier = map toLower + } + +instance (ToJSON a) => ToJSON (Signed a) where + toJSON = genericToJSON prerequisiteOptions + +instance (ToJSON a) => ToJSON (BoolExpr a) where + toJSON = genericToJSON prerequisiteOptions + +instance (ToJSON a) => ToJSON (DNF a) where + toJSON = genericToJSON prerequisiteOptions + +instance (ToJSON a) => ToJSON (CNF a) where + toJSON = genericToJSON prerequisiteOptions + +instance (ToJSON a) => ToJSON (Conj a) where + toJSON = genericToJSON prerequisiteOptions + +instance (ToJSON a) => ToJSON (Disj a) where + toJSON = genericToJSON prerequisiteOptions + +instance Functor BoolExpr where + fmap f (BAnd a b) = BAnd (fmap f a) (fmap f b) + fmap f (BOr a b) = BOr (fmap f a) (fmap f b) + fmap f (BNot t) = BNot (fmap f t) + fmap _ BTrue = BTrue + fmap _ BFalse = BFalse + fmap f (BConst x) = BConst (fmap f x) + +instance Traversable BoolExpr where + traverse f (BAnd a b) = BAnd <$> traverse f a <*> traverse f b + traverse f (BOr a b) = BOr <$> traverse f a <*> traverse f b + traverse f (BNot t) = BNot <$> traverse f t + traverse _ BTrue = pure BTrue + traverse _ BFalse = pure BFalse + traverse f (BConst x) = BConst <$> traverse f x + +instance Foldable BoolExpr where + foldMap = foldMapDefault + +instance Boolean BoolExpr where + (/\) = BAnd + (\/) = BOr + bNot = BNot + bTrue = BTrue + bFalse = BFalse + bConst = BConst + +newtype Eval b a = Eval {runEval :: (a -> b) -> b} + +runEvalId :: Eval a a -> a +runEvalId e = runEval e id + +instance b ~ Bool => Boolean (Eval b) where + (/\) = liftE2 (&&) + (\/) = liftE2 (||) + bNot = liftE not + bTrue = Eval $ const True + bFalse = Eval $ const False + bConst = Eval . flip evalSigned + +liftE :: (b -> b) -> Eval b a -> Eval b a +liftE f (Eval x) = Eval (f . x) + +liftE2 :: (b -> b -> b) -> Eval b a -> Eval b a -> Eval b a +liftE2 f (Eval x) (Eval y) = Eval (\e -> f (x e) (y e)) + +-- | Turns a boolean tree into any boolean type. +fromBoolExpr :: Boolean f => BoolExpr a -> f a +fromBoolExpr (BAnd l r) = fromBoolExpr l /\ fromBoolExpr r +fromBoolExpr (BOr l r) = fromBoolExpr l \/ fromBoolExpr r +fromBoolExpr (BNot t) = bNot $ fromBoolExpr t +fromBoolExpr BTrue = bTrue +fromBoolExpr BFalse = bFalse +fromBoolExpr (BConst c) = bConst c + +--- | Disjunction of atoms ('a') +newtype Disj a = Disj {unDisj :: [a]} + deriving (Show, Generic, Functor, Semigroup, Monoid) + +--- | Conjunction of atoms ('a') +newtype Conj a = Conj {unConj :: [a]} + deriving (Show, Generic, Functor, Semigroup, Monoid) + +--- | Conjunctive Normal Form +newtype CNF a = CNF {unCNF :: Conj (Disj (Signed a))} + deriving (Show, Generic, Semigroup, Monoid) + +--- | Disjunctive Normal Form +newtype DNF a = DNF {unDNF :: Disj (Conj (Signed a))} + deriving (Show, Generic, Semigroup, Monoid) + +instance Functor CNF where + fmap f (CNF x) = CNF (fmap (fmap (fmap f)) x) + +instance Boolean CNF where + l /\ r = l `mappend` r + l \/ r = + CNF $ + Conj + [ x `mappend` y | x <- unConj $ unCNF l, y <- unConj $ unCNF r + ] + bNot = error "bNot on CNF" + bTrue = CNF $ Conj [] + bFalse = CNF $ Conj [Disj []] + bConst x = CNF $ Conj [Disj [x]] + +instance Functor DNF where + fmap f (DNF x) = DNF (fmap (fmap (fmap f)) x) + +instance Boolean DNF where + l /\ r = + DNF $ + Disj + [ x `mappend` y | x <- unDisj $ unDNF l, y <- unDisj $ unDNF r + ] + l \/ r = l `mappend` r + bNot = error "bNot on CNF" + bTrue = DNF $ Disj [Conj []] + bFalse = DNF $ Disj [] + bConst x = DNF $ Disj [Conj [x]] + +-- | Reduce a boolean tree annotated by booleans to a single boolean. +reduceBoolExpr :: BoolExpr Bool -> Bool +reduceBoolExpr = evalBoolExpr id + +-- Given a evaluation function of constants, returns an evaluation +-- function over boolean trees. +-- +-- Note that since 'BoolExpr' is a functor, one can simply use +-- 'reduceBoolExpr': +-- +-- @ +-- evalBoolExpr f = reduceBoolExpr . fmap (f$) +-- @ +evalBoolExpr :: (a -> Bool) -> (BoolExpr a -> Bool) +evalBoolExpr env expr = runEval (fromBoolExpr expr) env + +-- | Returns constants used in a given boolean tree, these +-- constants are returned signed depending one how many +-- negations stands over a given constant. +constants :: BoolExpr a -> [Signed a] +constants = go True + where + go sign (BAnd a b) = go sign a ++ go sign b + go sign (BOr a b) = go sign a ++ go sign b + go sign (BNot t) = go (not sign) t + go _ BTrue = [] + go _ BFalse = [] + go sign (BConst x) = [if sign then x else negateSigned x] + +dualize :: Boolean f => BoolExpr a -> f a +dualize (BAnd l r) = dualize l \/ dualize r +dualize (BOr l r) = dualize l /\ dualize r +dualize BTrue = bFalse +dualize BFalse = bTrue +dualize (BConst c) = negateConstant c +dualize (BNot e) = fromBoolExpr e + +-- When dualize is used by pushNotInwards not BNot remain, +-- hence it makes sense to assert that dualize does not +-- have to work on BNot. However `dualize` can be freely +-- used as a fancy `bNot`. +-- dualize (BNot _) = error "dualize: impossible" + +-- | Push the negations inwards as much as possible. +-- The resulting boolean tree no longer use negations. +pushNotInwards :: Boolean f => BoolExpr a -> f a +pushNotInwards (BAnd l r) = pushNotInwards l /\ pushNotInwards r +pushNotInwards (BOr l r) = pushNotInwards l \/ pushNotInwards r +pushNotInwards (BNot t) = dualize $ pushNotInwards t +pushNotInwards BTrue = bTrue +pushNotInwards BFalse = bFalse +pushNotInwards (BConst c) = bConst c + +-- | Convert a 'CNF' (a boolean expression in conjunctive normal form) +-- to any other form supported by 'Boolean'. +fromCNF :: Boolean f => CNF a -> f a +fromCNF = bAll (bAny bConst . unDisj) . unConj . unCNF + +-- | Convert a 'DNF' (a boolean expression in disjunctive normal form) +-- to any other form supported by 'Boolean'. +fromDNF :: Boolean f => DNF a -> f a +fromDNF = bAny (bAll bConst . unConj) . unDisj . unDNF + +-- | Convert a boolean tree to a conjunctive normal form. +boolTreeToCNF :: BoolExpr a -> CNF a +boolTreeToCNF = pushNotInwards + +-- | Convert a boolean tree to a disjunctive normal form. +boolTreeToDNF :: BoolExpr a -> DNF a +boolTreeToDNF = pushNotInwards + +-- | Reduce a boolean expression in conjunctive normal form to a single +-- boolean. +reduceCNF :: CNF Bool -> Bool +reduceCNF = runEvalId . fromCNF + +-- | Reduce a boolean expression in disjunctive normal form to a single +-- boolean. +reduceDNF :: DNF Bool -> Bool +reduceDNF = runEvalId . fromDNF + +evalSigned :: (a -> Bool) -> Signed a -> Bool +evalSigned f (Positive x) = f x +evalSigned f (Negative x) = not $ f x + +reduceSigned :: Signed Bool -> Bool +reduceSigned = evalSigned id + +negateSigned :: Signed a -> Signed a +negateSigned (Positive x) = Negative x +negateSigned (Negative x) = Positive x + +negateConstant :: Boolean f => Signed a -> f a +negateConstant = bConst . negateSigned + +{- +prop_reduceBoolExpr_EQ_reduceCNF t = reduceBoolExpr t == reduceCNF (boolTreeToCNF t) + +prop_reduceBoolExpr_EQ_reduceCNF_Bool = prop_reduceBoolExpr_EQ_reduceCNF (BConst . not) + +prop_reduceBoolExpr_EQ_reduceDNF t = reduceBoolExpr t == reduceDNF (boolTreeToDNF t) + +prop_reduceBoolExpr_EQ_reduceDNF_Bool = prop_reduceBoolExpr_EQ_reduceDNF (BConst . not) + +{-* Generated by DrIFT : Look, but Don't Touch. *-} +instance (Arbitrary a) => Arbitrary (BoolExpr a) where + arbitrary = do x <- choose (1::Int,6) -- :: Int inserted manually + case x of + 1 -> do v1 <- arbitrary + v2 <- arbitrary + return (BAnd v1 v2) + 2 -> do v1 <- arbitrary + v2 <- arbitrary + return (BOr v1 v2) + 3 -> do v1 <- arbitrary + return (BNot v1) + 4 -> do return (BTrue ) + 5 -> do return (BFalse ) + 6 -> do v1 <- arbitrary + return (BConst v1) + --coarbitrary = error "coarbitrary not yet supported" -- quickcheck2 +-} diff --git a/src/Data/LICENSE b/src/Data/LICENSE new file mode 100644 index 0000000000..25a8865db0 --- /dev/null +++ b/src/Data/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2008, 2009, Nicolas Pouillard +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of the copyright holders nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/src/Swarm/Game/Display.hs b/src/Swarm/Game/Display.hs index 8b1a771af3..919ea9e190 100644 --- a/src/Swarm/Game/Display.hs +++ b/src/Swarm/Game/Display.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-} diff --git a/src/Swarm/Game/Entity.hs b/src/Swarm/Game/Entity.hs index 5db3ed041a..831bc1ba21 100644 --- a/src/Swarm/Game/Entity.hs +++ b/src/Swarm/Game/Entity.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} diff --git a/src/Swarm/Game/Scenario.hs b/src/Swarm/Game/Scenario.hs index 786c0a594b..8a18c44b96 100644 --- a/src/Swarm/Game/Scenario.hs +++ b/src/Swarm/Game/Scenario.hs @@ -17,11 +17,6 @@ -- conditions, which can be used both for building interactive -- tutorials and for standalone puzzles and scenarios. module Swarm.Game.Scenario ( - -- * Objectives - Objective, - objectiveGoal, - objectiveCondition, - -- * WorldDescription PCell (..), Cell, @@ -59,6 +54,7 @@ import Control.Carrier.Lift (Lift, sendIO) import Control.Carrier.Throw.Either (Throw, throwError) import Control.Lens hiding (from, (<.>)) import Control.Monad (filterM) +import Data.Aeson import Data.Maybe (catMaybes, isNothing, listToMaybe) import Data.Text (Text) import Data.Text qualified as T @@ -68,6 +64,7 @@ import Swarm.Game.Recipe import Swarm.Game.Robot (TRobot) import Swarm.Game.Scenario.Cell import Swarm.Game.Scenario.Objective +import Swarm.Game.Scenario.Objective.Validation import Swarm.Game.Scenario.RobotLookup import Swarm.Game.Scenario.WorldDescription import Swarm.Language.Pipeline (ProcessedTerm) @@ -99,7 +96,7 @@ data Scenario = Scenario , _scenarioSolution :: Maybe ProcessedTerm , _scenarioStepsPerTick :: Maybe Int } - deriving (Eq, Show) + deriving (Show) makeLensesWith (lensRules & generateSignatures .~ False) ''Scenario @@ -108,6 +105,10 @@ instance FromJSONE EntityMap Scenario where -- parse custom entities em <- liftE (buildEntityMap <$> (v .:? "entities" .!= [])) -- extend ambient EntityMap with custom entities + + objectivesRaw <- liftE (v .:? "objectives" .!= []) + objectives <- validateObjectives objectivesRaw + withE em $ do -- parse 'known' entity names and make sure they exist known <- liftE (v .:? "known" .!= []) @@ -134,7 +135,7 @@ instance FromJSONE EntityMap Scenario where <*> pure known <*> localE (,rsMap) (v ..: "world") <*> pure rs - <*> liftE (v .:? "objectives" .!= []) + <*> pure objectives <*> liftE (v .:? "solution") <*> liftE (v .:? "stepsPerTick") diff --git a/src/Swarm/Game/Scenario/Objective.hs b/src/Swarm/Game/Scenario/Objective.hs index 4fdfee47c0..c8d2ee35a1 100644 --- a/src/Swarm/Game/Scenario/Objective.hs +++ b/src/Swarm/Game/Scenario/Objective.hs @@ -1,26 +1,63 @@ +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Swarm.Game.Scenario.Objective where import Control.Lens hiding (from, (<.>)) +import Data.Aeson +import Data.Set qualified as Set import Data.Text (Text) -import Data.Yaml as Y import GHC.Generics (Generic) +import Swarm.Game.Scenario.Objective.Logic as L import Swarm.Language.Pipeline (ProcessedTerm) +import Swarm.TUI.Model.Achievement.Definitions import Swarm.Util (reflow) ------------------------------------------------------------ -- Scenario objectives ------------------------------------------------------------ +data PrerequisiteConfig = PrerequisiteConfig + { previewable :: Bool + -- ^ Typically, only the currently "active" objectives are + -- displayed to the user in the Goals dialog. An objective + -- is "active" if all of its prerequisites are met. + -- + -- However, some objectives may be "high-level", in that they may + -- explain the broader intention behind potentially multiple + -- prerequisites. + -- + -- Set this to option True to display this goal in the "upcoming" section even + -- if the objective has currently unmet prerequisites. + , logic :: Prerequisite ObjectiveLabel + -- ^ Boolean expression the represents the condition dependencies which also + -- must have been evaluated to True. + -- Note that the achievement of these objective dependencies is + -- persistent; once achieved, it still counts even if the "condition" + -- might not still hold. The condition is never re-evaluated once True. + } + deriving (Eq, Show, Generic, ToJSON) + +instance FromJSON PrerequisiteConfig where + parseJSON = withObject "prerequisite" $ \v -> + PrerequisiteConfig + <$> (v .:? "previewable" .!= False) + <*> (v .: "logic") + -- | An objective is a condition to be achieved by a player in a -- scenario. data Objective = Objective { _objectiveGoal :: [Text] , _objectiveCondition :: ProcessedTerm + , _objectiveId :: Maybe ObjectiveLabel + , _objectiveOptional :: Bool + , _objectivePrerequisite :: Maybe PrerequisiteConfig + , _objectiveHidden :: Bool + , _objectiveAchievement :: Maybe AchievementInfo } - deriving (Eq, Show, Generic, ToJSON) + deriving (Show, Generic, ToJSON) makeLensesWith (lensRules & generateSignatures .~ False) ''Objective @@ -34,8 +71,109 @@ objectiveGoal :: Lens' Objective [Text] -- of CESK steps per tick do not apply). objectiveCondition :: Lens' Objective ProcessedTerm +-- | Optional name by which this objective may be referenced +-- as a prerequisite for other objectives. +objectiveId :: Lens' Objective (Maybe Text) + +-- | Indicates whether the objective is not required in order +-- to "win" the scenario. Useful for (potentially hidden) achievements. +-- If the field is not supplied, it defaults to False (i.e. the +-- objective is mandatory to "win"). +objectiveOptional :: Lens' Objective Bool + +-- | Dependencies upon other objectives +objectivePrerequisite :: Lens' Objective (Maybe PrerequisiteConfig) + +-- | Whether the goal is displayed in the UI before completion. +-- The goal will always be revealed after it is completed. +-- +-- This attribute often goes along with an Achievement. +objectiveHidden :: Lens' Objective Bool + +-- | An optional Achievement that is to be registered globally +-- when this objective is completed. +objectiveAchievement :: Lens' Objective (Maybe AchievementInfo) + instance FromJSON Objective where parseJSON = withObject "objective" $ \v -> Objective <$> (fmap . map) reflow (v .:? "goal" .!= []) <*> (v .: "condition") + <*> (v .:? "id") + <*> (v .:? "optional" .!= False) + <*> (v .:? "prerequisite") + <*> (v .:? "hidden" .!= False) + <*> (v .:? "achievement") + +data CompletionBuckets = CompletionBuckets + { incomplete :: [Objective] + , completed :: [Objective] + , unwinnable :: [Objective] + } + deriving (Show, Generic, FromJSON, ToJSON) + +data ObjectiveCompletion = ObjectiveCompletion + { completionBuckets :: CompletionBuckets + -- ^ This is the authoritative "completion status" + -- for all objectives. + -- Note that there is a separate Set to store the + -- completion status of prerequisite objectives, which + -- must be carefully kept in sync with this. + -- Those prerequisite objectives are required to have + -- labels, but other objectives are not. + -- Therefore only prerequisites exist in the completion + -- map keyed by label. + , completedIDs :: Set.Set ObjectiveLabel + } + deriving (Show, Generic, FromJSON, ToJSON) + +-- | Concatenates all incomplete and completed objectives. +listAllObjectives :: CompletionBuckets -> [Objective] +listAllObjectives (CompletionBuckets x y z) = x <> y <> z + +addCompleted :: Objective -> ObjectiveCompletion -> ObjectiveCompletion +addCompleted obj (ObjectiveCompletion buckets cmplIds) = + ObjectiveCompletion newBuckets newCmplById + where + newBuckets = + buckets + { completed = obj : completed buckets + } + newCmplById = case _objectiveId obj of + Nothing -> cmplIds + Just lbl -> Set.insert lbl cmplIds + +addUnwinnable :: Objective -> ObjectiveCompletion -> ObjectiveCompletion +addUnwinnable obj (ObjectiveCompletion buckets cmplIds) = + ObjectiveCompletion newBuckets newCmplById + where + newBuckets = + buckets + { unwinnable = obj : unwinnable buckets + } + newCmplById = cmplIds + +setIncomplete :: + ([Objective] -> [Objective]) -> + ObjectiveCompletion -> + ObjectiveCompletion +setIncomplete f (ObjectiveCompletion buckets cmplIds) = + ObjectiveCompletion newBuckets cmplIds + where + newBuckets = + buckets + { incomplete = f $ incomplete buckets + } + +addIncomplete :: Objective -> ObjectiveCompletion -> ObjectiveCompletion +addIncomplete obj = setIncomplete (obj :) + +-- | Returns the "ObjectiveCompletion" with the "incomplete" goals +-- extracted to a separate tuple member. +-- This is intended as input to a "fold". +extractIncomplete :: ObjectiveCompletion -> (ObjectiveCompletion, [Objective]) +extractIncomplete oc = + (withoutIncomplete, incompleteGoals) + where + incompleteGoals = incomplete $ completionBuckets oc + withoutIncomplete = setIncomplete (const []) oc diff --git a/src/Swarm/Game/Scenario/Objective/Graph.hs b/src/Swarm/Game/Scenario/Objective/Graph.hs new file mode 100644 index 0000000000..38bb528285 --- /dev/null +++ b/src/Swarm/Game/Scenario/Objective/Graph.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Swarm.Game.Scenario.Objective.Graph where + +import Control.Arrow ((&&&)) +import Data.Aeson +import Data.BoolExpr (Signed (Positive)) +import Data.BoolExpr qualified as BE +import Data.Graph (Graph, SCC (AcyclicSCC), graphFromEdges, stronglyConnComp) +import Data.Map (Map) +import Data.Map.Strict qualified as M +import Data.Maybe (mapMaybe) +import Data.Set qualified as Set +import Data.Text qualified as T +import Data.Tuple (swap) +import GHC.Generics (Generic) +import Swarm.Game.Scenario.Objective +import Swarm.Game.Scenario.Objective.Logic as L +import Swarm.Game.Scenario.Objective.WinCheck + +-- | This is only needed for constructing a Graph, +-- which requires all nodes to have a key. +data ObjectiveId + = Label (Signed ObjectiveLabel) + | -- | for unlabeled objectives + Ordinal Int + deriving (Eq, Ord, Show, Generic, ToJSON) + +data GraphInfo = GraphInfo + { actualGraph :: Graph + , isAcyclic :: Bool + , sccInfo :: [SCC Objective] + , nodeIDs :: [ObjectiveId] + } + deriving (Show, Generic, ToJSON) + +instance ToJSON (SCC Objective) where + toJSON = String . T.pack . show + +instance ToJSON Graph where + toJSON = String . T.pack . show + +getConstFromSigned :: BE.Signed a -> a +getConstFromSigned = \case + BE.Positive x -> x + BE.Negative x -> x + +getNegatedIds :: [Objective] -> Map ObjectiveLabel Objective +getNegatedIds objs = + M.fromList $ mapMaybe f allConstants + where + objectivesById = getObjectivesById objs + + allPrereqExpressions = mapMaybe _objectivePrerequisite objs + allConstants = + mapMaybe onlyNegative $ + Set.toList $ + Set.unions $ + map (getDistinctConstants . logic) allPrereqExpressions + + f = sequenceA . \x -> (x, M.lookup x objectivesById) + + onlyNegative = \case + BE.Negative x -> Just x + _ -> Nothing + +getObjectivesById :: [Objective] -> Map ObjectiveLabel Objective +getObjectivesById objs = + M.fromList $ + map swap $ + mapMaybe (sequenceA . (id &&& _objectiveId)) objs + +-- | Uses the textual labels for those objectives that +-- have them, and assigns arbitrary integer IDs for +-- the remaining. +-- +-- Only necessary for constructing a "Graph". +assignIds :: [Objective] -> Map ObjectiveId Objective +assignIds objs = + unlabeledObjsMap <> labeledObjsMap + where + objectivesById = getObjectivesById objs + + labledObjsDirect = M.mapKeys (Label . Positive) objectivesById + labeledObjsMap = labledObjsDirect + + unlabeledObjs = filter (null . _objectiveId) objs + unlabeledObjsMap = M.fromList $ zipWith (\x y -> (Ordinal x, y)) [0 ..] unlabeledObjs + +-- | NOTE: Based strictly on the goal labels, the graph could +-- potentially contain a cycle, if there exist +-- mutually-exclusive goals. That is, if goal A depends on the NOT +-- of "goal B". Goal B could then also depend on "NOT Goal A" (re-enforcing the +-- mutual-exclusivity), or it could mandate a completion order, e.g.: +-- Goal A and Goal B are simultaneously available to pursue. However, if the +-- player completes Goal B first, then it closes off the option to complete +-- Goal A. However, if Goal A is completed first, then the user is also allowed +-- to complete Goal B. +-- +-- To avoid a "cycle" in this circumstance, "A" needs to exist as a distinct node +-- from "NOT A" in the graph. +makeGraph :: [Objective] -> Graph +makeGraph objectives = + myGraph + where + (myGraph, _, _) = graphFromEdges $ makeGraphEdges objectives + +makeGraphEdges :: [Objective] -> [(Objective, ObjectiveId, [ObjectiveId])] +makeGraphEdges objectives = + rootTuples <> negatedTuples + where + rootTuples = map f $ M.toList $ assignIds objectives + negatedTuples = map gg $ M.toList $ getNegatedIds objectives + gg (k, v) = (v, Label $ BE.Negative k, []) + + f (k, v) = (v, k, maybe [] (map Label . g) $ _objectivePrerequisite v) + g = Set.toList . getDistinctConstants . logic + +getStronglyConnectedComponents :: [Objective] -> [SCC Objective] +getStronglyConnectedComponents objectives = + stronglyConnComp $ makeGraphEdges objectives + +isAcyclicGraph :: [Objective] -> Bool +isAcyclicGraph objectives = + all isAcyclicVerex $ getStronglyConnectedComponents objectives + where + isAcyclicVerex = \case + AcyclicSCC _ -> True + _ -> False + +makeGraphInfo :: ObjectiveCompletion -> GraphInfo +makeGraphInfo oc = + GraphInfo + (makeGraph objs) + (isAcyclicGraph objs) + (getStronglyConnectedComponents objs) + (M.keys $ assignIds objs) + where + objs = listAllObjectives $ completionBuckets oc diff --git a/src/Swarm/Game/Scenario/Objective/Logic.hs b/src/Swarm/Game/Scenario/Objective/Logic.hs new file mode 100644 index 0000000000..8932cade32 --- /dev/null +++ b/src/Swarm/Game/Scenario/Objective/Logic.hs @@ -0,0 +1,41 @@ +module Swarm.Game.Scenario.Objective.Logic where + +import Data.Aeson +import Data.BoolExpr +import Data.Char (toLower) +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.Text (Text) +import GHC.Generics (Generic) + +type ObjectiveLabel = Text + +-- | In contrast with the "BoolExpr" type, +-- "And" and "Or" can have /one or more/ children +-- instead of /exactly two/. +data Prerequisite a + = And (NonEmpty (Prerequisite a)) + | Or (NonEmpty (Prerequisite a)) + | Not (Prerequisite a) + | Id a + deriving (Eq, Show, Generic, Functor, Foldable) + +prerequisiteOptions :: Options +prerequisiteOptions = + defaultOptions + { sumEncoding = ObjectWithSingleField + , constructorTagModifier = map toLower + } + +instance ToJSON (Prerequisite ObjectiveLabel) where + toJSON = genericToJSON prerequisiteOptions + +instance FromJSON (Prerequisite ObjectiveLabel) where + parseJSON = genericParseJSON prerequisiteOptions + +toBoolExpr :: Prerequisite a -> BoolExpr a +toBoolExpr (And (x :| [])) = toBoolExpr x +toBoolExpr (And (x0 :| x : xs)) = BAnd (toBoolExpr x0) (toBoolExpr $ And $ x :| xs) +toBoolExpr (Or (x :| [])) = toBoolExpr x +toBoolExpr (Or (x0 :| x : xs)) = BOr (toBoolExpr x0) (toBoolExpr $ Or $ x :| xs) +toBoolExpr (Not x) = BNot $ toBoolExpr x +toBoolExpr (Id x) = BConst $ pure x diff --git a/src/Swarm/Game/Scenario/Objective/Presentation/Model.hs b/src/Swarm/Game/Scenario/Objective/Presentation/Model.hs new file mode 100644 index 0000000000..039c8ed33a --- /dev/null +++ b/src/Swarm/Game/Scenario/Objective/Presentation/Model.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE TemplateHaskell #-} + +module Swarm.Game.Scenario.Objective.Presentation.Model where + +import Brick.Widgets.List qualified as BL +import Control.Lens (makeLenses) +import Data.Aeson +import Data.List.NonEmpty (NonEmpty, nonEmpty) +import Data.Map (Map) +import Data.Map qualified as M +import Data.Maybe (mapMaybe) +import GHC.Generics (Generic) +import Swarm.Game.Scenario.Objective +import Swarm.Game.Scenario.Objective.WinCheck +import Swarm.TUI.Model.Name + +-- | These are intended to be used as keys in a map +-- of lists of goals. +data GoalStatus + = -- | Goals in this category have other goals as prerequisites. + -- However, they are only displayed if the "previewable" attribute + -- is `true`. + Upcoming + | -- | Goals in this category may be pursued in parallel. + -- However, they are only displayed if the "hidden" attribute + -- is `false`. + Active + | -- | A goal's programmatic condition, as well as all its the prerequisites, were completed. + -- This is a "latch" mechanism; at some point the conditions required to meet the goal may + -- no longer hold. Nonetheless, the goal remains "completed". + Completed + | -- | A goal that can no longer be achieved. + -- If this goal is not an "optional" goal, then the player + -- also "Loses" the scenario. + -- + -- Note that currently the only way to "Fail" a goal is by way + -- of a NOT prerequisite that was completed. + Failed + deriving (Show, Eq, Ord, Bounded, Enum, Generic, ToJSON, ToJSONKey) + +-- | TODO Could also add an "ObjectiveFailed" constructor... +newtype Announcement + = ObjectiveCompleted Objective + deriving (Show, Generic, ToJSON) + +type CategorizedGoals = Map GoalStatus (NonEmpty Objective) + +data GoalEntry + = Header GoalStatus + | Goal GoalStatus Objective + +data GoalTracking = GoalTracking + { announcements :: [Announcement] + -- ^ TODO the actual contents of these are not used yet, + -- other than as flags to pop up the Goal dialog. + , goals :: CategorizedGoals + } + deriving (Generic, ToJSON) + +data GoalDisplay = GoalDisplay + { _goalsContent :: GoalTracking + , _listWidget :: BL.List Name GoalEntry + -- ^ required for maintaining the selection/navigation + -- state among list items + } + +makeLenses ''GoalDisplay + +emptyGoalDisplay :: GoalDisplay +emptyGoalDisplay = + GoalDisplay (GoalTracking mempty mempty) $ + BL.list ObjectivesList mempty 1 + +hasAnythingToShow :: GoalTracking -> Bool +hasAnythingToShow (GoalTracking ann g) = not (null ann && null g) + +constructGoalMap :: Bool -> ObjectiveCompletion -> CategorizedGoals +constructGoalMap isCheating objectiveCompletion@(ObjectiveCompletion buckets _) = + M.fromList $ + mapMaybe (traverse nonEmpty) categoryList + where + categoryList = + [ (Upcoming, displayableInactives) + , (Active, suppressHidden activeGoals) + , (Completed, completed buckets) + , (Failed, unwinnable buckets) + ] + + displayableInactives = + suppressHidden $ + filter (maybe False previewable . _objectivePrerequisite) inactiveGoals + + suppressHidden = + if isCheating + then id + else filter $ not . _objectiveHidden + + (activeGoals, inactiveGoals) = partitionActiveObjectives objectiveCompletion diff --git a/src/Swarm/Game/Scenario/Objective/Presentation/Render.hs b/src/Swarm/Game/Scenario/Objective/Presentation/Render.hs new file mode 100644 index 0000000000..25ed7d37cf --- /dev/null +++ b/src/Swarm/Game/Scenario/Objective/Presentation/Render.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Swarm.Game.Scenario.Objective.Presentation.Render where + +import Brick hiding (Direction, Location) +import Brick.Widgets.Center +import Brick.Widgets.List qualified as BL +import Control.Lens hiding (Const, from) +import Data.List.NonEmpty qualified as NE +import Data.Map.Strict qualified as M +import Data.Maybe (listToMaybe) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Vector qualified as V +import Swarm.Game.Scenario.Objective +import Swarm.Game.Scenario.Objective.Presentation.Model +import Swarm.TUI.Attr +import Swarm.TUI.Model.Name +import Swarm.TUI.View.Util + +makeListWidget :: GoalTracking -> BL.List Name GoalEntry +makeListWidget (GoalTracking _announcements categorizedObjs) = + BL.listMoveTo 1 $ BL.list ObjectivesList (V.fromList objList) 1 + where + objList = concatMap f $ M.toList categorizedObjs + f (h, xs) = Header h : map (Goal h) (NE.toList xs) + +renderGoalsDisplay :: GoalDisplay -> Widget Name +renderGoalsDisplay gd = + padAll 1 $ + hBox + [ hLimitPercent 30 $ + vBox + [ hCenter $ str "Goals" + , padAll 1 $ + vLimit 10 $ + BL.renderList (const drawGoalListItem) True lw + ] + , hLimitPercent 70 $ + padLeft (Pad 2) $ + maybe emptyWidget (singleGoalDetails . snd) $ + BL.listSelectedElement lw + ] + where + lw = _listWidget gd + +withEllipsis :: Text -> Widget Name +withEllipsis t = + Widget Greedy Fixed $ do + ctx <- getContext + let w = ctx ^. availWidthL + ellipsis = T.replicate 3 $ T.singleton '.' + tLength = T.length t + newText = + if tLength > w + then T.take (w - T.length ellipsis) t <> ellipsis + else t + render $ txt newText + +getCompletionIcon :: Objective -> GoalStatus -> Widget Name +getCompletionIcon obj = \case + Upcoming -> withAttr yellowAttr $ txt " ○ " + Active -> withAttr cyanAttr $ txt " ○ " + Failed -> withAttr redAttr $ txt " ● " + Completed -> withAttr colorattr $ txt " ● " + where + colorattr = + if obj ^. objectiveHidden + then magentaAttr + else greenAttr + +drawGoalListItem :: + GoalEntry -> + Widget Name +drawGoalListItem = \case + Header gs -> withAttr boldAttr $ str $ show gs + Goal gs obj -> getCompletionIcon obj gs <+> titleWidget + where + titleWidget = case listToMaybe $ obj ^. objectiveGoal of + Nothing -> txt "?" + Just x -> withEllipsis x + +singleGoalDetails :: GoalEntry -> Widget Name +singleGoalDetails = \case + Header _gs -> displayParagraphs [" "] + Goal _gs obj -> displayParagraphs $ obj ^. objectiveGoal diff --git a/src/Swarm/Game/Scenario/Objective/Simplify.hs b/src/Swarm/Game/Scenario/Objective/Simplify.hs new file mode 100644 index 0000000000..71b3d9852d --- /dev/null +++ b/src/Swarm/Game/Scenario/Objective/Simplify.hs @@ -0,0 +1,49 @@ +module Swarm.Game.Scenario.Objective.Simplify ( + cannotBeTrue, + replace, +) where + +import Data.BoolExpr +import Data.List qualified as L +import Data.Map (Map) +import Data.Map qualified as M +import Data.Set qualified as S + +extractConstFromSigned :: Signed a -> (a, Bool) +extractConstFromSigned v = case v of + Negative x -> (x, False) + Positive x -> (x, True) + +hasContradiction :: Ord a => Conj (Signed a) -> Bool +hasContradiction (Conj items) = + not $ + M.null $ + M.filter ((> 1) . S.size) $ + M.fromListWith (<>) $ + fmap (fmap S.singleton . extractConstFromSigned) items + +simplifyDNF :: Ord a => DNF a -> DNF a +simplifyDNF (DNF (Disj disjunctions)) = + DNF $ Disj $ L.filter (not . hasContradiction) disjunctions + +isAlwaysFalse :: Ord a => DNF a -> Bool +isAlwaysFalse (DNF (Disj disjunctions)) = L.null disjunctions + +cannotBeTrue :: Ord a => BoolExpr a -> Bool +cannotBeTrue = isAlwaysFalse . simplifyDNF . boolTreeToDNF + +replace :: Ord a => Map a Bool -> BoolExpr a -> BoolExpr a +replace f (BAnd a b) = BAnd (replace f a) (replace f b) +replace f (BOr a b) = BOr (replace f a) (replace f b) +replace f (BNot t) = BNot (replace f t) +replace _ BTrue = BTrue +replace _ BFalse = BFalse +replace m c@(BConst x) = case M.lookup varname m of + Nothing -> c + Just val -> + if txform val + then BTrue + else BFalse + where + (varname, isPositive) = extractConstFromSigned x + txform = if isPositive then id else not diff --git a/src/Swarm/Game/Scenario/Objective/Validation.hs b/src/Swarm/Game/Scenario/Objective/Validation.hs new file mode 100644 index 0000000000..dfe443370a --- /dev/null +++ b/src/Swarm/Game/Scenario/Objective/Validation.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Swarm.Game.Scenario.Objective.Validation where + +import Control.Monad (unless) +import Data.Foldable (for_, toList) +import Data.Maybe (mapMaybe) +import Data.Set qualified as Set +import Data.Text qualified as T +import Swarm.Game.Scenario.Objective +import Swarm.Game.Scenario.Objective.Graph +import Swarm.Util (quote) +import Witch (into) + +-- | Performs monadic validation before returning +-- the "pure" construction of a wrapper record. +-- This validation entails: +-- 1) Ensuring that all goal references utilized in prerequisites +-- actually exist +-- 2) Ensuring that the graph of dependencies is acyclic. +validateObjectives :: + MonadFail m => + [Objective] -> + m [Objective] +validateObjectives objectives = do + for_ objectives $ \x -> case _objectivePrerequisite x of + Just p -> + unless (null remaining) $ + fail . into @String $ + T.unwords + [ "Reference to undefined objective(s)" + , T.intercalate ", " (map quote $ Set.toList remaining) <> "." + , "Defined are:" + , T.intercalate ", " (map quote $ Set.toList allIds) + ] + where + refs = Set.fromList $ toList $ logic p + remaining = Set.difference refs allIds + Nothing -> return () + + unless (isAcyclicGraph objectives) $ + fail . into @String $ + T.unwords ["There are dependency cycles in the prerequisites."] + + return objectives + where + allIds = Set.fromList $ mapMaybe _objectiveId objectives diff --git a/src/Swarm/Game/Scenario/Objective/WinCheck.hs b/src/Swarm/Game/Scenario/Objective/WinCheck.hs new file mode 100644 index 0000000000..bb4520c930 --- /dev/null +++ b/src/Swarm/Game/Scenario/Objective/WinCheck.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Swarm.Game.Scenario.Objective.WinCheck where + +import Data.Aeson +import Data.BoolExpr qualified as BE +import Data.List (partition) +import Data.Map qualified as M +import Data.Set (Set) +import Data.Set qualified as Set +import GHC.Generics (Generic) +import Swarm.Game.Scenario.Objective +import Swarm.Game.Scenario.Objective.Logic as L +import Swarm.Game.Scenario.Objective.Simplify qualified as Simplify + +-- | We have "won" if all of the "unwinnable" or remaining "incomplete" objectives are "optional". +didWin :: ObjectiveCompletion -> Bool +didWin oc = all _objectiveOptional $ incomplete buckets <> unwinnable buckets + where + buckets = completionBuckets oc + +-- | We have "lost" if any of the "unwinnable" objectives not "optional". +didLose :: ObjectiveCompletion -> Bool +didLose oc = not $ all _objectiveOptional $ unwinnable buckets + where + buckets = completionBuckets oc + +isPrereqsSatisfied :: ObjectiveCompletion -> Objective -> Bool +isPrereqsSatisfied completions = + maybe True f . _objectivePrerequisite + where + f = BE.evalBoolExpr getTruth . L.toBoolExpr . logic + + getTruth :: ObjectiveLabel -> Bool + getTruth label = Set.member label $ completedIDs completions + +isUnwinnablePrereq :: Set ObjectiveLabel -> Prerequisite ObjectiveLabel -> Bool +isUnwinnablePrereq completedObjectives = + Simplify.cannotBeTrue . Simplify.replace boolMap . L.toBoolExpr + where + boolMap = + M.fromList $ + map (,True) $ + Set.toList completedObjectives + +isUnwinnable :: ObjectiveCompletion -> Objective -> Bool +isUnwinnable completions obj = + maybe False (isUnwinnablePrereq (completedIDs completions) . logic) $ _objectivePrerequisite obj + +partitionActiveObjectives :: ObjectiveCompletion -> ([Objective], [Objective]) +partitionActiveObjectives oc = + partition (isPrereqsSatisfied oc) $ + incomplete $ + completionBuckets oc + +getActiveObjectives :: ObjectiveCompletion -> [Objective] +getActiveObjectives = + fst . partitionActiveObjectives + +-- | For debugging only +data PrereqSatisfaction = PrereqSatisfaction + { objective :: Objective + , deps :: Set (BE.Signed ObjectiveLabel) + , prereqsSatisfied :: Bool + } + deriving (Generic, ToJSON) + +-- | Used only by the web interface for debugging +getSatisfaction :: ObjectiveCompletion -> [PrereqSatisfaction] +getSatisfaction oc = + map f $ + listAllObjectives $ + completionBuckets oc + where + f y = + PrereqSatisfaction + y + (maybe mempty (getDistinctConstants . logic) $ _objectivePrerequisite y) + (isPrereqsSatisfied oc y) + +getDistinctConstants :: (Ord a) => Prerequisite a -> Set (BE.Signed a) +getDistinctConstants = Set.fromList . BE.constants . toBoolExpr diff --git a/src/Swarm/Game/ScenarioInfo.hs b/src/Swarm/Game/ScenarioInfo.hs index 552f1105fc..2fe58ee444 100644 --- a/src/Swarm/Game/ScenarioInfo.hs +++ b/src/Swarm/Game/ScenarioInfo.hs @@ -177,7 +177,7 @@ updateScenarioInfoOnQuit z ticks completed (ScenarioInfo p s bTime bTicks) = cas -- | A scenario item is either a specific scenario, or a collection of -- scenarios (*e.g.* the scenarios contained in a subdirectory). data ScenarioItem = SISingle ScenarioInfoPair | SICollection Text ScenarioCollection - deriving (Eq, Show) + deriving (Show) -- | Retrieve the name of a scenario item. scenarioItemName :: ScenarioItem -> Text @@ -191,7 +191,7 @@ data ScenarioCollection = SC { scOrder :: Maybe [FilePath] , scMap :: Map FilePath ScenarioItem } - deriving (Eq, Show) + deriving (Show) -- | Access and modify ScenarioItems in collection based on their path. scenarioItemByPath :: FilePath -> Traversal' ScenarioCollection ScenarioItem diff --git a/src/Swarm/Game/State.hs b/src/Swarm/Game/State.hs index f3e1314a59..71ac0e547f 100644 --- a/src/Swarm/Game/State.hs +++ b/src/Swarm/Game/State.hs @@ -20,10 +20,12 @@ module Swarm.Game.State ( -- * Game state record and related types ViewCenterRule (..), REPLStatus (..), + WinStatus (..), WinCondition (..), + ObjectiveCompletion (..), _NoWinCondition, _WinConditions, - _Won, + Announcement (..), RunStatus (..), Seed, GameState, @@ -33,6 +35,7 @@ module Swarm.Game.State ( winCondition, winSolution, gameAchievements, + announcementQueue, runStatus, paused, robotMap, @@ -122,7 +125,6 @@ import Data.IntSet (IntSet) import Data.IntSet qualified as IS import Data.IntSet.Lens (setOf) import Data.List (partition, sortOn) -import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NE import Data.Map (Map) import Data.Map qualified as M @@ -145,6 +147,8 @@ import Swarm.Game.Recipe ( reqRecipeMap, ) import Swarm.Game.Robot +import Swarm.Game.Scenario.Objective +import Swarm.Game.Scenario.Objective.Presentation.Model import Swarm.Game.ScenarioInfo import Swarm.Game.Terrain (TerrainType (..)) import Swarm.Game.Value (Value) @@ -197,15 +201,28 @@ data REPLStatus REPLWorking (Typed (Maybe Value)) deriving (Eq, Show, Generic, FromJSON, ToJSON) +data WinStatus + = -- | There are one or more objectives remaining that the player + -- has not yet accomplished. + Ongoing + | -- | The player has won. + -- The boolean indicates whether they have + -- already been congratulated. + Won Bool + | -- | The player has completed certain "goals" that preclude + -- (via NOT prerequisites) the completion of all of the + -- required goals. + -- The boolean indicates whether they have + -- already been informed. + Unwinnable Bool + deriving (Show, Generic, FromJSON, ToJSON) + data WinCondition = -- | There is no winning condition. NoWinCondition - | -- | There are one or more objectives remaining that the player - -- has not yet accomplished. - WinConditions (NonEmpty Objective) - | -- | The player has won. The boolean indicates whether they have - -- already been congratulated. - Won Bool + | -- | NOTE: It is possible to continue to achieve "optional" objectives + -- even after the game has been won (or deemed unwinnable). + WinConditions WinStatus ObjectiveCompletion deriving (Show, Generic, FromJSON, ToJSON) makePrisms ''WinCondition @@ -260,6 +277,7 @@ data GameState = GameState , _winCondition :: WinCondition , _winSolution :: Maybe ProcessedTerm , _gameAchievements :: Map GameplayAchievement Attainment + , _announcementQueue :: Seq Announcement , _runStatus :: RunStatus , _robotMap :: IntMap Robot , -- A set of robots to consider for the next game tick. It is guaranteed to @@ -339,6 +357,13 @@ winSolution :: Lens' GameState (Maybe ProcessedTerm) -- | Map of in-game achievements that were attained gameAchievements :: Lens' GameState (Map GameplayAchievement Attainment) +-- | A queue of global announcments. +-- Note that this is distinct from the "messageQueue", +-- which is for messages emitted by robots. +-- +-- Note that we put the newest entry to the right. +announcementQueue :: Lens' GameState (Seq Announcement) + -- | The current 'RunStatus'. runStatus :: Lens' GameState RunStatus @@ -716,6 +741,7 @@ initGameState = do , -- This does not need to be initialized with anything, -- since the master list of achievements is stored in UIState _gameAchievements = mempty + , _announcementQueue = mempty , _runStatus = Running , _robotMap = IM.empty , _robotsByLocation = M.empty @@ -875,7 +901,12 @@ scenarioToGameState scenario userSeed toRun g = do (genRobots, wf) = buildWorld em (scenario ^. scenarioWorld) theWorld = W.newWorld . wf - theWinCondition = maybe NoWinCondition WinConditions (NE.nonEmpty (scenario ^. scenarioObjectives)) + theWinCondition = + maybe + NoWinCondition + (\x -> WinConditions Ongoing (ObjectiveCompletion (CompletionBuckets (NE.toList x) mempty mempty) mempty)) + (NE.nonEmpty (scenario ^. scenarioObjectives)) + initGensym = length robotList - 1 addRecipesWith f gRs = IM.unionWith (<>) (f $ scenario ^. scenarioRecipes) (g ^. gRs) diff --git a/src/Swarm/Game/Step.hs b/src/Swarm/Game/Step.hs index 1edc4a8511..3e5124699f 100644 --- a/src/Swarm/Game/Step.hs +++ b/src/Swarm/Game/Step.hs @@ -25,7 +25,7 @@ import Control.Effect.Error import Control.Effect.Lens import Control.Effect.Lift import Control.Lens as Lens hiding (Const, from, parts, use, uses, view, (%=), (+=), (.=), (<+=), (<>=)) -import Control.Monad (forM, forM_, guard, msum, unless, when) +import Control.Monad (foldM, forM, forM_, guard, msum, unless, when) import Data.Array (bounds, (!)) import Data.Bifunctor (second) import Data.Bool (bool) @@ -38,11 +38,10 @@ import Data.IntMap qualified as IM import Data.IntSet qualified as IS import Data.List (find, sortOn) import Data.List qualified as L -import Data.List.NonEmpty (NonEmpty ((:|))) -import Data.List.NonEmpty qualified as NE import Data.Map qualified as M import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, listToMaybe) import Data.Ord (Down (Down)) +import Data.Sequence ((><)) import Data.Sequence qualified as Seq import Data.Set (Set) import Data.Set qualified as S @@ -58,7 +57,8 @@ import Swarm.Game.Entity qualified as E import Swarm.Game.Exception import Swarm.Game.Recipe import Swarm.Game.Robot -import Swarm.Game.Scenario (objectiveCondition) +import Swarm.Game.Scenario.Objective qualified as OB +import Swarm.Game.Scenario.Objective.WinCheck qualified as WC import Swarm.Game.State import Swarm.Game.Value import Swarm.Game.World qualified as W @@ -132,39 +132,123 @@ gameTick = do -- Possibly see if the winning condition for the current objective is met. wc <- use winCondition case wc of - WinConditions (obj :| objs) -> do + WinConditions winState oc -> do g <- get @GameState - - -- Execute the win condition check *hypothetically*: i.e. in a - -- fresh CESK machine, using a copy of the current game state. - v <- runThrow @Exn . evalState @GameState g $ evalPT (obj ^. objectiveCondition) - let markWin = winCondition .= maybe (Won False) WinConditions (NE.nonEmpty objs) - case v of - -- Log exceptions in the message queue so we can check for them in tests - Left exn -> do - let h = hypotheticalRobot (Out VUnit emptyStore []) 0 - em <- use entityMap - m <- evalState @Robot h $ createLogEntry ErrorTrace (formatExn em exn) - emitMessage m - Right (VBool res) -> when res markWin - Right (VResult (VBool res) _env) -> when res markWin - Right val -> do - let h = hypotheticalRobot (Out VUnit emptyStore []) 0 - m <- - evalState @Robot h $ - createLogEntry ErrorTrace $ - T.unwords - [ "Non boolean value:" - , prettyValue val - , "real:" - , T.pack (show val) - ] - emitMessage m + em <- use entityMap + hypotheticalWinCheck em g winState oc _ -> return () -- Advance the game time by one. ticks += 1 +-- | An accumulator for folding over the incomplete +-- objectives to evaluate for their completion +data CompletionsWithExceptions = CompletionsWithExceptions + { exceptions :: [Text] + , completions :: ObjectiveCompletion + , completionAnnouncementQueue :: [OB.Objective] + -- ^ Upon completion, an objective is enqueued. + -- It is dequeued when displayed on the UI. + } + +-- | Execute the win condition check *hypothetically*: i.e. in a +-- fresh CESK machine, using a copy of the current game state. +-- +-- The win check is performed only on "active" goals; that is, +-- the goals that are currently unmet and have had all of their +-- prerequisites satisfied. +-- Note that it may be possible, while traversing through the +-- goal list, for one goal to be met earlier in the list that +-- happens to be a prerequisite later in the traversal. This +-- is why: +-- 1) We must not pre-filter the goals to be traversed based +-- on satisfied prerequisites (i.e. we cannot use the +-- "getActiveObjectives" function). +-- 2) The traversal order must be "reverse topological" order, so +-- that prerequisites are evaluated before dependent goals. +-- 3) The iteration needs to be a "fold", so that state is updated +-- after each element. +hypotheticalWinCheck :: + (Has (State GameState) sig m, Has (Lift IO) sig m) => + EntityMap -> + GameState -> + WinStatus -> + ObjectiveCompletion -> + m () +hypotheticalWinCheck em g ws oc = do + -- We can fully and accurately evaluate the new state of the objectives DAG + -- in a single pass, so long as we visit it in reverse topological order. + -- + -- N.B. The "reverse" is essential due to the re-population of the + -- "incomplete" goal list by cons-ing. + finalAccumulator <- + foldM foldFunc initialAccumulator $ + reverse incompleteGoals + + let newWinState = case ws of + Ongoing -> getNextWinState $ completions finalAccumulator + _ -> ws + + winCondition .= WinConditions newWinState (completions finalAccumulator) + announcementQueue %= (>< Seq.fromList (map ObjectiveCompleted $ completionAnnouncementQueue finalAccumulator)) + + mapM_ handleException $ exceptions finalAccumulator + where + getNextWinState comps + | WC.didWin comps = Won False + | WC.didLose comps = Unwinnable False + | otherwise = Ongoing + + (withoutIncomplete, incompleteGoals) = OB.extractIncomplete oc + initialAccumulator = CompletionsWithExceptions [] withoutIncomplete [] + + -- All of the "incomplete" goals have been emptied from the initial accumulator, and + -- these are what we iterate over with the fold. + -- Each iteration, we either place the goal back into the "incomplete" bucket, or + -- we determine that it has been met and place it into the "completed" bucket. + foldFunc (CompletionsWithExceptions exnTexts currentCompletions announcements) obj = do + v <- + if WC.isPrereqsSatisfied currentCompletions obj + then runThrow @Exn . evalState @GameState g $ evalPT $ obj ^. OB.objectiveCondition + else return $ Right $ VBool False + let simplified = simplifyResult v + return $ case simplified of + Left exnText -> + CompletionsWithExceptions + (exnText : exnTexts) + currentCompletions + announcements + Right boolResult -> + CompletionsWithExceptions + exnTexts + (modifyCompletions obj currentCompletions) + (modifyAnnouncements announcements) + where + (modifyCompletions, modifyAnnouncements) + | boolResult = (OB.addCompleted, (obj :)) + | WC.isUnwinnable currentCompletions obj = (OB.addUnwinnable, id) + | otherwise = (OB.addIncomplete, id) + + simplifyResult = \case + Left exn -> Left $ formatExn em exn + Right (VBool x) -> Right x + Right (VResult (VBool x) _env) -> Right x + Right val -> + Left $ + T.unwords + [ "Non boolean value:" + , prettyValue val + , "real:" + , T.pack (show val) + ] + + -- Log exceptions in the message queue so we can check for them in tests + handleException exnText = do + m <- evalState @Robot h $ createLogEntry ErrorTrace exnText + emitMessage m + where + h = hypotheticalRobot (Out VUnit emptyStore []) 0 + evalPT :: (Has (Lift IO) sig m, Has (Throw Exn) sig m, Has (State GameState) sig m) => ProcessedTerm -> diff --git a/src/Swarm/Game/World.hs b/src/Swarm/Game/World.hs index 07cdc94dee..cb523e15a5 100644 --- a/src/Swarm/Game/World.hs +++ b/src/Swarm/Game/World.hs @@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE TypeFamilies #-} -- | diff --git a/src/Swarm/Language/Capability.hs b/src/Swarm/Language/Capability.hs index 8146586959..8662902fa0 100644 --- a/src/Swarm/Language/Capability.hs +++ b/src/Swarm/Language/Capability.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DeriveAnyClass #-} + -- | -- Module : Swarm.Language.Capability -- Copyright : Brent Yorgey diff --git a/src/Swarm/Language/Requirement.hs b/src/Swarm/Language/Requirement.hs index de67e62492..a0665c45ab 100644 --- a/src/Swarm/Language/Requirement.hs +++ b/src/Swarm/Language/Requirement.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DeriveAnyClass #-} + -- | -- Module : Swarm.Language.Requirement -- Copyright : Brent Yorgey diff --git a/src/Swarm/Language/Syntax.hs b/src/Swarm/Language/Syntax.hs index ea9606d3ec..678c19ecd4 100644 --- a/src/Swarm/Language/Syntax.hs +++ b/src/Swarm/Language/Syntax.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} diff --git a/src/Swarm/Language/Typed.hs b/src/Swarm/Language/Typed.hs index ddd0aa8e02..d175e3f68c 100644 --- a/src/Swarm/Language/Typed.hs +++ b/src/Swarm/Language/Typed.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE TemplateHaskell #-} module Swarm.Language.Typed (Typed (..), value, polytype, requires) where diff --git a/src/Swarm/Language/Types.hs b/src/Swarm/Language/Types.hs index da3f0f69ad..aac885201f 100644 --- a/src/Swarm/Language/Types.hs +++ b/src/Swarm/Language/Types.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} diff --git a/src/Swarm/TUI/Attr.hs b/src/Swarm/TUI/Attr.hs index a7132e3d6e..77a115cb9d 100644 --- a/src/Swarm/TUI/Attr.hs +++ b/src/Swarm/TUI/Attr.hs @@ -40,6 +40,7 @@ module Swarm.TUI.Attr ( infoAttr, boldAttr, dimAttr, + magentaAttr, cyanAttr, yellowAttr, blueAttr, @@ -83,6 +84,7 @@ swarmAttrMap = , (blueAttr, fg V.blue) , (yellowAttr, fg V.yellow) , (cyanAttr, fg V.cyan) + , (magentaAttr, fg V.magenta) , -- Default attribute (defAttr, V.defAttr) ] @@ -161,12 +163,13 @@ dimAttr = attrName "dim" defAttr = attrName "def" -- | Some basic colors used in TUI. -redAttr, greenAttr, blueAttr, yellowAttr, cyanAttr :: AttrName +redAttr, greenAttr, blueAttr, yellowAttr, cyanAttr, magentaAttr :: AttrName redAttr = attrName "red" greenAttr = attrName "green" blueAttr = attrName "blue" yellowAttr = attrName "yellow" cyanAttr = attrName "cyan" +magentaAttr = attrName "magenta" instance ToJSON AttrName where toJSON = toJSON . head . attrNameComponents diff --git a/src/Swarm/TUI/Controller.hs b/src/Swarm/TUI/Controller.hs index adb58afa37..cc014dbea0 100644 --- a/src/Swarm/TUI/Controller.hs +++ b/src/Swarm/TUI/Controller.hs @@ -53,6 +53,7 @@ import Control.Monad.Extra (whenJust) import Control.Monad.State import Data.Bits import Data.Either (isRight) +import Data.Foldable (toList) import Data.Int (Int32) import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty qualified as NE @@ -68,6 +69,8 @@ import Linear import Swarm.Game.CESK (cancel, emptyStore, initMachine) import Swarm.Game.Entity hiding (empty) import Swarm.Game.Robot +import Swarm.Game.Scenario.Objective.Presentation.Model +import Swarm.Game.Scenario.Objective.Presentation.Render qualified as GR import Swarm.Game.ScenarioInfo import Swarm.Game.State import Swarm.Game.Step (gameTick) @@ -251,7 +254,8 @@ handleMainEvent ev = do -- ctrl-q works everywhere ControlChar 'q' -> case s ^. gameState . winCondition of - Won _ -> toggleModal WinModal + WinConditions (Won _) _ -> toggleModal WinModal + WinConditions (Unwinnable _) _ -> toggleModal LoseModal _ -> toggleModal QuitModal VtyEvent (V.EvResize _ _) -> invalidateCacheEntry WorldCache Key V.KEsc @@ -275,9 +279,10 @@ handleMainEvent ev = do FKey 5 | not (null (s ^. gameState . messageNotifications . notificationsContent)) -> do toggleModal MessagesModal gameState . lastSeenMessageTime .= s ^. gameState . ticks - ControlChar 'g' -> case s ^. uiState . uiGoal of - Just g | g /= [] -> toggleModal (GoalModal g) - _ -> continueWithoutRedraw + ControlChar 'g' -> + if hasAnythingToShow $ s ^. uiState . uiGoal . goalsContent + then toggleModal GoalModal + else continueWithoutRedraw MetaChar 'h' -> do t <- liftIO $ getTime Monotonic h <- use $ uiState . uiHideRobotsUntil @@ -398,8 +403,14 @@ handleModalEvent = \case Brick.zoom (uiState . uiModal . _Just . modalDialog) (handleDialogEvent ev) modal <- preuse $ uiState . uiModal . _Just . modalType case modal of + Just GoalModal -> do + lw <- use $ uiState . uiGoal . listWidget + newList <- refreshList lw + uiState . uiGoal . listWidget .= newList Just _ -> handleInfoPanelEvent modalScroll (VtyEvent ev) _ -> return () + where + refreshList lw = nestEventM' lw $ BL.handleListEvent ev -- | Write the @ScenarioInfo@ out to disk when exiting a game. saveScenarioInfoOnQuit :: (MonadIO m, MonadState AppState m) => m () @@ -415,7 +426,10 @@ saveScenarioInfoOnQuit = do gs <- use $ gameState . scenarios p <- liftIO $ normalizeScenarioPath gs p' t <- liftIO getZonedTime - won <- isJust <$> preuse (gameState . winCondition . _Won) + wc <- use $ gameState . winCondition + let won = case wc of + WinConditions (Won _) _ -> True + _ -> False ts <- use $ gameState . ticks let currentScenarioInfo :: Traversal' AppState ScenarioInfo currentScenarioInfo = gameState . scenarios . scenarioItemByPath p . _SISingle . _2 @@ -701,35 +715,72 @@ updateUI = do oldBotMore <- uiState . uiMoreInfoBot <<.= botMore return $ oldTopMore /= topMore || oldBotMore /= botMore - -- Decide whether we need to update the current goal text, and pop - -- up a modal dialog. - curGoal <- use (uiState . uiGoal) - newGoal <- - preuse (gameState . winCondition . _WinConditions . _NonEmpty . _1 . objectiveGoal) - - let goalUpdated = curGoal /= newGoal - when goalUpdated $ do - uiState . uiGoal .= newGoal - case newGoal of - Just goal | goal /= [] -> do - toggleModal (GoalModal goal) - _ -> return () + goalOrWinUpdated <- doGoalUpdates - -- 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 - toggleModal WinModal - uiState . uiMenu %= advanceMenu - return True - _ -> return False - - let redraw = g ^. needsRedraw || inventoryUpdated || replUpdated || logUpdated || infoPanelUpdated || goalUpdated || winModalUpdated + let redraw = g ^. needsRedraw || inventoryUpdated || replUpdated || logUpdated || infoPanelUpdated || goalOrWinUpdated pure redraw +-- | Either pops up the updated Goals modal +-- or pops up the Congratulations (Win) modal, or pops +-- up the Condolences (Lose) modal. +-- The Win modal will take precendence if the player +-- has met the necessary conditions to win the game. +-- +-- If the player chooses to "Keep Playing" from the Win modal, the +-- updated Goals will then immediately appear. +-- This is desirable for: +-- * feedback as to the final goal the player accomplished, +-- * as a summary of all of the goals of the game +-- * shows the player more "optional" goals they can continue to pursue +doGoalUpdates :: EventM Name AppState Bool +doGoalUpdates = do + curGoal <- use (uiState . uiGoal . goalsContent) + isCheating <- use (uiState . uiCheatMode) + curWinCondition <- use (gameState . winCondition) + announcementsSeq <- use (gameState . announcementQueue) + let announcementsList = toList announcementsSeq + + -- Decide whether we need to update the current goal text and pop + -- up a modal dialog. + case curWinCondition of + NoWinCondition -> return False + WinConditions (Unwinnable False) x -> do + -- This clears the "flag" that the Lose dialog needs to pop up + gameState . winCondition .= WinConditions (Unwinnable True) x + openModal LoseModal + + uiState . uiMenu %= advanceMenu + return True + WinConditions (Won False) x -> do + -- This clears the "flag" that the Win dialog needs to pop up + gameState . winCondition .= WinConditions (Won True) x + openModal WinModal + + uiState . uiMenu %= advanceMenu + return True + WinConditions _ oc -> do + let newGoalTracking = GoalTracking announcementsList $ constructGoalMap isCheating oc + -- The "uiGoal" field is intialized with empty members, so we know that + -- this will be the first time showing it if it will be nonempty after previously + -- being empty. + isFirstGoalDisplay = hasAnythingToShow newGoalTracking && not (hasAnythingToShow curGoal) + goalWasUpdated = isFirstGoalDisplay || not (null announcementsList) + + -- Decide whether to show a pop-up modal congratulating the user on + -- successfully completing the current challenge. + when goalWasUpdated $ do + -- The "uiGoal" field is necessary at least to "persist" the data that is needed + -- if the player chooses to later "recall" the goals dialog with CTRL+g. + uiState . uiGoal .= GoalDisplay newGoalTracking (GR.makeListWidget newGoalTracking) + + -- This clears the "flag" that indicate that the goals dialog needs to be + -- automatically popped up. + gameState . announcementQueue .= mempty + + openModal GoalModal + + return goalWasUpdated + -- | Make sure all tiles covering the visible part of the world are -- loaded. loadVisibleRegion :: EventM Name AppState () diff --git a/src/Swarm/TUI/Model/Achievement/Definitions.hs b/src/Swarm/TUI/Model/Achievement/Definitions.hs index e7952b6e4e..a8df44c2c7 100644 --- a/src/Swarm/TUI/Model/Achievement/Definitions.hs +++ b/src/Swarm/TUI/Model/Achievement/Definitions.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DeriveAnyClass #-} + module Swarm.TUI.Model.Achievement.Definitions where import Data.Aeson @@ -10,18 +12,18 @@ data ExpectedEffort | Easy | Moderate | Gruelling - deriving (Eq, Ord, Show, Bounded, Enum) + deriving (Eq, Ord, Show, Bounded, Enum, Generic, FromJSON, ToJSON) data Quotation = Quotation { attribution :: Text , content :: Text } - deriving (Show) + deriving (Show, Generic, FromJSON, ToJSON) data FlavorText = Freeform Text | FTQuotation Quotation - deriving (Show) + deriving (Show, Generic, FromJSON, ToJSON) data AchievementInfo = AchievementInfo { title :: Text @@ -41,7 +43,7 @@ data AchievementInfo = AchievementInfo -- ^ Hides the attainment process until after the achievement is attained. -- Best when the title + elaboration constitute a good clue. } - deriving (Show) + deriving (Show, Generic, FromJSON, ToJSON) data CategorizedAchievement = GlobalAchievement GlobalAchievement diff --git a/src/Swarm/TUI/Model/Menu.hs b/src/Swarm/TUI/Model/Menu.hs index 0117a075c7..bbc3043064 100644 --- a/src/Swarm/TUI/Model/Menu.hs +++ b/src/Swarm/TUI/Model/Menu.hs @@ -41,10 +41,11 @@ data ModalType | MessagesModal | RobotsModal | WinModal + | LoseModal | QuitModal | KeepPlayingModal | DescriptionModal Entity - | GoalModal [Text] + | GoalModal deriving (Show) data ButtonSelection diff --git a/src/Swarm/TUI/Model/Name.hs b/src/Swarm/TUI/Model/Name.hs index e591424aa2..66d8ee9fa6 100644 --- a/src/Swarm/TUI/Model/Name.hs +++ b/src/Swarm/TUI/Model/Name.hs @@ -30,6 +30,8 @@ data Name MenuList | -- | The list of achievements. AchievementList + | -- | The list of goals/ojbectives. + ObjectivesList | -- | The list of scenario choices. ScenarioList | -- | The scrollable viewport for the info panel. diff --git a/src/Swarm/TUI/Model/StateUpdate.hs b/src/Swarm/TUI/Model/StateUpdate.hs index 019490d61c..6aadedea77 100644 --- a/src/Swarm/TUI/Model/StateUpdate.hs +++ b/src/Swarm/TUI/Model/StateUpdate.hs @@ -19,6 +19,7 @@ import Data.Maybe (fromMaybe, isJust) import Data.Text (Text) import Data.Time (ZonedTime, getZonedTime) import Swarm.Game.Scenario (loadScenario) +import Swarm.Game.Scenario.Objective.Presentation.Model (emptyGoalDisplay) import Swarm.Game.ScenarioInfo ( ScenarioInfo (..), ScenarioInfoPair, @@ -126,7 +127,7 @@ scenarioToUIState siPair u = do return $ u & uiPlaying .~ True - & uiGoal .~ Nothing + & uiGoal .~ emptyGoalDisplay & uiFocusRing .~ initFocusRing & uiInventory .~ Nothing & uiInventorySort .~ defaultSortOptions diff --git a/src/Swarm/TUI/Model/UI.hs b/src/Swarm/TUI/Model/UI.hs index 5a427753a6..e607ed71f0 100644 --- a/src/Swarm/TUI/Model/UI.hs +++ b/src/Swarm/TUI/Model/UI.hs @@ -6,6 +6,7 @@ module Swarm.TUI.Model.UI ( UIState (..), + GoalDisplay (..), uiMenu, uiPlaying, uiCheatMode, @@ -54,6 +55,7 @@ import Data.Map (Map) import Data.Map qualified as M import Data.Text (Text) import Data.Text qualified as T +import Swarm.Game.Scenario.Objective.Presentation.Model import Swarm.Game.ScenarioInfo ( ScenarioInfoPair, ) @@ -88,7 +90,7 @@ data UIState = UIState , _uiScrollToEnd :: Bool , _uiError :: Maybe Text , _uiModal :: Maybe Modal - , _uiGoal :: Maybe [Text] + , _uiGoal :: GoalDisplay , _uiAchievements :: Map CategorizedAchievement Attainment , _uiShowFPS :: Bool , _uiShowZero :: Bool @@ -168,7 +170,7 @@ uiModal :: Lens' UIState (Maybe Modal) -- | Status of the scenario goal: whether there is one, and whether it -- has been displayed to the user initially. -uiGoal :: Lens' UIState (Maybe [Text]) +uiGoal :: Lens' UIState GoalDisplay -- | Map of achievements that were attained uiAchievements :: Lens' UIState (Map CategorizedAchievement Attainment) @@ -280,7 +282,7 @@ initUIState showMainMenu cheatMode = do , _uiScrollToEnd = False , _uiError = Nothing , _uiModal = Nothing - , _uiGoal = Nothing + , _uiGoal = emptyGoalDisplay , _uiAchievements = M.fromList $ map (view achievement &&& id) achievements , _uiShowFPS = False , _uiShowZero = True diff --git a/src/Swarm/TUI/View.hs b/src/Swarm/TUI/View.hs index 600e3d9230..39276c8e3a 100644 --- a/src/Swarm/TUI/View.hs +++ b/src/Swarm/TUI/View.hs @@ -78,6 +78,8 @@ import Swarm.Game.Entity as E import Swarm.Game.Recipe import Swarm.Game.Robot import Swarm.Game.Scenario (scenarioAuthor, scenarioDescription, scenarioName, scenarioObjectives) +import Swarm.Game.Scenario.Objective.Presentation.Model (goalsContent, hasAnythingToShow) +import Swarm.Game.Scenario.Objective.Presentation.Render qualified as GR import Swarm.Game.ScenarioInfo ( ScenarioItem (..), ScenarioStatus (..), @@ -468,9 +470,17 @@ drawModal s = \case CommandsModal -> commandsListWidget (s ^. gameState) MessagesModal -> availableListWidget (s ^. gameState) MessageList WinModal -> padBottom (Pad 1) $ hCenter $ txt "Congratulations!" + LoseModal -> + padBottom (Pad 1) $ + vBox $ + map + (hCenter . txt) + [ "Condolences!" + , "This scenario is no longer winnable." + ] DescriptionModal e -> descriptionWidget s e QuitModal -> padBottom (Pad 1) $ hCenter $ txt (quitMsg (s ^. uiState . uiMenu)) - GoalModal g -> padLeftRight 1 (displayParagraphs g) + GoalModal -> padLeftRight 1 $ GR.renderGoalsDisplay (s ^. uiState . uiGoal) KeepPlayingModal -> padLeftRight 1 (displayParagraphs ["Have fun! Hit Ctrl-Q whenever you're ready to proceed to the next challenge or return to the menu."]) robotsListWidget :: AppState -> Widget Name @@ -755,9 +765,7 @@ drawKeyMenu s = viewingBase = (s ^. gameState . viewCenterRule) == VCRobot 0 creative = s ^. gameState . creativeMode cheat = s ^. uiState . uiCheatMode - goal = case s ^. uiState . uiGoal of - Just g | g /= [] -> True - _ -> False + goal = hasAnythingToShow $ s ^. uiState . uiGoal . goalsContent showZero = s ^. uiState . uiShowZero inventorySort = s ^. uiState . uiInventorySort ctrlMode = s ^. uiState . uiREPL . replControlMode @@ -1156,12 +1164,3 @@ drawREPL s = vBox $ latestHistory <> [currentPrompt] base = s ^. gameState . robotMap . at 0 fmt (REPLEntry e) = txt $ "> " <> e fmt (REPLOutput t) = txt t - ------------------------------------------------------------- --- Utility ------------------------------------------------------------- - --- | Display a list of text-wrapped paragraphs with one blank line after --- each. -displayParagraphs :: [Text] -> Widget Name -displayParagraphs = vBox . map (padBottom (Pad 1) . txtWrap) diff --git a/src/Swarm/TUI/View/Util.hs b/src/Swarm/TUI/View/Util.hs index aca53e7fc0..696643a0f8 100644 --- a/src/Swarm/TUI/View/Util.hs +++ b/src/Swarm/TUI/View/Util.hs @@ -55,6 +55,21 @@ generateModal s mt = Modal mt (dialog (Just title) buttons (maxModalWindowWidth ) , sum (map length [nextMsg, stopMsg, continueMsg]) + 32 ) + LoseModal -> + let stopMsg = fromMaybe "Return to the menu" haltingMessage + continueMsg = "Keep playing" + maybeStartOver = sequenceA ("Start over", StartOverButton currentSeed <$> currentScenario) + in ( "" + , Just + ( 0 + , catMaybes + [ Just (stopMsg, QuitButton) + , maybeStartOver + , Just (continueMsg, KeepPlayingButton) + ] + ) + , sum (map length [stopMsg, continueMsg]) + 32 + ) DescriptionModal e -> (descriptionTitle e, Nothing, descriptionWidth) QuitModal -> let stopMsg = fromMaybe ("Quit to" ++ maybe "" (" " ++) (into @String <$> curMenuName s) ++ " menu") haltingMessage @@ -70,11 +85,11 @@ generateModal s mt = Modal mt (dialog (Just title) buttons (maxModalWindowWidth ) , T.length (quitMsg (s ^. uiState . uiMenu)) + 4 ) - GoalModal _ -> + GoalModal -> let goalModalTitle = case currentScenario of Nothing -> "Goal" Just (scenario, _) -> scenario ^. scenarioName - in (" " <> T.unpack goalModalTitle <> " ", Nothing, 80) + in (" " <> T.unpack goalModalTitle <> " ", Nothing, descriptionWidth) KeepPlayingModal -> ("", Just (0, [("OK", CancelButton)]), 80) -- | Render the type of the current REPL input to be shown to the user. @@ -102,3 +117,8 @@ quitMsg m = "Are you sure you want to " <> quitAction <> "? All progress on this quitAction = case m of NoMenu -> "quit" _ -> "return to the menu" + +-- | Display a list of text-wrapped paragraphs with one blank line after +-- each. +displayParagraphs :: [Text] -> Widget Name +displayParagraphs = vBox . map (padBottom (Pad 1) . txtWrap) diff --git a/src/Swarm/Util.hs b/src/Swarm/Util.hs index d749e986a9..32bb586d77 100644 --- a/src/Swarm/Util.hs +++ b/src/Swarm/Util.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskellQuotes #-} {-# OPTIONS_GHC -fno-warn-orphans #-} diff --git a/src/Swarm/Util/Location.hs b/src/Swarm/Util/Location.hs index a279d9783c..8633bc70b7 100644 --- a/src/Swarm/Util/Location.hs +++ b/src/Swarm/Util/Location.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE PatternSynonyms #-} {-# OPTIONS_GHC -fno-warn-orphans #-} diff --git a/src/Swarm/Web.hs b/src/Swarm/Web.hs index 6c18751341..d4ace705ca 100644 --- a/src/Swarm/Web.hs +++ b/src/Swarm/Web.hs @@ -34,6 +34,10 @@ import Network.Wai qualified import Network.Wai.Handler.Warp qualified as Warp import Servant import Swarm.Game.Robot +import Swarm.Game.Scenario.Objective +import Swarm.Game.Scenario.Objective.Graph +import Swarm.Game.Scenario.Objective.Presentation.Model +import Swarm.Game.Scenario.Objective.WinCheck import Swarm.Game.State import Swarm.TUI.Model import Swarm.TUI.Model.UI @@ -42,12 +46,22 @@ import System.Timeout (timeout) type SwarmApi = "robots" :> Get '[JSON] [Robot] :<|> "robot" :> Capture "id" Int :> Get '[JSON] (Maybe Robot) + :<|> "goals" :> "prereqs" :> Get '[JSON] [PrereqSatisfaction] + :<|> "goals" :> "active" :> Get '[JSON] [Objective] + :<|> "goals" :> "graph" :> Get '[JSON] (Maybe GraphInfo) + :<|> "goals" :> "uigoal" :> Get '[JSON] GoalTracking + :<|> "goals" :> Get '[JSON] WinCondition :<|> "repl" :> "history" :> "full" :> Get '[JSON] [T.Text] mkApp :: IORef AppState -> Servant.Server SwarmApi mkApp appStateRef = robotsHandler :<|> robotHandler + :<|> prereqsHandler + :<|> activeGoalsHandler + :<|> goalsGraphHandler + :<|> uiGoalHandler + :<|> goalsHandler :<|> replHandler where robotsHandler = do @@ -56,6 +70,27 @@ mkApp appStateRef = robotHandler rid = do appState <- liftIO (readIORef appStateRef) pure $ IM.lookup rid (appState ^. gameState . robotMap) + prereqsHandler = do + appState <- liftIO (readIORef appStateRef) + case appState ^. gameState . winCondition of + WinConditions _winState oc -> return $ getSatisfaction oc + _ -> return [] + activeGoalsHandler = do + appState <- liftIO (readIORef appStateRef) + case appState ^. gameState . winCondition of + WinConditions _winState oc -> return $ getActiveObjectives oc + _ -> return [] + goalsGraphHandler = do + appState <- liftIO (readIORef appStateRef) + return $ case appState ^. gameState . winCondition of + WinConditions _winState oc -> Just $ makeGraphInfo oc + _ -> Nothing + uiGoalHandler = do + appState <- liftIO (readIORef appStateRef) + return $ appState ^. uiState . uiGoal . goalsContent + goalsHandler = do + appState <- liftIO (readIORef appStateRef) + return $ appState ^. gameState . winCondition replHandler = do appState <- liftIO (readIORef appStateRef) let replHistorySeq = appState ^. uiState . uiREPL . replHistory . replSeq diff --git a/swarm.cabal b/swarm.cabal index 5869f3f501..1d154db8dc 100644 --- a/swarm.cabal +++ b/swarm.cabal @@ -57,7 +57,6 @@ common ghc2021-extensions ghc-options: -Wprepositive-qualified-module default-extensions: BangPatterns - DeriveAnyClass DeriveDataTypeable DeriveFunctor DeriveGeneric @@ -81,7 +80,8 @@ common ghc2021-extensions library import: stan-config, common, ghc2021-extensions - exposed-modules: Swarm.Language.Context + exposed-modules: Data.BoolExpr + Swarm.Language.Context Swarm.Language.Types Swarm.Language.Syntax Swarm.Language.Capability @@ -98,6 +98,13 @@ library Swarm.Game.CESK Swarm.Game.Scenario Swarm.Game.Scenario.Cell + Swarm.Game.Scenario.Objective.Logic + Swarm.Game.Scenario.Objective.Graph + Swarm.Game.Scenario.Objective.Presentation.Model + Swarm.Game.Scenario.Objective.Presentation.Render + Swarm.Game.Scenario.Objective.Simplify + Swarm.Game.Scenario.Objective.Validation + Swarm.Game.Scenario.Objective.WinCheck Swarm.Game.Scenario.Objective Swarm.Game.Scenario.RobotLookup Swarm.Game.Scenario.WorldDescription @@ -226,6 +233,7 @@ test-suite swarm-unit TestNotification TestLanguagePipeline TestPretty + TestBoolExpr TestUtil build-depends: tasty >= 0.10 && < 1.5, diff --git a/test/integration/Main.hs b/test/integration/Main.hs index b9cb7d665a..10b7191413 100644 --- a/test/integration/Main.hs +++ b/test/integration/Main.hs @@ -13,6 +13,7 @@ import Data.Char (isSpace) import Data.Containers.ListUtils (nubOrd) import Data.Foldable (Foldable (toList), find) import Data.IntSet qualified as IS +import Data.List (partition) import Data.Map qualified as M import Data.Maybe (isJust) import Data.Text (Text) @@ -27,7 +28,8 @@ import Swarm.Game.Robot (defReqs, leText, machine, robotContext, robotLog, waiti import Swarm.Game.Scenario (Scenario) import Swarm.Game.State ( GameState, - WinCondition (Won), + WinCondition (WinConditions), + WinStatus (Won), activeRobots, baseRobot, initGameStateForScenario, @@ -44,16 +46,22 @@ import Swarm.Language.Pipeline (ProcessedTerm (..), processTerm) import Swarm.Util.Yaml (decodeFileEitherE) import System.Directory (doesDirectoryExist, doesFileExist, listDirectory) import System.Environment (getEnvironment) +import System.FilePath (splitDirectories) import System.FilePath.Posix (takeExtension, ()) import System.Timeout (timeout) import Test.Tasty (TestTree, defaultMain, testGroup) +import Test.Tasty.ExpectedFailure (expectFailBecause) import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, testCase) import Witch (into) +isUnparseableTest :: (FilePath, String) -> Bool +isUnparseableTest (fp, _) = "_Validation" `elem` splitDirectories fp + main :: IO () main = do examplePaths <- acquire "example" "sw" scenarioPaths <- acquire "data/scenarios" "yaml" + let (unparseableScenarios, parseableScenarios) = partition isUnparseableTest scenarioPaths scenarioPrograms <- acquire "data/scenarios" "sw" ci <- any (("CI" ==) . fst) <$> getEnvironment entities <- loadEntities @@ -65,7 +73,8 @@ main = do "Tests" [ exampleTests examplePaths , exampleTests scenarioPrograms - , scenarioTests em scenarioPaths + , scenarioParseTests em parseableScenarios + , scenarioParseInvalidTests em unparseableScenarios , testScenarioSolution ci em , testEditorFiles ] @@ -80,8 +89,14 @@ exampleTest (path, fileContent) = where value = processTerm $ into @Text fileContent -scenarioTests :: EntityMap -> [(FilePath, String)] -> TestTree -scenarioTests em inputs = testGroup "Test scenarios" (map (scenarioTest em) inputs) +scenarioParseTests :: EntityMap -> [(FilePath, String)] -> TestTree +scenarioParseTests em inputs = testGroup "Test scenarios" (map (scenarioTest em) inputs) + +scenarioParseInvalidTests :: EntityMap -> [(FilePath, String)] -> TestTree +scenarioParseInvalidTests em inputs = + testGroup + "Parse Validation Test scenarios" + (map (expectFailBecause "Invalid scenario file" . scenarioTest em) inputs) scenarioTest :: EntityMap -> (FilePath, String) -> TestTree scenarioTest em (path, _) = @@ -253,7 +268,7 @@ testScenarioSolution _ci _em = w <- use winCondition b <- gets badErrorsInLogs when (null b) $ case w of - Won _ -> return () + WinConditions (Won _) _ -> return () _ -> gameTick >> playUntilWin noBadErrors :: GameState -> Assertion diff --git a/test/unit/Main.hs b/test/unit/Main.hs index 4a70890d8f..af0cc4c19a 100644 --- a/test/unit/Main.hs +++ b/test/unit/Main.hs @@ -20,6 +20,7 @@ import Test.Tasty.QuickCheck ( testProperty, (==>), ) +import TestBoolExpr (testBoolExpr) import TestEval (testEval) import TestInventory (testInventory) import TestLanguagePipeline (testLanguagePipeline) @@ -41,6 +42,7 @@ tests g = "Tests" [ testLanguagePipeline , testPrettyConst + , testBoolExpr , testEval g , testModel , testInventory diff --git a/test/unit/TestBoolExpr.hs b/test/unit/TestBoolExpr.hs new file mode 100644 index 0000000000..834d9ca931 --- /dev/null +++ b/test/unit/TestBoolExpr.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Boolean expression unit tests +module TestBoolExpr where + +import Data.BoolExpr qualified as BE +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.Set qualified as Set +import Swarm.Game.Scenario.Objective.Logic +import Swarm.Game.Scenario.Objective.Simplify qualified as Simplify +import Swarm.Game.Scenario.Objective.WinCheck qualified as WC +import Test.Tasty +import Test.Tasty.HUnit + +testBoolExpr :: TestTree +testBoolExpr = + testGroup + "Boolean evaluation" + [ testGroup + "Expression simplification" + [ testGroup + "Return true if the expression can be simplified to False" + [ testGroup + "Effect of constant literals" + [ testCase + "False input via single literal" + $ expectTrue BE.BFalse + , testCase + "True input via composed literals" + $ expectFalse BE.BTrue + , testCase + "False input via composed literals" + $ expectTrue + $ BE.BOr BE.BFalse BE.BFalse + , testCase + "True input via composed literals" + $ expectFalse + $ BE.BOr BE.BFalse BE.BTrue + , testCase + "Constant OR'd with False" + $ expectFalse + $ BE.BOr BE.BFalse (BE.BConst (BE.Positive "foo")) + , testCase + "Constant OR'd with True" + $ expectFalse + $ BE.BOr (BE.BConst (BE.Positive "foo")) BE.BTrue + , testCase + "Constant AND'd with False" + $ expectTrue + $ BE.BAnd BE.BFalse (BE.BConst (BE.Positive "foo")) + , testCase + "Constant AND'd with True" + $ expectFalse + $ BE.BAnd (BE.BConst (BE.Positive "foo")) BE.BTrue + , testCase + "Nested Constants AND'd with False within OR" + $ expectTrue + $ BE.BOr + (BE.BAnd BE.BFalse (BE.BConst (BE.Positive "foo"))) + (BE.BAnd (BE.BConst (BE.Positive "bar")) BE.BFalse) + , testCase + "Deeply nested Constants AND'd with False within OR with multiple negations" + $ expectTrue + $ BE.BOr + (BE.BAnd (BE.BNot BE.BTrue) (BE.BNot (BE.BNot (BE.BNot (BE.BConst (BE.Positive "foo")))))) + (BE.BAnd (BE.BConst (BE.Positive "bar")) (BE.BNot (BE.BNot BE.BFalse))) + ] + , testGroup + "Effect of contradicting named constants" + [ testCase + "via NOT operator" + $ expectTrue + $ BE.BAnd (BE.BNot (BE.BConst (BE.Positive "foo"))) (BE.BConst (BE.Positive "foo")) + , testCase + "via signedness" + $ expectTrue + $ BE.BAnd (BE.BConst (BE.Positive "foo")) (BE.BConst (BE.Negative "foo")) + ] + ] + ] + , testGroup + "Prerequisite expressions" + [ testCase + "A negated goal is completed" + $ assertBool "Should have returned true" + $ WC.isUnwinnablePrereq (Set.singleton "b") demoPrereqs + , testCase + "A non-negated goal is completed" + $ assertBool "Should have returned false" + $ not + $ WC.isUnwinnablePrereq (Set.singleton "c") demoPrereqs + ] + ] + where + expectTrue, expectFalse :: BE.BoolExpr String -> Assertion + expectTrue = assertBool "Should have returned true" . Simplify.cannotBeTrue + expectFalse = assertBool "Should have returned false" . not . Simplify.cannotBeTrue + + demoPrereqs :: Prerequisite ObjectiveLabel + demoPrereqs = + And $ + Id "a" + :| [Not (Id "b"), Id "c"]