{-# OPTIONS_GHC -fno-warn-orphans #-}

-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Utilities for performing graph analysis on Objective prerequisites
module Swarm.Game.Scenario.Objective.Graph where

import Control.Arrow ((&&&))
import Control.Lens (view, (^.), (^..))
import Data.Aeson
import Data.BoolExpr (Signed (Positive))
import Data.BoolExpr qualified as BE
import Data.Graph (Graph, SCC, graphFromEdges, stronglyConnComp)
import Data.Map (Map)
import Data.Map.Strict qualified as M
import Data.Maybe (mapMaybe)
import Data.Set (Set)
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.Util.Graph (isAcyclicGraph)

-- | 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 (ObjectiveId -> ObjectiveId -> Bool
(ObjectiveId -> ObjectiveId -> Bool)
-> (ObjectiveId -> ObjectiveId -> Bool) -> Eq ObjectiveId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ObjectiveId -> ObjectiveId -> Bool
== :: ObjectiveId -> ObjectiveId -> Bool
$c/= :: ObjectiveId -> ObjectiveId -> Bool
/= :: ObjectiveId -> ObjectiveId -> Bool
Eq, Eq ObjectiveId
Eq ObjectiveId =>
(ObjectiveId -> ObjectiveId -> Ordering)
-> (ObjectiveId -> ObjectiveId -> Bool)
-> (ObjectiveId -> ObjectiveId -> Bool)
-> (ObjectiveId -> ObjectiveId -> Bool)
-> (ObjectiveId -> ObjectiveId -> Bool)
-> (ObjectiveId -> ObjectiveId -> ObjectiveId)
-> (ObjectiveId -> ObjectiveId -> ObjectiveId)
-> Ord 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
$ccompare :: ObjectiveId -> ObjectiveId -> Ordering
compare :: ObjectiveId -> ObjectiveId -> Ordering
$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
>= :: ObjectiveId -> ObjectiveId -> Bool
$cmax :: ObjectiveId -> ObjectiveId -> ObjectiveId
max :: ObjectiveId -> ObjectiveId -> ObjectiveId
$cmin :: ObjectiveId -> ObjectiveId -> ObjectiveId
min :: ObjectiveId -> ObjectiveId -> ObjectiveId
Ord, Int -> ObjectiveId -> ShowS
[ObjectiveId] -> ShowS
ObjectiveId -> String
(Int -> ObjectiveId -> ShowS)
-> (ObjectiveId -> String)
-> ([ObjectiveId] -> ShowS)
-> Show ObjectiveId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ObjectiveId -> ShowS
showsPrec :: Int -> ObjectiveId -> ShowS
$cshow :: ObjectiveId -> String
show :: ObjectiveId -> String
$cshowList :: [ObjectiveId] -> ShowS
showList :: [ObjectiveId] -> ShowS
Show, (forall x. ObjectiveId -> Rep ObjectiveId x)
-> (forall x. Rep ObjectiveId x -> ObjectiveId)
-> Generic ObjectiveId
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
$cfrom :: forall x. ObjectiveId -> Rep ObjectiveId x
from :: forall x. ObjectiveId -> Rep ObjectiveId x
$cto :: forall x. Rep ObjectiveId x -> ObjectiveId
to :: forall x. Rep ObjectiveId x -> ObjectiveId
Generic, [ObjectiveId] -> Value
[ObjectiveId] -> Encoding
ObjectiveId -> Bool
ObjectiveId -> Value
ObjectiveId -> Encoding
(ObjectiveId -> Value)
-> (ObjectiveId -> Encoding)
-> ([ObjectiveId] -> Value)
-> ([ObjectiveId] -> Encoding)
-> (ObjectiveId -> Bool)
-> ToJSON ObjectiveId
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: ObjectiveId -> Value
toJSON :: ObjectiveId -> Value
$ctoEncoding :: ObjectiveId -> Encoding
toEncoding :: ObjectiveId -> Encoding
$ctoJSONList :: [ObjectiveId] -> Value
toJSONList :: [ObjectiveId] -> Value
$ctoEncodingList :: [ObjectiveId] -> Encoding
toEncodingList :: [ObjectiveId] -> Encoding
$comitField :: ObjectiveId -> Bool
omitField :: ObjectiveId -> Bool
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
(Int -> GraphInfo -> ShowS)
-> (GraphInfo -> String)
-> ([GraphInfo] -> ShowS)
-> Show GraphInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GraphInfo -> ShowS
showsPrec :: Int -> GraphInfo -> ShowS
$cshow :: GraphInfo -> String
show :: GraphInfo -> String
$cshowList :: [GraphInfo] -> ShowS
showList :: [GraphInfo] -> ShowS
Show, (forall x. GraphInfo -> Rep GraphInfo x)
-> (forall x. Rep GraphInfo x -> GraphInfo) -> Generic GraphInfo
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
$cfrom :: forall x. GraphInfo -> Rep GraphInfo x
from :: forall x. GraphInfo -> Rep GraphInfo x
$cto :: forall x. Rep GraphInfo x -> GraphInfo
to :: forall x. Rep GraphInfo x -> GraphInfo
Generic, [GraphInfo] -> Value
[GraphInfo] -> Encoding
GraphInfo -> Bool
GraphInfo -> Value
GraphInfo -> Encoding
(GraphInfo -> Value)
-> (GraphInfo -> Encoding)
-> ([GraphInfo] -> Value)
-> ([GraphInfo] -> Encoding)
-> (GraphInfo -> Bool)
-> ToJSON GraphInfo
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: GraphInfo -> Value
toJSON :: GraphInfo -> Value
$ctoEncoding :: GraphInfo -> Encoding
toEncoding :: GraphInfo -> Encoding
$ctoJSONList :: [GraphInfo] -> Value
toJSONList :: [GraphInfo] -> Value
$ctoEncodingList :: [GraphInfo] -> Encoding
toEncodingList :: [GraphInfo] -> Encoding
$comitField :: GraphInfo -> Bool
omitField :: GraphInfo -> Bool
ToJSON)

instance ToJSON (SCC Objective) where
  toJSON :: SCC Objective -> Value
toJSON = ObjectiveLabel -> Value
String (ObjectiveLabel -> Value)
-> (SCC Objective -> ObjectiveLabel) -> SCC Objective -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ObjectiveLabel
T.pack (String -> ObjectiveLabel)
-> (SCC Objective -> String) -> SCC Objective -> ObjectiveLabel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SCC Objective -> String
forall a. Show a => a -> String
show

instance ToJSON Graph where
  toJSON :: Graph -> Value
toJSON = ObjectiveLabel -> Value
String (ObjectiveLabel -> Value)
-> (Graph -> ObjectiveLabel) -> Graph -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ObjectiveLabel
T.pack (String -> ObjectiveLabel)
-> (Graph -> String) -> Graph -> ObjectiveLabel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph -> String
forall a. Show a => a -> String
show

instance ToSample GraphInfo where
  toSamples :: Proxy GraphInfo -> [(ObjectiveLabel, GraphInfo)]
toSamples Proxy GraphInfo
_ = [(ObjectiveLabel, GraphInfo)]
forall a. [(ObjectiveLabel, a)]
SD.noSamples

deriving instance Generic (BE.Signed ObjectiveLabel)
deriving instance ToJSON (BE.Signed ObjectiveLabel)

getDistinctConstants :: (Ord a) => Prerequisite a -> Set (BE.Signed a)
getDistinctConstants :: forall a. Ord a => Prerequisite a -> Set (Signed a)
getDistinctConstants = [Signed a] -> Set (Signed a)
forall a. Ord a => [a] -> Set a
Set.fromList ([Signed a] -> Set (Signed a))
-> (Prerequisite a -> [Signed a])
-> Prerequisite a
-> Set (Signed a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BoolExpr a -> [Signed a]
forall a. BoolExpr a -> [Signed a]
BE.constants (BoolExpr a -> [Signed a])
-> (Prerequisite a -> BoolExpr a) -> Prerequisite a -> [Signed a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prerequisite a -> BoolExpr a
forall a. Prerequisite a -> BoolExpr a
toBoolExpr

-- | 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 :: [Objective] -> Map ObjectiveLabel Objective
getNegatedIds [Objective]
objs =
  [(ObjectiveLabel, Objective)] -> Map ObjectiveLabel Objective
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(ObjectiveLabel, Objective)] -> Map ObjectiveLabel Objective)
-> [(ObjectiveLabel, Objective)] -> Map ObjectiveLabel Objective
forall a b. (a -> b) -> a -> b
$ (ObjectiveLabel -> Maybe (ObjectiveLabel, Objective))
-> [ObjectiveLabel] -> [(ObjectiveLabel, Objective)]
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 = (Objective -> Maybe PrerequisiteConfig)
-> [Objective] -> [PrerequisiteConfig]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Getting
  (Maybe PrerequisiteConfig) Objective (Maybe PrerequisiteConfig)
-> Objective -> Maybe PrerequisiteConfig
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (Maybe PrerequisiteConfig) Objective (Maybe PrerequisiteConfig)
Lens' Objective (Maybe PrerequisiteConfig)
objectivePrerequisite) [Objective]
objs
  allConstants :: [ObjectiveLabel]
allConstants =
    (Signed ObjectiveLabel -> Maybe ObjectiveLabel)
-> [Signed ObjectiveLabel] -> [ObjectiveLabel]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Signed ObjectiveLabel -> Maybe ObjectiveLabel
forall {a}. Signed a -> Maybe a
onlyNegative
      ([Signed ObjectiveLabel] -> [ObjectiveLabel])
-> ([PrerequisiteConfig] -> [Signed ObjectiveLabel])
-> [PrerequisiteConfig]
-> [ObjectiveLabel]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (Signed ObjectiveLabel) -> [Signed ObjectiveLabel]
forall a. Set a -> [a]
Set.toList
      (Set (Signed ObjectiveLabel) -> [Signed ObjectiveLabel])
-> ([PrerequisiteConfig] -> Set (Signed ObjectiveLabel))
-> [PrerequisiteConfig]
-> [Signed ObjectiveLabel]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Set (Signed ObjectiveLabel)] -> Set (Signed ObjectiveLabel)
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions
      ([Set (Signed ObjectiveLabel)] -> Set (Signed ObjectiveLabel))
-> ([PrerequisiteConfig] -> [Set (Signed ObjectiveLabel)])
-> [PrerequisiteConfig]
-> Set (Signed ObjectiveLabel)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PrerequisiteConfig -> Set (Signed ObjectiveLabel))
-> [PrerequisiteConfig] -> [Set (Signed ObjectiveLabel)]
forall a b. (a -> b) -> [a] -> [b]
map (Prerequisite ObjectiveLabel -> Set (Signed ObjectiveLabel)
forall a. Ord a => Prerequisite a -> Set (Signed a)
getDistinctConstants (Prerequisite ObjectiveLabel -> Set (Signed ObjectiveLabel))
-> (PrerequisiteConfig -> Prerequisite ObjectiveLabel)
-> PrerequisiteConfig
-> Set (Signed ObjectiveLabel)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrerequisiteConfig -> Prerequisite ObjectiveLabel
logic)
      ([PrerequisiteConfig] -> [ObjectiveLabel])
-> [PrerequisiteConfig] -> [ObjectiveLabel]
forall a b. (a -> b) -> a -> b
$ [PrerequisiteConfig]
allPrereqExpressions

  f :: ObjectiveLabel -> Maybe (ObjectiveLabel, Objective)
f = (ObjectiveLabel, Maybe Objective)
-> Maybe (ObjectiveLabel, Objective)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a.
Applicative f =>
(ObjectiveLabel, f a) -> f (ObjectiveLabel, a)
sequenceA ((ObjectiveLabel, Maybe Objective)
 -> Maybe (ObjectiveLabel, Objective))
-> (ObjectiveLabel -> (ObjectiveLabel, Maybe Objective))
-> ObjectiveLabel
-> Maybe (ObjectiveLabel, Objective)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \ObjectiveLabel
x -> (ObjectiveLabel
x, ObjectiveLabel -> Map ObjectiveLabel Objective -> Maybe Objective
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 -> a -> Maybe a
forall a. a -> Maybe a
Just a
x
    Signed a
_ -> Maybe a
forall a. Maybe a
Nothing

getObjectivesById :: [Objective] -> Map ObjectiveLabel Objective
getObjectivesById :: [Objective] -> Map ObjectiveLabel Objective
getObjectivesById [Objective]
objs =
  [(ObjectiveLabel, Objective)] -> Map ObjectiveLabel Objective
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(ObjectiveLabel, Objective)] -> Map ObjectiveLabel Objective)
-> [(ObjectiveLabel, Objective)] -> Map ObjectiveLabel Objective
forall a b. (a -> b) -> a -> b
$
    ((Objective, ObjectiveLabel) -> (ObjectiveLabel, Objective))
-> [(Objective, ObjectiveLabel)] -> [(ObjectiveLabel, Objective)]
forall a b. (a -> b) -> [a] -> [b]
map (Objective, ObjectiveLabel) -> (ObjectiveLabel, Objective)
forall a b. (a, b) -> (b, a)
swap ([(Objective, ObjectiveLabel)] -> [(ObjectiveLabel, Objective)])
-> [(Objective, ObjectiveLabel)] -> [(ObjectiveLabel, Objective)]
forall a b. (a -> b) -> a -> b
$
      (Objective -> Maybe (Objective, ObjectiveLabel))
-> [Objective] -> [(Objective, ObjectiveLabel)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((Objective, Maybe ObjectiveLabel)
-> Maybe (Objective, ObjectiveLabel)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a.
Applicative f =>
(Objective, f a) -> f (Objective, a)
sequenceA ((Objective, Maybe ObjectiveLabel)
 -> Maybe (Objective, ObjectiveLabel))
-> (Objective -> (Objective, Maybe ObjectiveLabel))
-> Objective
-> Maybe (Objective, ObjectiveLabel)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Objective -> Objective
forall a. a -> a
id (Objective -> Objective)
-> (Objective -> Maybe ObjectiveLabel)
-> Objective
-> (Objective, Maybe ObjectiveLabel)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Getting (Maybe ObjectiveLabel) Objective (Maybe ObjectiveLabel)
-> Objective -> Maybe ObjectiveLabel
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Maybe ObjectiveLabel) Objective (Maybe ObjectiveLabel)
Lens' Objective (Maybe ObjectiveLabel)
objectiveId)) [Objective]
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 :: [Objective] -> Map ObjectiveId Objective
assignIds [Objective]
objs =
  Map ObjectiveId Objective
unlabeledObjsMap Map ObjectiveId Objective
-> Map ObjectiveId Objective -> Map ObjectiveId Objective
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 = (ObjectiveLabel -> ObjectiveId)
-> Map ObjectiveLabel Objective -> Map ObjectiveId Objective
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
M.mapKeys (Signed ObjectiveLabel -> ObjectiveId
Label (Signed ObjectiveLabel -> ObjectiveId)
-> (ObjectiveLabel -> Signed ObjectiveLabel)
-> ObjectiveLabel
-> ObjectiveId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ObjectiveLabel -> Signed ObjectiveLabel
forall a. a -> Signed a
Positive) Map ObjectiveLabel Objective
objectivesById

  unlabeledObjs :: [Objective]
unlabeledObjs = (Objective -> Bool) -> [Objective] -> [Objective]
forall a. (a -> Bool) -> [a] -> [a]
filter (Maybe ObjectiveLabel -> Bool
forall a. Maybe a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Maybe ObjectiveLabel -> Bool)
-> (Objective -> Maybe ObjectiveLabel) -> Objective -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (Maybe ObjectiveLabel) Objective (Maybe ObjectiveLabel)
-> Objective -> Maybe ObjectiveLabel
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Maybe ObjectiveLabel) Objective (Maybe ObjectiveLabel)
Lens' Objective (Maybe ObjectiveLabel)
objectiveId) [Objective]
objs
  unlabeledObjsMap :: Map ObjectiveId Objective
unlabeledObjsMap = [(ObjectiveId, Objective)] -> Map ObjectiveId Objective
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(ObjectiveId, Objective)] -> Map ObjectiveId Objective)
-> [(ObjectiveId, Objective)] -> Map ObjectiveId Objective
forall a b. (a -> b) -> a -> b
$ (Int -> Objective -> (ObjectiveId, Objective))
-> [Int] -> [Objective] -> [(ObjectiveId, Objective)]
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])]

-- | 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 -> Graph
makeGraph Edges
edges =
  Graph
myGraph
 where
  (Graph
myGraph, Int -> (Objective, ObjectiveId, [ObjectiveId])
_, ObjectiveId -> Maybe Int
_) = Edges
-> (Graph, 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 Edges -> Edges -> Edges
forall a. Semigroup a => a -> a -> a
<> Edges
forall {a}. [(Objective, ObjectiveId, [a])]
negatedTuples
 where
  rootTuples :: Edges
rootTuples = ((ObjectiveId, Objective)
 -> (Objective, ObjectiveId, [ObjectiveId]))
-> [(ObjectiveId, Objective)] -> Edges
forall a b. (a -> b) -> [a] -> [b]
map (ObjectiveId, Objective) -> (Objective, ObjectiveId, [ObjectiveId])
forall {b}. (b, Objective) -> (Objective, b, [ObjectiveId])
f ([(ObjectiveId, Objective)] -> Edges)
-> [(ObjectiveId, Objective)] -> Edges
forall a b. (a -> b) -> a -> b
$ Map ObjectiveId Objective -> [(ObjectiveId, Objective)]
forall k a. Map k a -> [(k, a)]
M.toList (Map ObjectiveId Objective -> [(ObjectiveId, Objective)])
-> Map ObjectiveId Objective -> [(ObjectiveId, Objective)]
forall a b. (a -> b) -> a -> b
$ [Objective] -> Map ObjectiveId Objective
assignIds [Objective]
objectives
  negatedTuples :: [(Objective, ObjectiveId, [a])]
negatedTuples = ((ObjectiveLabel, Objective) -> (Objective, ObjectiveId, [a]))
-> [(ObjectiveLabel, Objective)] -> [(Objective, ObjectiveId, [a])]
forall a b. (a -> b) -> [a] -> [b]
map (ObjectiveLabel, Objective) -> (Objective, ObjectiveId, [a])
forall {a} {a}. (ObjectiveLabel, a) -> (a, ObjectiveId, [a])
gg ([(ObjectiveLabel, Objective)] -> [(Objective, ObjectiveId, [a])])
-> [(ObjectiveLabel, Objective)] -> [(Objective, ObjectiveId, [a])]
forall a b. (a -> b) -> a -> b
$ Map ObjectiveLabel Objective -> [(ObjectiveLabel, Objective)]
forall k a. Map k a -> [(k, a)]
M.toList (Map ObjectiveLabel Objective -> [(ObjectiveLabel, Objective)])
-> Map ObjectiveLabel Objective -> [(ObjectiveLabel, Objective)]
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 (Signed ObjectiveLabel -> ObjectiveId)
-> Signed ObjectiveLabel -> ObjectiveId
forall a b. (a -> b) -> a -> b
$ ObjectiveLabel -> Signed ObjectiveLabel
forall a. a -> Signed a
BE.Negative ObjectiveLabel
k, [])

  f :: (b, Objective) -> (Objective, b, [ObjectiveId])
f (b
k, Objective
v) = (Objective
v, b
k, [ObjectiveId]
-> (PrerequisiteConfig -> [ObjectiveId])
-> Maybe PrerequisiteConfig
-> [ObjectiveId]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((Signed ObjectiveLabel -> ObjectiveId)
-> [Signed ObjectiveLabel] -> [ObjectiveId]
forall a b. (a -> b) -> [a] -> [b]
map Signed ObjectiveLabel -> ObjectiveId
Label ([Signed ObjectiveLabel] -> [ObjectiveId])
-> (PrerequisiteConfig -> [Signed ObjectiveLabel])
-> PrerequisiteConfig
-> [ObjectiveId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrerequisiteConfig -> [Signed ObjectiveLabel]
g) (Maybe PrerequisiteConfig -> [ObjectiveId])
-> Maybe PrerequisiteConfig -> [ObjectiveId]
forall a b. (a -> b) -> a -> b
$ Objective
v Objective
-> Getting
     (Maybe PrerequisiteConfig) Objective (Maybe PrerequisiteConfig)
-> Maybe PrerequisiteConfig
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe PrerequisiteConfig) Objective (Maybe PrerequisiteConfig)
Lens' Objective (Maybe PrerequisiteConfig)
objectivePrerequisite)
  g :: PrerequisiteConfig -> [Signed ObjectiveLabel]
g = Set (Signed ObjectiveLabel) -> [Signed ObjectiveLabel]
forall a. Set a -> [a]
Set.toList (Set (Signed ObjectiveLabel) -> [Signed ObjectiveLabel])
-> (PrerequisiteConfig -> Set (Signed ObjectiveLabel))
-> PrerequisiteConfig
-> [Signed ObjectiveLabel]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prerequisite ObjectiveLabel -> Set (Signed ObjectiveLabel)
forall a. Ord a => Prerequisite a -> Set (Signed a)
getDistinctConstants (Prerequisite ObjectiveLabel -> Set (Signed ObjectiveLabel))
-> (PrerequisiteConfig -> Prerequisite ObjectiveLabel)
-> PrerequisiteConfig
-> Set (Signed ObjectiveLabel)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrerequisiteConfig -> Prerequisite ObjectiveLabel
logic

makeGraphInfo :: ObjectiveCompletion -> GraphInfo
makeGraphInfo :: ObjectiveCompletion -> GraphInfo
makeGraphInfo ObjectiveCompletion
oc =
  Graph -> Bool -> [SCC Objective] -> [ObjectiveId] -> GraphInfo
GraphInfo
    (Edges -> Graph
makeGraph Edges
edges)
    ([SCC Objective] -> Bool
forall a. [SCC a] -> Bool
isAcyclicGraph [SCC Objective]
connectedComponents)
    [SCC Objective]
connectedComponents
    (Map ObjectiveId Objective -> [ObjectiveId]
forall k a. Map k a -> [k]
M.keys (Map ObjectiveId Objective -> [ObjectiveId])
-> Map ObjectiveId Objective -> [ObjectiveId]
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 = Edges -> [SCC Objective]
forall key node. Ord key => [(node, key, [key])] -> [SCC node]
stronglyConnComp Edges
edges
  objs :: [Objective]
objs = ObjectiveCompletion
oc ObjectiveCompletion
-> Getting (Endo [Objective]) ObjectiveCompletion Objective
-> [Objective]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. Getting (Endo [Objective]) ObjectiveCompletion Objective
Fold ObjectiveCompletion Objective
allObjectives