-- | A simple data structure to describe a directed graph
module Crem.Graph where

import Crem.Render.RenderableVertices (RenderableVertices (..))
import "base" Data.List (nub)

-- * Graph

-- | A graph is just a list of edges between vertices of type @a@
newtype Graph a = Graph [(a, a)]
  deriving stock (Graph a -> Graph a -> Bool
(Graph a -> Graph a -> Bool)
-> (Graph a -> Graph a -> Bool) -> Eq (Graph a)
forall a. Eq a => Graph a -> Graph a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Graph a -> Graph a -> Bool
== :: Graph a -> Graph a -> Bool
$c/= :: forall a. Eq a => Graph a -> Graph a -> Bool
/= :: Graph a -> Graph a -> Bool
Eq, Int -> Graph a -> ShowS
[Graph a] -> ShowS
Graph a -> String
(Int -> Graph a -> ShowS)
-> (Graph a -> String) -> ([Graph a] -> ShowS) -> Show (Graph a)
forall a. Show a => Int -> Graph a -> ShowS
forall a. Show a => [Graph a] -> ShowS
forall a. Show a => Graph a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Graph a -> ShowS
showsPrec :: Int -> Graph a -> ShowS
$cshow :: forall a. Show a => Graph a -> String
show :: Graph a -> String
$cshowList :: forall a. Show a => [Graph a] -> ShowS
showList :: [Graph a] -> ShowS
Show)

-- | The product graph.
-- It has as vertices the product of the set of vertices of the initial graph.
-- It has as edge from @(a1, b1)@ to @(a2, b2)@ if and only if there is an edge
-- from @a1@ to @a2@ and an edge from @b1@ to @b2@
--
-- >>> productGraph (Graph [('a', 'b')]) (Graph [('c', 'd')])
-- Graph [(('a','c'),('b','d'))]
productGraph :: Graph a -> Graph b -> Graph (a, b)
productGraph :: forall a b. Graph a -> Graph b -> Graph (a, b)
productGraph (Graph [(a, a)]
edges1) (Graph [(b, b)]
edges2) =
  [((a, b), (a, b))] -> Graph (a, b)
forall a. [(a, a)] -> Graph a
Graph ([((a, b), (a, b))] -> Graph (a, b))
-> [((a, b), (a, b))] -> Graph (a, b)
forall a b. (a -> b) -> a -> b
$
    ( \((a
initialEdge1, a
finalEdge1), (b
initialEdge2, b
finalEdge2)) ->
        ((a
initialEdge1, b
initialEdge2), (a
finalEdge1, b
finalEdge2))
    )
      (((a, a), (b, b)) -> ((a, b), (a, b)))
-> [((a, a), (b, b))] -> [((a, b), (a, b))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [((a, a)
edge1, (b, b)
edge2) | (a, a)
edge1 <- [(a, a)]
edges1, (b, b)
edge2 <- [(b, b)]
edges2]

-- | Computes all the possible paths in the input graph and considers them as
-- edges. Notice that the current implementation is removing duplicates
transitiveClosureGraph :: Eq a => Graph a -> Graph a
transitiveClosureGraph :: forall a. Eq a => Graph a -> Graph a
transitiveClosureGraph graph :: Graph a
graph@(Graph [(a, a)]
edges) =
  [(a, a)] -> Graph a
forall a. [(a, a)] -> Graph a
Graph ([(a, a)] -> Graph a) -> [(a, a)] -> Graph a
forall a b. (a -> b) -> a -> b
$
    (a -> [(a, a)] -> [(a, a)]) -> [(a, a)] -> [a] -> [(a, a)]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
      ( \a
a [(a, a)]
edgesSoFar ->
          [(a, a)]
edgesSoFar [(a, a)] -> [(a, a)] -> [(a, a)]
forall a. Semigroup a => a -> a -> a
<> Graph a -> a -> [(a, a)]
forall a. Eq a => Graph a -> a -> [(a, a)]
pathsFrom Graph a
graph a
a
      )
      []
      ([a] -> [a]
forall a. Eq a => [a] -> [a]
nub ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ (a, a) -> a
forall a b. (a, b) -> a
fst ((a, a) -> a) -> [(a, a)] -> [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(a, a)]
edges)
  where
    edgesFrom :: Eq a => Graph a -> a -> [(a, a)]
    edgesFrom :: forall a. Eq a => Graph a -> a -> [(a, a)]
edgesFrom (Graph [(a, a)]
edges') a
a = ((a, a) -> Bool) -> [(a, a)] -> [(a, a)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
a) (a -> Bool) -> ((a, a) -> a) -> (a, a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, a) -> a
forall a b. (a, b) -> a
fst) [(a, a)]
edges'

    pathsFrom :: forall a. Eq a => Graph a -> a -> [(a, a)]
    pathsFrom :: forall a. Eq a => Graph a -> a -> [(a, a)]
pathsFrom Graph a
g a
a =
      let
        edgesFromAToB :: [(a, a)]
edgesFromAToB = Graph a -> a -> [(a, a)]
forall a. Eq a => Graph a -> a -> [(a, a)]
edgesFrom Graph a
g a
a
        pathsFromBToC :: [(a, a)]
pathsFromBToC = [(a, a)]
edgesFromAToB [(a, a)] -> ((a, a) -> [(a, a)]) -> [(a, a)]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Graph a -> a -> [(a, a)]
forall a. Eq a => Graph a -> a -> [(a, a)]
pathsFrom Graph a
g (a -> [(a, a)]) -> ((a, a) -> a) -> (a, a) -> [(a, a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, a) -> a
forall a b. (a, b) -> b
snd
        edgesFromAToC :: [(a, a)]
edgesFromAToC = (a
a,) (a -> (a, a)) -> ((a, a) -> a) -> (a, a) -> (a, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, a) -> a
forall a b. (a, b) -> b
snd ((a, a) -> (a, a)) -> [(a, a)] -> [(a, a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(a, a)]
pathsFromBToC
       in
        [(a, a)]
edgesFromAToB [(a, a)] -> [(a, a)] -> [(a, a)]
forall a. Semigroup a => a -> a -> a
<> [(a, a)]
edgesFromAToC

-- | Add all the identity edges to a graph
addIdentityEdges :: RenderableVertices a => Graph a -> Graph a
addIdentityEdges :: forall a. RenderableVertices a => Graph a -> Graph a
addIdentityEdges (Graph [(a, a)]
edges) = [(a, a)] -> Graph a
forall a. [(a, a)] -> Graph a
Graph ([(a, a)] -> Graph a) -> [(a, a)] -> Graph a
forall a b. (a -> b) -> a -> b
$ [(a, a)]
edges [(a, a)] -> [(a, a)] -> [(a, a)]
forall a. Semigroup a => a -> a -> a
<> ((\a
a -> (a
a, a
a)) (a -> (a, a)) -> [a] -> [(a, a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
forall a. RenderableVertices a => [a]
vertices)

-- | Remove all the edges which start and end at the same vertex
removeIdentityEdges :: Eq a => Graph a -> Graph a
removeIdentityEdges :: forall a. Eq a => Graph a -> Graph a
removeIdentityEdges (Graph [(a, a)]
edges) = [(a, a)] -> Graph a
forall a. [(a, a)] -> Graph a
Graph ([(a, a)] -> Graph a) -> [(a, a)] -> Graph a
forall a b. (a -> b) -> a -> b
$ ((a, a) -> Bool) -> [(a, a)] -> [(a, a)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((a -> a -> Bool) -> (a, a) -> Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry a -> a -> Bool
forall a. Eq a => a -> a -> Bool
(/=)) [(a, a)]
edges

-- * UntypedGraph

-- | A data type to represent a graph which is not tracking the vertex type
data UntypedGraph
  = forall a. (RenderableVertices a, Eq a, Show a) => UntypedGraph (Graph a)

instance Show UntypedGraph where
  show :: UntypedGraph -> String
  show :: UntypedGraph -> String
show (UntypedGraph Graph a
graph) = Graph a -> String
forall a. Show a => a -> String
show Graph a
graph

-- | Same as @productGraph@ but for @UntypedGraph@
untypedProductGraph :: UntypedGraph -> UntypedGraph -> UntypedGraph
untypedProductGraph :: UntypedGraph -> UntypedGraph -> UntypedGraph
untypedProductGraph (UntypedGraph Graph a
graph1) (UntypedGraph Graph a
graph2) =
  Graph (a, a) -> UntypedGraph
forall a.
(RenderableVertices a, Eq a, Show a) =>
Graph a -> UntypedGraph
UntypedGraph (Graph a -> Graph a -> Graph (a, a)
forall a b. Graph a -> Graph b -> Graph (a, b)
productGraph Graph a
graph1 Graph a
graph2)

-- | Same as @transitiveClosureGraph@ but for @UntypedGraph@
untypedTransitiveClosureGraph :: UntypedGraph -> UntypedGraph
untypedTransitiveClosureGraph :: UntypedGraph -> UntypedGraph
untypedTransitiveClosureGraph (UntypedGraph Graph a
graph) =
  Graph a -> UntypedGraph
forall a.
(RenderableVertices a, Eq a, Show a) =>
Graph a -> UntypedGraph
UntypedGraph (Graph a -> Graph a
forall a. Eq a => Graph a -> Graph a
transitiveClosureGraph Graph a
graph)

-- | Add all identity edges to an @UntypedGraph@
untypedAddIdentityEdges :: UntypedGraph -> UntypedGraph
untypedAddIdentityEdges :: UntypedGraph -> UntypedGraph
untypedAddIdentityEdges (UntypedGraph Graph a
graph) =
  Graph a -> UntypedGraph
forall a.
(RenderableVertices a, Eq a, Show a) =>
Graph a -> UntypedGraph
UntypedGraph (Graph a -> UntypedGraph) -> Graph a -> UntypedGraph
forall a b. (a -> b) -> a -> b
$ Graph a -> Graph a
forall a. RenderableVertices a => Graph a -> Graph a
addIdentityEdges Graph a
graph

-- | Remove all the edges which start and end at the same vertex from an
-- @UntypedGraph@
untypedRemoveIdentityEdges :: UntypedGraph -> UntypedGraph
untypedRemoveIdentityEdges :: UntypedGraph -> UntypedGraph
untypedRemoveIdentityEdges (UntypedGraph Graph a
graph) =
  Graph a -> UntypedGraph
forall a.
(RenderableVertices a, Eq a, Show a) =>
Graph a -> UntypedGraph
UntypedGraph (Graph a -> UntypedGraph) -> Graph a -> UntypedGraph
forall a b. (a -> b) -> a -> b
$ Graph a -> Graph a
forall a. Eq a => Graph a -> Graph a
removeIdentityEdges Graph a
graph