mirror of
https://github.com/swarm-game/swarm.git
synced 2024-08-16 18:10:23 +03:00
Boolean expressions of objective prerequisites (#927)
Closes #795    ## Tasks - [x] Vendor a subset of the `boolexpr` package - [x] New display logic for parallel goals - [x] Add a check for whether winning is impossible (due to a "not" prerequisite being achieved) - [x] Add a "Lose" dialog analogous to the "Win" dialog - [x] Validate no dependency cycles in prerequisites specs - [x] Add tests for negative validation result from scenario parsing - [x] Web API to inspect status of incomplete, completed, optional, and prerequisite objectives - [x] Update all of the multi-goal scenarios to use prerequisites ## For follow-up PRs: - [ ] Upload new GHC8-compatible version of `boolexpr` to Hackage (perhaps [take over the package](https://wiki.haskell.org/Taking_over_a_package)?) - [ ] Add prerequisites and its logical operators to JSON schema - [ ] Reverse topological sort of goals before evaluation, with a test that demonstrates necessity - [ ] Automatically skip over the header rows when navigating the Goals list - [ ] Add indicators for optional and hidden goals - [ ] New Challenge for strategizing optional and mutually-exclusive goals
This commit is contained in:
Karl Ostmo
GitHub
parent
1678b49a52
commit
b80503f16e
1
.gitignore
vendored
1
.gitignore
vendored
@ -15,6 +15,7 @@ stan.html
|
||||
|
||||
.swarm_history
|
||||
|
||||
*.orig
|
||||
*.aux
|
||||
*.log
|
||||
docs/ott/*.tex
|
||||
|
||||
@ -5,7 +5,9 @@ description: |
|
||||
Start a wool industry from the local fauna.
|
||||
creative: false
|
||||
objectives:
|
||||
- goal:
|
||||
- id: enclose_sheep
|
||||
teaser: Paddock sheep
|
||||
goal:
|
||||
- |
|
||||
You've homesteaded on a small island in the ocean.
|
||||
It's time to gather resources to trade.
|
||||
@ -274,7 +276,9 @@ objectives:
|
||||
} {
|
||||
return false;
|
||||
}
|
||||
- goal:
|
||||
- id: feed_sheep
|
||||
teaser: Feed sheep
|
||||
goal:
|
||||
- |
|
||||
Safe! Your sheep are now hungry.
|
||||
Offer them something tasty and you may be rewarded.
|
||||
@ -311,6 +315,7 @@ objectives:
|
||||
end;
|
||||
|
||||
anySheep (has "clover") 3;
|
||||
prerequisite: enclose_sheep
|
||||
- goal:
|
||||
- |
|
||||
Yum! Contented, well-fed sheep may drop wool.
|
||||
@ -323,6 +328,7 @@ objectives:
|
||||
as base {
|
||||
has "sweater";
|
||||
};
|
||||
prerequisite: feed_sheep
|
||||
robots:
|
||||
- name: base
|
||||
dir: [0, 1]
|
||||
|
||||
@ -54,7 +54,9 @@ robots:
|
||||
program: |
|
||||
run "scenarios/Challenges/_bucket-brigade/powerplant.sw"
|
||||
objectives:
|
||||
- goal:
|
||||
- id: deliver_coal_lump
|
||||
teaser: Get coal to base
|
||||
goal:
|
||||
- Deliver a "coal lump" to the base.
|
||||
- |
|
||||
To excavate coal from the "lignite mine" (M), a robot needs to
|
||||
@ -75,6 +77,7 @@ objectives:
|
||||
condition: |
|
||||
hauler <- robotnamed "hauler";
|
||||
as hauler {has "coal briquette"}
|
||||
prerequisite: deliver_coal_lump
|
||||
solution: |
|
||||
run "scenarios/Challenges/_bucket-brigade/brigade.sw"
|
||||
entities:
|
||||
|
||||
@ -6,7 +6,9 @@ description: |
|
||||
seed: 2
|
||||
creative: false
|
||||
objectives:
|
||||
- goal:
|
||||
- id: prepare_playfield
|
||||
teaser: Wait patiently
|
||||
goal:
|
||||
- |
|
||||
First, wait for the playfield to be set up,
|
||||
and then your path forward will be cleared.
|
||||
@ -23,6 +25,7 @@ objectives:
|
||||
leftward or rightward direction,
|
||||
or vertically in either the upward or downward direction.
|
||||
Diagonal appearances are not valid.
|
||||
prerequisite: prepare_playfield
|
||||
condition: |
|
||||
/**
|
||||
Algorithm:
|
||||
|
||||
@ -14,6 +14,7 @@
|
||||
684-swap.yaml
|
||||
699-movement-fail
|
||||
858-inventory
|
||||
795-prerequisite
|
||||
710-multi-robot.yaml
|
||||
920-meet.yaml
|
||||
955-heading.yaml
|
||||
|
||||
@ -3,7 +3,9 @@ name: Complete two objectives in succession.
|
||||
description: |
|
||||
First, get some trees; then, use them to build a harvester.
|
||||
objectives:
|
||||
- goal:
|
||||
- id: get_trees
|
||||
teaser: Get trees
|
||||
goal:
|
||||
- Your first goal is to get three trees.
|
||||
condition: |
|
||||
try {
|
||||
@ -14,6 +16,7 @@ objectives:
|
||||
- Nice job. Now, build a harvester.
|
||||
condition: |
|
||||
try { as base {has "harvester"} } {return false}
|
||||
prerequisite: get_trees
|
||||
solution: |
|
||||
build {turn right; move; move; grab; move; grab; move; grab; turn back; move; move; move; move};
|
||||
wait 16;
|
||||
|
||||
4
data/scenarios/Testing/795-prerequisite/00-ORDER.txt
Normal file
4
data/scenarios/Testing/795-prerequisite/00-ORDER.txt
Normal file
@ -0,0 +1,4 @@
|
||||
795-prerequisite-or.yaml
|
||||
795-prerequisite-and.yaml
|
||||
795-prerequisite-mutually-exclusive.yaml
|
||||
795-prerequisite-cycle-with-not.yaml
|
||||
@ -0,0 +1,50 @@
|
||||
version: 1
|
||||
name: |
|
||||
Prerequisite objectives: AND
|
||||
description: |
|
||||
Complete an objective with a prerequisite entailing both of two other objectives.
|
||||
objectives:
|
||||
- goal:
|
||||
- Achieve both of two other objectives
|
||||
condition: |
|
||||
return true;
|
||||
prerequisite:
|
||||
previewable: true
|
||||
logic:
|
||||
and:
|
||||
- have_furnace
|
||||
- have_gear
|
||||
- id: have_furnace
|
||||
goal:
|
||||
- Make a "furnace".
|
||||
condition: |
|
||||
as base {has "furnace"};
|
||||
optional: true
|
||||
- id: have_gear
|
||||
goal:
|
||||
- Make a "wooden gear".
|
||||
condition: |
|
||||
as base {has "wooden 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
|
||||
@ -0,0 +1,42 @@
|
||||
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:
|
||||
- id: have_furnace
|
||||
goal:
|
||||
- Make a "furnace".
|
||||
condition: |
|
||||
as base {has "furnace"};
|
||||
prerequisite:
|
||||
not: have_gear
|
||||
- id: have_gear
|
||||
goal:
|
||||
- Make a "wooden gear".
|
||||
condition: |
|
||||
as base {has "wooden gear"};
|
||||
prerequisite: 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
|
||||
@ -0,0 +1,61 @@
|
||||
version: 1
|
||||
name: |
|
||||
Mutually exclusive prerequisites
|
||||
description: |
|
||||
Complete an objective with a prerequisite of either of two other objectives.
|
||||
objectives:
|
||||
- goal:
|
||||
- Either obtain a "furnace" WITHOUT a "flower", or obtain both a "wooden gear" and "flower".
|
||||
condition: |
|
||||
return true;
|
||||
prerequisite:
|
||||
previewable: true
|
||||
logic:
|
||||
or:
|
||||
- and:
|
||||
- id: have_furnace
|
||||
- not:
|
||||
id: have_flower
|
||||
- and:
|
||||
- id: have_gear
|
||||
- id: have_flower
|
||||
- id: have_furnace
|
||||
goal:
|
||||
- Make a "furnace".
|
||||
condition: |
|
||||
as base {has "furnace"};
|
||||
|
||||
optional: true
|
||||
- id: have_gear
|
||||
goal:
|
||||
- Make a "wooden gear".
|
||||
condition: |
|
||||
as base {has "wooden gear"};
|
||||
optional: true
|
||||
- id: have_flower
|
||||
goal:
|
||||
- Possess a "flower".
|
||||
condition: |
|
||||
as base {has "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
|
||||
@ -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
|
||||
- id: have_furnace
|
||||
goal:
|
||||
- Make a "furnace".
|
||||
condition: |
|
||||
as base {has "furnace"};
|
||||
optional: true
|
||||
- id: have_gear
|
||||
goal:
|
||||
- Make a "wooden gear".
|
||||
condition: |
|
||||
as base {has "wooden 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
|
||||
@ -0,0 +1,38 @@
|
||||
version: 1
|
||||
name: |
|
||||
Prerequisite objectives: dependency cycle
|
||||
description: |
|
||||
This should be rejected by the parser.
|
||||
objectives:
|
||||
- id: have_furnace
|
||||
goal:
|
||||
- Make a "furnace".
|
||||
condition: |
|
||||
as base {has "furnace"};
|
||||
prerequisite: have_gear
|
||||
- id: have_gear
|
||||
goal:
|
||||
- Make a "wooden gear".
|
||||
condition: |
|
||||
as base {has "wooden gear"};
|
||||
prerequisite: 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
|
||||
@ -0,0 +1,38 @@
|
||||
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: shave_furnace
|
||||
- id: have_furnace
|
||||
goal:
|
||||
- Make a "furnace".
|
||||
condition: |
|
||||
as base {has "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
|
||||
@ -0,0 +1,31 @@
|
||||
version: 1
|
||||
name: |
|
||||
Prerequisite objectives: dependency cycle (self-reference)
|
||||
description: |
|
||||
This should be rejected by the parser.
|
||||
objectives:
|
||||
- id: have_furnace
|
||||
goal:
|
||||
- Make a "furnace".
|
||||
condition: |
|
||||
as base {has "furnace"};
|
||||
prerequisite: 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
|
||||
@ -4,7 +4,9 @@ creative: false
|
||||
description: |
|
||||
Learn about command return types and how to bind the results.
|
||||
objectives:
|
||||
- goal:
|
||||
- id: grab_artifact
|
||||
teaser: Retrieve artifact
|
||||
goal:
|
||||
- |
|
||||
A pedestal stands conspicuously empty in the center of the room.
|
||||
Perhaps its intended contents lie nearby?
|
||||
@ -56,6 +58,7 @@ objectives:
|
||||
w <- as p {ishere "Hastur"};
|
||||
return w;
|
||||
} { return false }
|
||||
prerequisite: grab_artifact
|
||||
solution: |
|
||||
run "data/scenarios/Tutorials/bind2-solution.sw"
|
||||
entities:
|
||||
@ -105,4 +108,4 @@ world:
|
||||
│...xxxH..│
|
||||
│.........│
|
||||
│Ω┌───────┘
|
||||
└─┘........
|
||||
└─┘........
|
||||
|
||||
@ -3,7 +3,9 @@ name: Farming
|
||||
description: |
|
||||
Learn how to build a farm to grow and harvest items.
|
||||
objectives:
|
||||
- goal:
|
||||
- id: get_many_lambdas
|
||||
teaser: Get 256 lambdas
|
||||
goal:
|
||||
- Lambdas are an essential item for building robots, but they
|
||||
are somewhat rare in the wild. Therefore, it makes sense to farm
|
||||
them in order to create a reliable supply.
|
||||
@ -47,6 +49,7 @@ objectives:
|
||||
- Now go forth and build your swarm!
|
||||
condition: |
|
||||
try {as base {has "curry"}} {return false}
|
||||
prerequisite: get_many_lambdas
|
||||
solution: |
|
||||
run "scenarios/Tutorials/farming.sw";
|
||||
run "scenarios/Tutorials/make_curry.sw";
|
||||
|
||||
@ -3,7 +3,9 @@ name: Moving
|
||||
description: |
|
||||
Learn how to move and chain commands.
|
||||
objectives:
|
||||
- goal:
|
||||
- id: move_to_first_flower
|
||||
teaser: Get the flower
|
||||
goal:
|
||||
- Robots can use the `move` command to move forward one unit
|
||||
in the direction they are currently facing.
|
||||
- To complete this challenge, move your robot two spaces to the right,
|
||||
@ -14,7 +16,9 @@ objectives:
|
||||
condition: |
|
||||
r <- robotNamed "check1";
|
||||
loc <- as r {has "Win"};
|
||||
- goal:
|
||||
- id: move_along_corridor
|
||||
teaser: Down the corridor
|
||||
goal:
|
||||
- Good! Now you need to learn how to effectively repeat actions.
|
||||
- |
|
||||
Previously you could move twice by chaining the move command:
|
||||
@ -29,7 +33,10 @@ objectives:
|
||||
condition: |
|
||||
r <- robotNamed "check2";
|
||||
loc <- as r {has "Win"};
|
||||
- goal:
|
||||
prerequisite: move_to_first_flower
|
||||
- id: move_northeast_corner
|
||||
teaser: To northeast corner
|
||||
goal:
|
||||
- Well done! In addition to `move`, you can use the `turn` command
|
||||
to turn your robot, for example, `turn right` or `turn east`.
|
||||
- Switch to the inventory view in the upper left (by clicking on it or typing `Alt+E`)
|
||||
@ -51,6 +58,7 @@ objectives:
|
||||
condition: |
|
||||
r <- robotNamed "check3";
|
||||
loc <- as r {has "Win"};
|
||||
prerequisite: 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 +69,7 @@ objectives:
|
||||
condition: |
|
||||
r <- robotNamed "check4";
|
||||
loc <- as r {has "Win"};
|
||||
prerequisite: move_northeast_corner
|
||||
solution: |
|
||||
// 0
|
||||
move;move;
|
||||
|
||||
@ -3,7 +3,9 @@ name: First steps
|
||||
description: |
|
||||
Learn some of the first steps you might take on the new planet.
|
||||
objectives:
|
||||
- goal:
|
||||
- id: get_trees
|
||||
teaser: Get 3 trees
|
||||
goal:
|
||||
- You're ready to graduate to something a bit more complex! This
|
||||
multi-step tutorial will walk you through a few of the first
|
||||
steps you might take in exploring the new planet, using many
|
||||
@ -26,7 +28,9 @@ objectives:
|
||||
n <- as base {count "tree"};
|
||||
return (n >= 3)
|
||||
} { return false }
|
||||
- goal:
|
||||
- id: get_harvester
|
||||
teaser: Make a harvester
|
||||
goal:
|
||||
- Nice work! Now, use the trees to make a harvester device.
|
||||
This will require several intermediate products; try making
|
||||
various things, and take a look at your available recipes (F3)
|
||||
@ -34,6 +38,7 @@ objectives:
|
||||
you may end up needing some additional trees.
|
||||
condition: |
|
||||
try { as base {has "harvester"} } {return false}
|
||||
prerequisite: 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,7 @@ objectives:
|
||||
coordinates."
|
||||
condition: |
|
||||
try { as base {has "lambda"} } {return false}
|
||||
prerequisite: get_harvester
|
||||
robots:
|
||||
- name: base
|
||||
display:
|
||||
|
||||
337
src/Data/BoolExpr.hs
Normal file
337
src/Data/BoolExpr.hs
Normal file
@ -0,0 +1,337 @@
|
||||
{-
|
||||
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.
|
||||
-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE NoDeriveAnyClass #-}
|
||||
|
||||
--------------------------------------------------------------------
|
||||
|
||||
--------------------------------------------------------------------
|
||||
|
||||
-- |
|
||||
-- Module : Data.BoolExpr
|
||||
-- Copyright : (c) Nicolas Pouillard 2008,2009
|
||||
-- License : BSD3
|
||||
--
|
||||
-- Maintainer: Nicolas Pouillard <nicolas.pouillard@gmail.com>
|
||||
-- Stability : provisional
|
||||
-- Portability:
|
||||
--
|
||||
-- Boolean expressions and various representations.
|
||||
module Data.BoolExpr (
|
||||
-- * A boolean class
|
||||
Boolean (..),
|
||||
|
||||
-- * Boolean trees
|
||||
BoolExpr (..),
|
||||
reduceBoolExpr,
|
||||
evalBoolExpr,
|
||||
|
||||
-- * Boolean evaluation semantic
|
||||
Eval (..),
|
||||
runEvalId,
|
||||
|
||||
-- * Signed constants
|
||||
Signed (..),
|
||||
negateSigned,
|
||||
evalSigned,
|
||||
constants,
|
||||
negateConstant,
|
||||
|
||||
-- * Conjunctive Normal Form
|
||||
CNF (..),
|
||||
Conj (..),
|
||||
boolTreeToCNF,
|
||||
|
||||
-- * Disjunctive Normal Form
|
||||
Disj (..),
|
||||
DNF (..),
|
||||
boolTreeToDNF,
|
||||
|
||||
-- * Other transformations
|
||||
dualize,
|
||||
fromBoolExpr,
|
||||
pushNotInwards,
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad (ap)
|
||||
import Data.Aeson
|
||||
import Data.Char (toLower)
|
||||
import Data.Traversable
|
||||
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
|
||||
|
||||
-- | 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 !-})
|
||||
|
||||
encodingOptions :: Options
|
||||
encodingOptions =
|
||||
defaultOptions
|
||||
{ sumEncoding = ObjectWithSingleField
|
||||
, constructorTagModifier = map toLower
|
||||
}
|
||||
|
||||
instance (ToJSON a) => ToJSON (Signed a) where
|
||||
toJSON = genericToJSON encodingOptions
|
||||
|
||||
instance (ToJSON a) => ToJSON (BoolExpr a) where
|
||||
toJSON = genericToJSON encodingOptions
|
||||
|
||||
instance (ToJSON a) => ToJSON (DNF a) where
|
||||
toJSON = genericToJSON encodingOptions
|
||||
|
||||
instance (ToJSON a) => ToJSON (CNF a) where
|
||||
toJSON = genericToJSON encodingOptions
|
||||
|
||||
instance (ToJSON a) => ToJSON (Conj a) where
|
||||
toJSON = genericToJSON encodingOptions
|
||||
|
||||
instance (ToJSON a) => ToJSON (Disj a) where
|
||||
toJSON = genericToJSON encodingOptions
|
||||
|
||||
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 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
|
||||
|
||||
evalSigned :: (a -> Bool) -> Signed a -> Bool
|
||||
evalSigned f (Positive x) = f x
|
||||
evalSigned f (Negative x) = not $ f x
|
||||
|
||||
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
|
||||
57
src/Data/BoolExpr/Simplify.hs
Normal file
57
src/Data/BoolExpr/Simplify.hs
Normal file
@ -0,0 +1,57 @@
|
||||
-- | Simplification logic for boolean expressions that is not
|
||||
-- provided in the 'boolexpr' package.
|
||||
module Data.BoolExpr.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
|
||||
|
||||
-- | Used only by "hasContradiction".
|
||||
-- Note that the Booleans returned in this tuple are not actually used
|
||||
-- as conditions, and therefore their semantic convention (e.g. associating
|
||||
-- True = Positive and False = Negative) is irrelevant.
|
||||
-- Rather, they are collected into sets
|
||||
-- to determine whether both True and False exist for a key.
|
||||
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
|
||||
@ -1,4 +1,3 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
|
||||
@ -1,4 +1,3 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
|
||||
@ -1,4 +1,3 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
|
||||
@ -1,5 +1,4 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
@ -1,5 +1,4 @@
|
||||
{-# LANGUAGE DefaultSignatures #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DerivingVia #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
@ -17,11 +16,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 +53,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 +63,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)
|
||||
@ -108,6 +104,7 @@ instance FromJSONE EntityMap Scenario where
|
||||
-- parse custom entities
|
||||
em <- liftE (buildEntityMap <$> (v .:? "entities" .!= []))
|
||||
-- extend ambient EntityMap with custom entities
|
||||
|
||||
withE em $ do
|
||||
-- parse 'known' entity names and make sure they exist
|
||||
known <- liftE (v .:? "known" .!= [])
|
||||
@ -134,7 +131,7 @@ instance FromJSONE EntityMap Scenario where
|
||||
<*> pure known
|
||||
<*> localE (,rsMap) (v ..: "world")
|
||||
<*> pure rs
|
||||
<*> liftE (v .:? "objectives" .!= [])
|
||||
<*> (liftE (v .:? "objectives" .!= []) >>= validateObjectives)
|
||||
<*> liftE (v .:? "solution")
|
||||
<*> liftE (v .:? "stepsPerTick")
|
||||
|
||||
|
||||
@ -1,24 +1,73 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Swarm.Game.Scenario.Objective where
|
||||
|
||||
import Control.Applicative ((<|>))
|
||||
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 of dependencies upon other objectives. Variables in this expression
|
||||
-- are the "id"s of other objectives, and become "true" if the corresponding objective is completed.
|
||||
-- The "condition" of the objective at hand shall not be evaluated until its
|
||||
-- prerequisite expression evaluates as True.
|
||||
--
|
||||
-- Note that the achievement of these objective dependencies is
|
||||
-- persistent; once achieved, they still count even if their "condition"
|
||||
-- might not still hold. The condition is never re-evaluated once True.
|
||||
}
|
||||
deriving (Eq, Show, Generic, ToJSON)
|
||||
|
||||
instance FromJSON PrerequisiteConfig where
|
||||
-- Parsing JSON/YAML 'PrerequisiteConfig' has a shorthand option
|
||||
-- in which the boolean expression can be written directly,
|
||||
-- bypassing the "logic" key.
|
||||
-- Furthermore, an "Id" in a boolean expressions can be written
|
||||
-- as a bare string without needing the "id" key.
|
||||
parseJSON val = preLogic val <|> preObject val
|
||||
where
|
||||
preObject = withObject "prerequisite" $ \v ->
|
||||
PrerequisiteConfig
|
||||
<$> (v .:? "previewable" .!= False)
|
||||
<*> v .: "logic"
|
||||
preLogic = fmap (PrerequisiteConfig False) . parseJSON
|
||||
|
||||
-- | An objective is a condition to be achieved by a player in a
|
||||
-- scenario.
|
||||
data Objective = Objective
|
||||
{ _objectiveGoal :: [Text]
|
||||
, _objectiveTeaser :: Maybe Text
|
||||
, _objectiveCondition :: ProcessedTerm
|
||||
, _objectiveId :: Maybe ObjectiveLabel
|
||||
, _objectiveOptional :: Bool
|
||||
, _objectivePrerequisite :: Maybe PrerequisiteConfig
|
||||
, _objectiveHidden :: Bool
|
||||
, _objectiveAchievement :: Maybe AchievementInfo
|
||||
}
|
||||
deriving (Eq, Show, Generic, ToJSON)
|
||||
|
||||
@ -28,14 +77,119 @@ makeLensesWith (lensRules & generateSignatures .~ False) ''Objective
|
||||
-- during play. It is represented as a list of paragraphs.
|
||||
objectiveGoal :: Lens' Objective [Text]
|
||||
|
||||
-- | A very short (3-5 words) description of the goal for
|
||||
-- displaying on the left side of the Objectives modal.
|
||||
objectiveTeaser :: Lens' Objective (Maybe Text)
|
||||
|
||||
-- | A winning condition for the objective, expressed as a
|
||||
-- program of type @cmd bool@. By default, this program will be
|
||||
-- run to completion every tick (the usual limits on the number
|
||||
-- of CESK steps per tick do not apply).
|
||||
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 .:? "teaser")
|
||||
<*> (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 cmplIds
|
||||
where
|
||||
newBuckets =
|
||||
buckets
|
||||
{ unwinnable = obj : unwinnable buckets
|
||||
}
|
||||
|
||||
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
|
||||
|
||||
144
src/Swarm/Game/Scenario/Objective/Graph.hs
Normal file
144
src/Swarm/Game/Scenario/Objective/Graph.hs
Normal file
@ -0,0 +1,144 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
-- | Utilities for performing graph analysis on Objective prerequisites
|
||||
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
|
||||
|
||||
-- | Collect all of the constants that have a negation.
|
||||
-- This is necessary for enumerating all of the distinct
|
||||
-- nodes when constructing a Graph, as we treat a constant
|
||||
-- and its negation as distinct nodes.
|
||||
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
|
||||
|
||||
labeledObjsMap = M.mapKeys (Label . Positive) objectivesById
|
||||
|
||||
unlabeledObjs = filter (null . _objectiveId) objs
|
||||
unlabeledObjsMap = M.fromList $ zipWith (\x y -> (Ordinal x, y)) [0 ..] unlabeledObjs
|
||||
|
||||
type Edges = [(Objective, ObjectiveId, [ObjectiveId])]
|
||||
|
||||
-- | 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 :: Edges -> Graph
|
||||
makeGraph edges =
|
||||
myGraph
|
||||
where
|
||||
(myGraph, _, _) = graphFromEdges edges
|
||||
|
||||
makeGraphEdges :: [Objective] -> Edges
|
||||
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
|
||||
|
||||
isAcyclicGraph :: [SCC Objective] -> Bool
|
||||
isAcyclicGraph =
|
||||
all isAcyclicVertex
|
||||
where
|
||||
isAcyclicVertex = \case
|
||||
AcyclicSCC _ -> True
|
||||
_ -> False
|
||||
|
||||
makeGraphInfo :: ObjectiveCompletion -> GraphInfo
|
||||
makeGraphInfo oc =
|
||||
GraphInfo
|
||||
(makeGraph edges)
|
||||
(isAcyclicGraph connectedComponents)
|
||||
connectedComponents
|
||||
(M.keys $ assignIds objs)
|
||||
where
|
||||
edges = makeGraphEdges objs
|
||||
connectedComponents = stronglyConnComp edges
|
||||
objs = listAllObjectives $ completionBuckets oc
|
||||
46
src/Swarm/Game/Scenario/Objective/Logic.hs
Normal file
46
src/Swarm/Game/Scenario/Objective/Logic.hs
Normal file
@ -0,0 +1,46 @@
|
||||
-- | A model for defining boolean expressions for Objective prerequisites.
|
||||
--
|
||||
-- This model is intended to be user-facing in the .yaml files, and is
|
||||
-- distinct from that in 'Data.BoolExpr'.
|
||||
module Swarm.Game.Scenario.Objective.Logic where
|
||||
|
||||
import Control.Applicative ((<|>))
|
||||
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 x = preString x <|> genericParseJSON prerequisiteOptions x
|
||||
where
|
||||
preString = withText "prerequisite" $ pure . Id
|
||||
|
||||
toBoolExpr :: Prerequisite a -> BoolExpr a
|
||||
toBoolExpr (And xs) = foldr1 BAnd (fmap toBoolExpr xs)
|
||||
toBoolExpr (Or xs) = foldr1 BOr (fmap toBoolExpr xs)
|
||||
toBoolExpr (Not x) = BNot $ toBoolExpr x
|
||||
toBoolExpr (Id x) = BConst $ pure x
|
||||
105
src/Swarm/Game/Scenario/Objective/Presentation/Model.hs
Normal file
105
src/Swarm/Game/Scenario/Objective/Presentation/Model.hs
Normal file
@ -0,0 +1,105 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}
|
||||
|
||||
-- A UI-centric model for Objective presentation.
|
||||
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 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 negative prerequisite that was completed.
|
||||
Failed
|
||||
deriving (Show, Eq, Ord, Bounded, Enum, Generic, ToJSON, ToJSONKey)
|
||||
|
||||
-- | TODO: #1044 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
|
||||
|
||||
isHeader :: GoalEntry -> Bool
|
||||
isHeader = \case
|
||||
Header _ -> True
|
||||
_ -> False
|
||||
|
||||
data GoalTracking = GoalTracking
|
||||
{ announcements :: [Announcement]
|
||||
-- ^ TODO: #1044 the actual contents of these are not used yet,
|
||||
-- other than as a flag 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
|
||||
80
src/Swarm/Game/Scenario/Objective/Presentation/Render.hs
Normal file
80
src/Swarm/Game/Scenario/Objective/Presentation/Render.hs
Normal file
@ -0,0 +1,80 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
-- Display logic for Objectives.
|
||||
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.Applicative ((<|>))
|
||||
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.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 $
|
||||
if goalsCount > 1
|
||||
then
|
||||
hBox
|
||||
[ leftSide
|
||||
, hLimitPercent 70 goalElaboration
|
||||
]
|
||||
else goalElaboration
|
||||
where
|
||||
lw = _listWidget gd
|
||||
leftSide =
|
||||
hLimitPercent 30 $
|
||||
vBox
|
||||
[ hCenter $ str "Goals"
|
||||
, padAll 1 $
|
||||
vLimit 10 $
|
||||
BL.renderList (const drawGoalListItem) True lw
|
||||
]
|
||||
goalsCount = sum . M.elems . M.map NE.length . goals $ gd ^. goalsContent
|
||||
|
||||
goalElaboration =
|
||||
padLeft (Pad 2) $
|
||||
maybe emptyWidget (singleGoalDetails . snd) $
|
||||
BL.listSelectedElement lw
|
||||
|
||||
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
|
||||
textSource = obj ^. objectiveTeaser <|> obj ^. objectiveId <|> listToMaybe (obj ^. objectiveGoal)
|
||||
titleWidget = maybe (txt "?") withEllipsis textSource
|
||||
|
||||
singleGoalDetails :: GoalEntry -> Widget Name
|
||||
singleGoalDetails = \case
|
||||
Header _gs -> displayParagraphs [" "]
|
||||
Goal _gs obj -> displayParagraphs $ obj ^. objectiveGoal
|
||||
50
src/Swarm/Game/Scenario/Objective/Validation.hs
Normal file
50
src/Swarm/Game/Scenario/Objective/Validation.hs
Normal file
@ -0,0 +1,50 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
-- | Validity checking for Objective prerequisites
|
||||
module Swarm.Game.Scenario.Objective.Validation where
|
||||
|
||||
import Control.Monad (unless)
|
||||
import Data.Foldable (for_, toList)
|
||||
import Data.Graph (stronglyConnComp)
|
||||
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 connectedComponents) $
|
||||
fail . into @String $
|
||||
T.unwords ["There are dependency cycles in the prerequisites."]
|
||||
|
||||
return objectives
|
||||
where
|
||||
connectedComponents = stronglyConnComp $ makeGraphEdges objectives
|
||||
allIds = Set.fromList $ mapMaybe _objectiveId objectives
|
||||
83
src/Swarm/Game/Scenario/Objective/WinCheck.hs
Normal file
83
src/Swarm/Game/Scenario/Objective/WinCheck.hs
Normal file
@ -0,0 +1,83 @@
|
||||
-- | Utilities to check whether conditions are met for a game win/loss.
|
||||
module Swarm.Game.Scenario.Objective.WinCheck where
|
||||
|
||||
import Data.Aeson
|
||||
import Data.BoolExpr qualified as BE
|
||||
import Data.BoolExpr.Simplify qualified as Simplify
|
||||
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
|
||||
|
||||
-- | 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
|
||||
|
||||
-- | The first element of the returned tuple consists of "active" objectives,
|
||||
-- the second element "inactive".
|
||||
partitionActiveObjectives :: ObjectiveCompletion -> ([Objective], [Objective])
|
||||
partitionActiveObjectives oc =
|
||||
partition (isPrereqsSatisfied oc) $
|
||||
incomplete $
|
||||
completionBuckets oc
|
||||
|
||||
getActiveObjectives :: ObjectiveCompletion -> [Objective]
|
||||
getActiveObjectives =
|
||||
fst . partitionActiveObjectives
|
||||
|
||||
-- | For debugging only (via Web API)
|
||||
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
|
||||
@ -1,4 +1,3 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
@ -20,10 +19,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 +34,7 @@ module Swarm.Game.State (
|
||||
winCondition,
|
||||
winSolution,
|
||||
gameAchievements,
|
||||
announcementQueue,
|
||||
runStatus,
|
||||
paused,
|
||||
robotMap,
|
||||
@ -122,7 +124,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 +146,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)
|
||||
@ -198,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 negative 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
|
||||
@ -261,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
|
||||
@ -340,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
|
||||
|
||||
@ -717,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
|
||||
@ -876,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)
|
||||
|
||||
|
||||
@ -26,7 +26,7 @@ import Control.Effect.Error
|
||||
import Control.Effect.Lens
|
||||
import Control.Effect.Lift
|
||||
import Control.Lens as Lens hiding (Const, distrib, 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, mapMaybe)
|
||||
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,37 +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)
|
||||
let h = hypotheticalRobot (Out VUnit emptyStore []) 0
|
||||
case stripVResult <$> v of
|
||||
-- Log exceptions in the message queue so we can check for them in tests
|
||||
Left exn -> do
|
||||
em <- use entityMap
|
||||
m <- evalState @Robot h $ createLogEntry (ErrorTrace Critical) (formatExn em exn)
|
||||
emitMessage m
|
||||
Right (VBool res) -> when res markWin
|
||||
Right val -> do
|
||||
m <-
|
||||
evalState @Robot h $
|
||||
createLogEntry (ErrorTrace Critical) $
|
||||
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 completedObjs
|
||||
| WC.didWin completedObjs = Won False
|
||||
| WC.didLose completedObjs = 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 or impossible and place it into the "completed"
|
||||
-- or "unwinnable" bucket, respectively.
|
||||
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 $ stripVResult <$> 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 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 Critical) 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 ->
|
||||
|
||||
@ -1,4 +1,3 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
|
||||
|
||||
@ -1,4 +1,3 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
|
||||
-- |
|
||||
|
||||
@ -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
|
||||
|
||||
@ -54,6 +54,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
|
||||
@ -69,6 +70,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)
|
||||
@ -254,7 +257,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
|
||||
@ -278,9 +282,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
|
||||
@ -401,8 +406,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 $ handleListEventWithSeparators ev isHeader
|
||||
|
||||
-- | Write the @ScenarioInfo@ out to disk when exiting a game.
|
||||
saveScenarioInfoOnQuit :: (MonadIO m, MonadState AppState m) => m ()
|
||||
@ -418,7 +429,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
|
||||
@ -703,35 +717,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)
|
||||
goalOrWinUpdated <- doGoalUpdates
|
||||
|
||||
let goalUpdated = curGoal /= newGoal
|
||||
when goalUpdated $ do
|
||||
uiState . uiGoal .= newGoal
|
||||
case newGoal of
|
||||
Just goal | goal /= [] -> do
|
||||
toggleModal (GoalModal goal)
|
||||
_ -> return ()
|
||||
|
||||
-- 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 ()
|
||||
|
||||
@ -10,18 +10,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 (Eq, Show, Generic, FromJSON, ToJSON)
|
||||
|
||||
data FlavorText
|
||||
= Freeform Text
|
||||
| FTQuotation Quotation
|
||||
deriving (Show)
|
||||
deriving (Eq, Show, Generic, FromJSON, ToJSON)
|
||||
|
||||
data AchievementInfo = AchievementInfo
|
||||
{ title :: Text
|
||||
@ -41,7 +41,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 (Eq, Show, Generic, FromJSON, ToJSON)
|
||||
|
||||
data CategorizedAchievement
|
||||
= GlobalAchievement GlobalAchievement
|
||||
|
||||
@ -41,10 +41,11 @@ data ModalType
|
||||
| MessagesModal
|
||||
| RobotsModal
|
||||
| WinModal
|
||||
| LoseModal
|
||||
| QuitModal
|
||||
| KeepPlayingModal
|
||||
| DescriptionModal Entity
|
||||
| GoalModal [Text]
|
||||
| GoalModal
|
||||
deriving (Show)
|
||||
|
||||
data ButtonSelection
|
||||
|
||||
@ -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.
|
||||
|
||||
@ -21,6 +21,7 @@ import Data.Text (Text)
|
||||
import Data.Time (ZonedTime, getZonedTime)
|
||||
import Swarm.Game.Log (ErrorLevel (..), LogSource (ErrorTrace))
|
||||
import Swarm.Game.Scenario (loadScenario)
|
||||
import Swarm.Game.Scenario.Objective.Presentation.Model (emptyGoalDisplay)
|
||||
import Swarm.Game.ScenarioInfo (
|
||||
ScenarioInfo (..),
|
||||
ScenarioInfoPair,
|
||||
@ -130,7 +131,7 @@ scenarioToUIState siPair u = do
|
||||
return $
|
||||
u
|
||||
& uiPlaying .~ True
|
||||
& uiGoal .~ Nothing
|
||||
& uiGoal .~ emptyGoalDisplay
|
||||
& uiFocusRing .~ initFocusRing
|
||||
& uiInventory .~ Nothing
|
||||
& uiInventorySort .~ defaultSortOptions
|
||||
|
||||
@ -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,
|
||||
)
|
||||
@ -89,7 +91,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
|
||||
@ -169,7 +171,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)
|
||||
@ -281,7 +283,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
|
||||
|
||||
@ -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
|
||||
@ -759,9 +769,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
|
||||
@ -1155,12 +1163,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)
|
||||
|
||||
@ -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,21 @@ 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)
|
||||
|
||||
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
|
||||
|
||||
@ -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
|
||||
|
||||
11
swarm.cabal
11
swarm.cabal
@ -81,7 +81,9 @@ common ghc2021-extensions
|
||||
|
||||
library
|
||||
import: stan-config, common, ghc2021-extensions
|
||||
exposed-modules: Swarm.App
|
||||
exposed-modules: Data.BoolExpr
|
||||
Data.BoolExpr.Simplify
|
||||
Swarm.App
|
||||
Swarm.DocGen
|
||||
Swarm.Game.CESK
|
||||
Swarm.Game.Display
|
||||
@ -92,6 +94,12 @@ library
|
||||
Swarm.Game.Robot
|
||||
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.Validation
|
||||
Swarm.Game.Scenario.Objective.WinCheck
|
||||
Swarm.Game.Scenario.Objective
|
||||
Swarm.Game.Scenario.RobotLookup
|
||||
Swarm.Game.Scenario.WorldDescription
|
||||
@ -232,6 +240,7 @@ test-suite swarm-unit
|
||||
TestNotification
|
||||
TestLanguagePipeline
|
||||
TestPretty
|
||||
TestBoolExpr
|
||||
TestLSP
|
||||
TestUtil
|
||||
|
||||
|
||||
@ -6,13 +6,14 @@
|
||||
module Main where
|
||||
|
||||
import Control.Lens (Ixed (ix), to, use, view, (&), (.~), (<&>), (<>~), (^.), (^..), (^?!))
|
||||
import Control.Monad (filterM, forM_, unless, void, when)
|
||||
import Control.Monad (filterM, forM_, unless, when)
|
||||
import Control.Monad.State (StateT (runStateT), gets)
|
||||
import Control.Monad.Trans.Except (runExceptT)
|
||||
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.Sequence (Seq)
|
||||
@ -28,7 +29,8 @@ import Swarm.Game.Robot (LogEntry, defReqs, leText, machine, robotContext, robot
|
||||
import Swarm.Game.Scenario (Scenario)
|
||||
import Swarm.Game.State (
|
||||
GameState,
|
||||
WinCondition (Won),
|
||||
WinCondition (WinConditions),
|
||||
WinStatus (Won),
|
||||
activeRobots,
|
||||
baseRobot,
|
||||
initGameStateForScenario,
|
||||
@ -45,16 +47,21 @@ 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.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
|
||||
@ -66,7 +73,8 @@ main = do
|
||||
"Tests"
|
||||
[ exampleTests examplePaths
|
||||
, exampleTests scenarioPrograms
|
||||
, scenarioTests em scenarioPaths
|
||||
, scenarioParseTests em parseableScenarios
|
||||
, scenarioParseInvalidTests em unparseableScenarios
|
||||
, testScenarioSolution ci em
|
||||
, testEditorFiles
|
||||
]
|
||||
@ -81,19 +89,34 @@ 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 parse"
|
||||
(map (scenarioTest Parsed em) inputs)
|
||||
|
||||
scenarioTest :: EntityMap -> (FilePath, String) -> TestTree
|
||||
scenarioTest em (path, _) =
|
||||
testCase ("parse scenario " ++ show path) (void $ getScenario em path)
|
||||
scenarioParseInvalidTests :: EntityMap -> [(FilePath, String)] -> TestTree
|
||||
scenarioParseInvalidTests em inputs =
|
||||
testGroup
|
||||
"Test invalid scenarios fail to parse"
|
||||
(map (scenarioTest Failed em) inputs)
|
||||
|
||||
getScenario :: EntityMap -> FilePath -> IO Scenario
|
||||
getScenario em p = do
|
||||
data ParseResult = Parsed | Failed
|
||||
|
||||
scenarioTest :: ParseResult -> EntityMap -> (FilePath, String) -> TestTree
|
||||
scenarioTest expRes em (path, _) =
|
||||
testCase ("parse scenario " ++ show path) (getScenario expRes em path)
|
||||
|
||||
getScenario :: ParseResult -> EntityMap -> FilePath -> IO ()
|
||||
getScenario expRes em p = do
|
||||
res <- decodeFileEitherE em p :: IO (Either ParseException Scenario)
|
||||
case res of
|
||||
Left err -> assertFailure (prettyPrintParseException err)
|
||||
Right s -> return s
|
||||
case expRes of
|
||||
Parsed -> case res of
|
||||
Left err -> assertFailure (prettyPrintParseException err)
|
||||
Right _s -> return ()
|
||||
Failed -> case res of
|
||||
Left _err -> return ()
|
||||
Right _s -> assertFailure "Unexpectedly parsed invalid scenario!"
|
||||
|
||||
acquire :: FilePath -> String -> IO [(FilePath, String)]
|
||||
acquire dir ext = do
|
||||
@ -272,7 +295,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
|
||||
|
||||
@ -20,6 +20,7 @@ import Test.Tasty.QuickCheck (
|
||||
testProperty,
|
||||
(==>),
|
||||
)
|
||||
import TestBoolExpr (testBoolExpr)
|
||||
import TestEval (testEval)
|
||||
import TestInventory (testInventory)
|
||||
import TestLSP (testLSP)
|
||||
@ -42,6 +43,7 @@ tests g =
|
||||
"Tests"
|
||||
[ testLanguagePipeline
|
||||
, testPrettyConst
|
||||
, testBoolExpr
|
||||
, testEval g
|
||||
, testModel
|
||||
, testInventory
|
||||
|
||||
103
test/unit/TestBoolExpr.hs
Normal file
103
test/unit/TestBoolExpr.hs
Normal file
@ -0,0 +1,103 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
-- | Boolean expression unit tests
|
||||
module TestBoolExpr where
|
||||
|
||||
import Data.BoolExpr qualified as BE
|
||||
import Data.BoolExpr.Simplify qualified as Simplify
|
||||
import Data.List.NonEmpty (NonEmpty ((:|)))
|
||||
import Data.Set qualified as Set
|
||||
import Swarm.Game.Scenario.Objective.Logic
|
||||
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"]
|
||||
Loading…
Reference in New Issue
Block a user