{-# OPTIONS_GHC -fno-warn-orphans #-}
module Swarm.Game.Scenario.Objective.Graph where
import Control.Arrow ((&&&))
import Data.Aeson
import Data.BoolExpr (Signed (Positive))
import Data.BoolExpr qualified as BE
import Data.Graph (Graph, SCC (AcyclicSCC), graphFromEdges, stronglyConnComp)
import Data.Map (Map)
import Data.Map.Strict qualified as M
import Data.Maybe (mapMaybe)
import Data.Set qualified as Set
import Data.Text qualified as T
import Data.Tuple (swap)
import GHC.Generics (Generic)
import Servant.Docs (ToSample)
import Servant.Docs qualified as SD
import Swarm.Game.Scenario.Objective
import Swarm.Game.Scenario.Objective.Logic as L
import Swarm.Game.Scenario.Objective.WinCheck
data ObjectiveId
= Label (Signed ObjectiveLabel)
|
Ordinal Int
deriving (ObjectiveId -> ObjectiveId -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ObjectiveId -> ObjectiveId -> Bool
$c/= :: ObjectiveId -> ObjectiveId -> Bool
== :: ObjectiveId -> ObjectiveId -> Bool
$c== :: ObjectiveId -> ObjectiveId -> Bool
Eq, Eq ObjectiveId
ObjectiveId -> ObjectiveId -> Bool
ObjectiveId -> ObjectiveId -> Ordering
ObjectiveId -> ObjectiveId -> ObjectiveId
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ObjectiveId -> ObjectiveId -> ObjectiveId
$cmin :: ObjectiveId -> ObjectiveId -> ObjectiveId
max :: ObjectiveId -> ObjectiveId -> ObjectiveId
$cmax :: ObjectiveId -> ObjectiveId -> ObjectiveId
>= :: ObjectiveId -> ObjectiveId -> Bool
$c>= :: ObjectiveId -> ObjectiveId -> Bool
> :: ObjectiveId -> ObjectiveId -> Bool
$c> :: ObjectiveId -> ObjectiveId -> Bool
<= :: ObjectiveId -> ObjectiveId -> Bool
$c<= :: ObjectiveId -> ObjectiveId -> Bool
< :: ObjectiveId -> ObjectiveId -> Bool
$c< :: ObjectiveId -> ObjectiveId -> Bool
compare :: ObjectiveId -> ObjectiveId -> Ordering
$ccompare :: ObjectiveId -> ObjectiveId -> Ordering
Ord, Int -> ObjectiveId -> ShowS
[ObjectiveId] -> ShowS
ObjectiveId -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ObjectiveId] -> ShowS
$cshowList :: [ObjectiveId] -> ShowS
show :: ObjectiveId -> String
$cshow :: ObjectiveId -> String
showsPrec :: Int -> ObjectiveId -> ShowS
$cshowsPrec :: Int -> ObjectiveId -> ShowS
Show, forall x. Rep ObjectiveId x -> ObjectiveId
forall x. ObjectiveId -> Rep ObjectiveId x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ObjectiveId x -> ObjectiveId
$cfrom :: forall x. ObjectiveId -> Rep ObjectiveId x
Generic, [ObjectiveId] -> Encoding
[ObjectiveId] -> Value
ObjectiveId -> Encoding
ObjectiveId -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [ObjectiveId] -> Encoding
$ctoEncodingList :: [ObjectiveId] -> Encoding
toJSONList :: [ObjectiveId] -> Value
$ctoJSONList :: [ObjectiveId] -> Value
toEncoding :: ObjectiveId -> Encoding
$ctoEncoding :: ObjectiveId -> Encoding
toJSON :: ObjectiveId -> Value
$ctoJSON :: ObjectiveId -> Value
ToJSON)
data GraphInfo = GraphInfo
{ GraphInfo -> Graph
actualGraph :: Graph
, GraphInfo -> Bool
isAcyclic :: Bool
, GraphInfo -> [SCC Objective]
sccInfo :: [SCC Objective]
, GraphInfo -> [ObjectiveId]
nodeIDs :: [ObjectiveId]
}
deriving (Int -> GraphInfo -> ShowS
[GraphInfo] -> ShowS
GraphInfo -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GraphInfo] -> ShowS
$cshowList :: [GraphInfo] -> ShowS
show :: GraphInfo -> String
$cshow :: GraphInfo -> String
showsPrec :: Int -> GraphInfo -> ShowS
$cshowsPrec :: Int -> GraphInfo -> ShowS
Show, forall x. Rep GraphInfo x -> GraphInfo
forall x. GraphInfo -> Rep GraphInfo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep GraphInfo x -> GraphInfo
$cfrom :: forall x. GraphInfo -> Rep GraphInfo x
Generic, [GraphInfo] -> Encoding
[GraphInfo] -> Value
GraphInfo -> Encoding
GraphInfo -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [GraphInfo] -> Encoding
$ctoEncodingList :: [GraphInfo] -> Encoding
toJSONList :: [GraphInfo] -> Value
$ctoJSONList :: [GraphInfo] -> Value
toEncoding :: GraphInfo -> Encoding
$ctoEncoding :: GraphInfo -> Encoding
toJSON :: GraphInfo -> Value
$ctoJSON :: GraphInfo -> Value
ToJSON)
instance ToJSON (SCC Objective) where
toJSON :: SCC Objective -> Value
toJSON = ObjectiveLabel -> Value
String forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ObjectiveLabel
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show
instance ToJSON Graph where
toJSON :: Graph -> Value
toJSON = ObjectiveLabel -> Value
String forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ObjectiveLabel
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show
instance ToSample GraphInfo where
toSamples :: Proxy GraphInfo -> [(ObjectiveLabel, GraphInfo)]
toSamples Proxy GraphInfo
_ = forall a. [(ObjectiveLabel, a)]
SD.noSamples
getConstFromSigned :: BE.Signed a -> a
getConstFromSigned :: forall a. Signed a -> a
getConstFromSigned = \case
BE.Positive a
x -> a
x
BE.Negative a
x -> a
x
getNegatedIds :: [Objective] -> Map ObjectiveLabel Objective
getNegatedIds :: [Objective] -> Map ObjectiveLabel Objective
getNegatedIds [Objective]
objs =
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ObjectiveLabel -> Maybe (ObjectiveLabel, Objective)
f [ObjectiveLabel]
allConstants
where
objectivesById :: Map ObjectiveLabel Objective
objectivesById = [Objective] -> Map ObjectiveLabel Objective
getObjectivesById [Objective]
objs
allPrereqExpressions :: [PrerequisiteConfig]
allPrereqExpressions = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Objective -> Maybe PrerequisiteConfig
_objectivePrerequisite [Objective]
objs
allConstants :: [ObjectiveLabel]
allConstants =
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {a}. Signed a -> Maybe a
onlyNegative
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
Set.toList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a. Ord a => Prerequisite a -> Set (Signed a)
getDistinctConstants forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrerequisiteConfig -> Prerequisite ObjectiveLabel
logic)
forall a b. (a -> b) -> a -> b
$ [PrerequisiteConfig]
allPrereqExpressions
f :: ObjectiveLabel -> Maybe (ObjectiveLabel, Objective)
f = forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA forall b c a. (b -> c) -> (a -> b) -> a -> c
. \ObjectiveLabel
x -> (ObjectiveLabel
x, forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ObjectiveLabel
x Map ObjectiveLabel Objective
objectivesById)
onlyNegative :: Signed a -> Maybe a
onlyNegative = \case
BE.Negative a
x -> forall a. a -> Maybe a
Just a
x
Signed a
_ -> forall a. Maybe a
Nothing
getObjectivesById :: [Objective] -> Map ObjectiveLabel Objective
getObjectivesById :: [Objective] -> Map ObjectiveLabel Objective
getObjectivesById [Objective]
objs =
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> (b, a)
swap forall a b. (a -> b) -> a -> b
$
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> a
id forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Objective -> Maybe ObjectiveLabel
_objectiveId)) [Objective]
objs
assignIds :: [Objective] -> Map ObjectiveId Objective
assignIds :: [Objective] -> Map ObjectiveId Objective
assignIds [Objective]
objs =
Map ObjectiveId Objective
unlabeledObjsMap forall a. Semigroup a => a -> a -> a
<> Map ObjectiveId Objective
labeledObjsMap
where
objectivesById :: Map ObjectiveLabel Objective
objectivesById = [Objective] -> Map ObjectiveLabel Objective
getObjectivesById [Objective]
objs
labeledObjsMap :: Map ObjectiveId Objective
labeledObjsMap = forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
M.mapKeys (Signed ObjectiveLabel -> ObjectiveId
Label forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Signed a
Positive) Map ObjectiveLabel Objective
objectivesById
unlabeledObjs :: [Objective]
unlabeledObjs = forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. Objective -> Maybe ObjectiveLabel
_objectiveId) [Objective]
objs
unlabeledObjsMap :: Map ObjectiveId Objective
unlabeledObjsMap = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
x Objective
y -> (Int -> ObjectiveId
Ordinal Int
x, Objective
y)) [Int
0 ..] [Objective]
unlabeledObjs
type Edges = [(Objective, ObjectiveId, [ObjectiveId])]
makeGraph :: Edges -> Graph
makeGraph :: Edges -> Graph
makeGraph Edges
edges =
Graph
myGraph
where
(Graph
myGraph, Int -> (Objective, ObjectiveId, [ObjectiveId])
_, ObjectiveId -> Maybe Int
_) = forall key node.
Ord key =>
[(node, key, [key])]
-> (Graph, Int -> (node, key, [key]), key -> Maybe Int)
graphFromEdges Edges
edges
makeGraphEdges :: [Objective] -> Edges
makeGraphEdges :: [Objective] -> Edges
makeGraphEdges [Objective]
objectives =
Edges
rootTuples forall a. Semigroup a => a -> a -> a
<> forall {a}. [(Objective, ObjectiveId, [a])]
negatedTuples
where
rootTuples :: Edges
rootTuples = forall a b. (a -> b) -> [a] -> [b]
map forall {b}. (b, Objective) -> (Objective, b, [ObjectiveId])
f forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
M.toList forall a b. (a -> b) -> a -> b
$ [Objective] -> Map ObjectiveId Objective
assignIds [Objective]
objectives
negatedTuples :: [(Objective, ObjectiveId, [a])]
negatedTuples = forall a b. (a -> b) -> [a] -> [b]
map forall {a} {a}. (ObjectiveLabel, a) -> (a, ObjectiveId, [a])
gg forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
M.toList forall a b. (a -> b) -> a -> b
$ [Objective] -> Map ObjectiveLabel Objective
getNegatedIds [Objective]
objectives
gg :: (ObjectiveLabel, a) -> (a, ObjectiveId, [a])
gg (ObjectiveLabel
k, a
v) = (a
v, Signed ObjectiveLabel -> ObjectiveId
Label forall a b. (a -> b) -> a -> b
$ forall a. a -> Signed a
BE.Negative ObjectiveLabel
k, [])
f :: (b, Objective) -> (Objective, b, [ObjectiveId])
f (b
k, Objective
v) = (Objective
v, b
k, forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (forall a b. (a -> b) -> [a] -> [b]
map Signed ObjectiveLabel -> ObjectiveId
Label forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrerequisiteConfig -> [Signed ObjectiveLabel]
g) forall a b. (a -> b) -> a -> b
$ Objective -> Maybe PrerequisiteConfig
_objectivePrerequisite Objective
v)
g :: PrerequisiteConfig -> [Signed ObjectiveLabel]
g = forall a. Set a -> [a]
Set.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => Prerequisite a -> Set (Signed a)
getDistinctConstants forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrerequisiteConfig -> Prerequisite ObjectiveLabel
logic
isAcyclicGraph :: [SCC Objective] -> Bool
isAcyclicGraph :: [SCC Objective] -> Bool
isAcyclicGraph =
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall {vertex}. SCC vertex -> Bool
isAcyclicVertex
where
isAcyclicVertex :: SCC vertex -> Bool
isAcyclicVertex = \case
AcyclicSCC vertex
_ -> Bool
True
SCC vertex
_ -> Bool
False
makeGraphInfo :: ObjectiveCompletion -> GraphInfo
makeGraphInfo :: ObjectiveCompletion -> GraphInfo
makeGraphInfo ObjectiveCompletion
oc =
Graph -> Bool -> [SCC Objective] -> [ObjectiveId] -> GraphInfo
GraphInfo
(Edges -> Graph
makeGraph Edges
edges)
([SCC Objective] -> Bool
isAcyclicGraph [SCC Objective]
connectedComponents)
[SCC Objective]
connectedComponents
(forall k a. Map k a -> [k]
M.keys forall a b. (a -> b) -> a -> b
$ [Objective] -> Map ObjectiveId Objective
assignIds [Objective]
objs)
where
edges :: Edges
edges = [Objective] -> Edges
makeGraphEdges [Objective]
objs
connectedComponents :: [SCC Objective]
connectedComponents = forall key node. Ord key => [(node, key, [key])] -> [SCC node]
stronglyConnComp Edges
edges
objs :: [Objective]
objs = CompletionBuckets -> [Objective]
listAllObjectives forall a b. (a -> b) -> a -> b
$ ObjectiveCompletion -> CompletionBuckets
completionBuckets ObjectiveCompletion
oc