{-# 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 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

-- | 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
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

-- | 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 =
  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

-- | 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 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])]

-- | 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
_) = 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