module Crem.Graph where
import Crem.Render.RenderableVertices (RenderableVertices (..))
import "base" Data.List (nub)
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)
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]
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
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)
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
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
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)
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)
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
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