-- Copyright 2013 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

-- | Some functions missing from "Data.Graph".
module Util.Graphs where
import qualified Data.List as List
import qualified Data.Set as Set
import qualified Data.Array.IArray as IArray
import Data.Array.IArray ( (!), (//) )
import Data.Graph
import qualified Data.Tree as Tree

import qualified Util.Array as Array
import qualified Util.Seq as Seq


build :: [Edge] -> Graph
build :: [Edge] -> Graph
build [Edge]
edges = Edge -> [Edge] -> Graph
buildG (Vertex
0, Vertex
upper) [Edge]
unique
    where
    unique :: [Edge]
unique = [Edge] -> [Edge]
forall a. Ord a => [a] -> [a]
Seq.unique [Edge]
edges
    upper :: Vertex
upper = [Vertex] -> Vertex
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (-Vertex
1 Vertex -> [Vertex] -> [Vertex]
forall a. a -> [a] -> [a]
: (Edge -> Vertex) -> [Edge] -> [Vertex]
forall a b. (a -> b) -> [a] -> [b]
map (\(Vertex
x, Vertex
y) -> Vertex -> Vertex -> Vertex
forall a. Ord a => a -> a -> a
max Vertex
x Vertex
y) [Edge]
unique)

-- | Roots are all vertices with no parents.
roots_of :: Graph -> [Vertex]
roots_of :: Graph -> [Vertex]
roots_of Graph
graph =
    Set Vertex -> [Vertex]
forall a. Set a -> [a]
Set.toList (Set Vertex -> [Vertex]) -> Set Vertex -> [Vertex]
forall a b. (a -> b) -> a -> b
$ (Set Vertex -> Vertex -> Set Vertex)
-> Set Vertex -> [Vertex] -> Set Vertex
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' ((Vertex -> Set Vertex -> Set Vertex)
-> Set Vertex -> Vertex -> Set Vertex
forall a b c. (a -> b -> c) -> b -> a -> c
flip Vertex -> Set Vertex -> Set Vertex
forall a. Ord a => a -> Set a -> Set a
Set.delete) ([Vertex] -> Set Vertex
forall a. Ord a => [a] -> Set a
Set.fromList [Vertex
lo..Vertex
hi])
        ([[Vertex]] -> [Vertex]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Graph -> [[Vertex]]
forall (a :: * -> * -> *) e i. (IArray a e, Ix i) => a i e -> [e]
IArray.elems Graph
graph))
    where (Vertex
lo, Vertex
hi) = Graph -> Edge
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
IArray.bounds Graph
graph

-- | This is like 'dfs', except it allows duplicated vertices.  So don't
-- use it one a graph with cycles.
to_forest :: Graph -> Tree.Forest Vertex
to_forest :: Graph -> Forest Vertex
to_forest Graph
graph = (Vertex -> Tree Vertex) -> [Vertex] -> Forest Vertex
forall a b. (a -> b) -> [a] -> [b]
map (Graph -> Vertex -> Tree Vertex
forall {a :: * -> * -> *} {a}.
(IArray a [a], Ix a) =>
a a [a] -> a -> Tree a
generate Graph
graph) (Graph -> [Vertex]
roots_of Graph
graph)
    where
    generate :: a a [a] -> a -> Tree a
generate a a [a]
graph a
vertex = a -> [Tree a] -> Tree a
forall a. a -> [Tree a] -> Tree a
Node a
vertex ((a -> Tree a) -> [a] -> [Tree a]
forall a b. (a -> b) -> [a] -> [b]
map (a a [a] -> a -> Tree a
generate a a [a]
graph) (a a [a]
grapha a [a] -> a -> [a]
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
!a
vertex))

draw :: Graph -> String
draw :: Graph -> String
draw = [Tree String] -> String
Tree.drawForest ([Tree String] -> String)
-> (Graph -> [Tree String]) -> Graph -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tree Vertex -> Tree String) -> Forest Vertex -> [Tree String]
forall a b. (a -> b) -> [a] -> [b]
map ((Vertex -> String) -> Tree Vertex -> Tree String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Vertex -> String
forall a. Show a => a -> String
show) (Forest Vertex -> [Tree String])
-> (Graph -> Forest Vertex) -> Graph -> [Tree String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph -> Forest Vertex
to_forest

-- | Remove the edge if it already exists, create a new one of it doesn't.
-- Return Nothing if adding an edge would create a cycle.
toggle_edge :: Edge -> Graph -> Maybe Graph
toggle_edge :: Edge -> Graph -> Maybe Graph
toggle_edge Edge
edge Graph
graph
    | Graph -> Edge -> Bool
has_edge Graph
graph Edge
edge = Graph -> Maybe Graph
forall a. a -> Maybe a
Just ([Edge] -> Graph -> Graph
remove_edges [Edge
edge] Graph
graph)
    | Edge -> Graph -> Bool
would_make_cycle Edge
edge Graph
graph = Maybe Graph
forall a. Maybe a
Nothing
    | Bool
otherwise = Graph -> Maybe Graph
forall a. a -> Maybe a
Just (Graph -> Maybe Graph) -> Graph -> Maybe Graph
forall a b. (a -> b) -> a -> b
$ [Edge] -> Graph -> Graph
add_edges [Edge
edge] Graph
graph

-- | Splice @new@ into the graph above @to@.  The parents of @to@ are detached
-- from it and re-attached to @new@.  Then @new@ is attached above @to@.
--
-- This operation should be idempotent.
splice_above :: Vertex -> Vertex -> Graph -> Graph
splice_above :: Vertex -> Vertex -> Graph -> Graph
splice_above Vertex
new Vertex
to Graph
graph =
    -- If I don't filter p/=new, a duplicate splice will cause a vertex to
    -- loop back to itself.
    [Edge] -> Graph -> Graph
add_edges ((Vertex
new, Vertex
to) Edge -> [Edge] -> [Edge]
forall a. a -> [a] -> [a]
: [(Vertex
p, Vertex
new) | Vertex
p <- [Vertex]
ps, Vertex
p Vertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
/= Vertex
new]) (Graph -> Graph) -> Graph -> Graph
forall a b. (a -> b) -> a -> b
$
        [Edge] -> Graph -> Graph
remove_edges [(Vertex
p, Vertex
to) | Vertex
p <- [Vertex]
ps] Graph
graph
    where ps :: [Vertex]
ps = Graph -> Vertex -> [Vertex]
parents Graph
graph Vertex
to

-- | Splice @new@ into the graph below @to@.  The children of @to@ are
-- detached and re-attached to @new@.  Then @to@ is attached above @new@.
--
-- This operation should be idempotent.
splice_below :: Vertex -> Vertex -> Graph -> Graph
splice_below :: Vertex -> Vertex -> Graph -> Graph
splice_below Vertex
new Vertex
to Graph
graph =
    [Edge] -> Graph -> Graph
add_edges ((Vertex
to, Vertex
new) Edge -> [Edge] -> [Edge]
forall a. a -> [a] -> [a]
: [(Vertex
new, Vertex
c) | Vertex
c <- [Vertex]
cs, Vertex
c Vertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
/= Vertex
new]) (Graph -> Graph) -> Graph -> Graph
forall a b. (a -> b) -> a -> b
$
        [Edge] -> Graph -> Graph
remove_edges ((Vertex -> Edge) -> [Vertex] -> [Edge]
forall a b. (a -> b) -> [a] -> [b]
map ((,) Vertex
to) [Vertex]
cs) Graph
graph
    where cs :: [Vertex]
cs = Graph -> Vertex -> [Vertex]
children Graph
graph Vertex
to

-- | Get the parents of a Vertex.
parents :: Graph -> Vertex -> [Vertex]
parents :: Graph -> Vertex -> [Vertex]
parents Graph
graph Vertex
v = [Vertex
p | (Vertex
p, [Vertex]
cs) <- Graph -> [(Vertex, [Vertex])]
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> [(i, e)]
IArray.assocs Graph
graph, Vertex
v Vertex -> [Vertex] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Vertex]
cs]

-- | Get the children of a Vertex.
children :: Graph -> Vertex -> [Vertex]
children :: Graph -> Vertex -> [Vertex]
children Graph
graph Vertex
v
    | Vertex -> Graph -> Bool
forall a. Vertex -> Array a -> Bool
Array.in_bounds Vertex
v Graph
graph = Graph
graphGraph -> Vertex -> [Vertex]
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
!Vertex
v
    | Bool
otherwise = []

would_make_cycle :: Edge -> Graph -> Bool
would_make_cycle :: Edge -> Graph -> Bool
would_make_cycle (Vertex
from, Vertex
to) Graph
graph =
    Vertex
from Vertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
== Vertex
to
    Bool -> Bool -> Bool
|| Vertex -> Graph -> Bool
forall a. Vertex -> Array a -> Bool
Array.in_bounds Vertex
from Graph
graph Bool -> Bool -> Bool
&& Vertex -> Graph -> Bool
forall a. Vertex -> Array a -> Bool
Array.in_bounds Vertex
to Graph
graph
        Bool -> Bool -> Bool
&& Graph -> Vertex -> Vertex -> Bool
path Graph
graph Vertex
to Vertex
from

has_cycle :: Graph -> Bool
has_cycle :: Graph -> Bool
has_cycle Graph
graph = (Tree Vertex -> Bool) -> Forest Vertex -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> Bool
not (Bool -> Bool) -> (Tree Vertex -> Bool) -> Tree Vertex -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Forest Vertex -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Forest Vertex -> Bool)
-> (Tree Vertex -> Forest Vertex) -> Tree Vertex -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree Vertex -> Forest Vertex
forall a. Tree a -> [Tree a]
Tree.subForest) (Graph -> Forest Vertex
scc Graph
graph)
    Bool -> Bool -> Bool
|| (Edge -> Bool) -> [Edge] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Vertex -> Vertex -> Bool) -> Edge -> Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Vertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
(==)) (Graph -> [Edge]
edges Graph
graph)

has_edge :: Graph -> Edge -> Bool
has_edge :: Graph -> Edge -> Bool
has_edge Graph
graph (Vertex
from, Vertex
to) = Vertex -> Graph -> Bool
forall a. Vertex -> Array a -> Bool
Array.in_bounds Vertex
from Graph
graph Bool -> Bool -> Bool
&& Vertex
to Vertex -> [Vertex] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Graph
graphGraph -> Vertex -> [Vertex]
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
!Vertex
from

-- | A lonely vertex has no edges.
lonely_vertex :: Graph -> Vertex -> Bool
lonely_vertex :: Graph -> Vertex -> Bool
lonely_vertex Graph
graph Vertex
vertex =
    Bool -> Bool
not (Vertex -> Graph -> Bool
forall a. Vertex -> Array a -> Bool
Array.in_bounds Vertex
vertex Graph
graph) Bool -> Bool -> Bool
|| [Vertex] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Graph
graphGraph -> Vertex -> [Vertex]
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
!Vertex
vertex)

add_edges :: [Edge] -> Graph -> Graph
add_edges :: [Edge] -> Graph -> Graph
add_edges [Edge]
edges Graph
graph =
    ([Vertex] -> Vertex -> [Vertex])
-> [Vertex] -> Edge -> [Edge] -> Graph
forall (a :: * -> * -> *) e i e'.
(IArray a e, Ix i) =>
(e -> e' -> e) -> e -> (i, i) -> [(i, e')] -> a i e
IArray.accumArray [Vertex] -> Vertex -> [Vertex]
forall {a}. Eq a => [a] -> a -> [a]
add [] Edge
new_bounds
        ([Edge]
edges [Edge] -> [Edge] -> [Edge]
forall a. [a] -> [a] -> [a]
++ [(Vertex
p, Vertex
c) | (Vertex
p, [Vertex]
cs) <- Graph -> [(Vertex, [Vertex])]
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> [(i, e)]
IArray.assocs Graph
graph, Vertex
c <- [Vertex]
cs])
    where
    (Vertex
low, Vertex
high) = Graph -> Edge
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
IArray.bounds Graph
graph
    flattened :: [Vertex]
flattened = [Vertex
v | (Vertex
p, Vertex
c) <- [Edge]
edges, Vertex
v <- [Vertex
p, Vertex
c]]
    new_bounds :: Edge
new_bounds = ([Vertex] -> Vertex
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum (Vertex
low Vertex -> [Vertex] -> [Vertex]
forall a. a -> [a] -> [a]
: [Vertex]
flattened), [Vertex] -> Vertex
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (Vertex
high Vertex -> [Vertex] -> [Vertex]
forall a. a -> [a] -> [a]
: [Vertex]
flattened))
    add :: [a] -> a -> [a]
add [a]
cs a
c = if a
c a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [a]
cs then [a]
cs else a
ca -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
cs

remove_edges :: [Edge] -> Graph -> Graph
remove_edges :: [Edge] -> Graph -> Graph
remove_edges [Edge]
edges Graph
graph
    | [Edge] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Edge]
edges = Graph
graph
    | Bool
otherwise =
        Graph
graph Graph -> [(Vertex, [Vertex])] -> Graph
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> [(i, e)] -> a i e
// [(Vertex
from, (Vertex -> Bool) -> [Vertex] -> [Vertex]
forall a. (a -> Bool) -> [a] -> [a]
filter (Vertex -> [Vertex] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` (Edge -> Vertex) -> [Edge] -> [Vertex]
forall a b. (a -> b) -> [a] -> [b]
map Edge -> Vertex
forall a b. (a, b) -> b
snd [Edge]
groups) (Graph
graphGraph -> Vertex -> [Vertex]
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
!Vertex
from))
            | (Vertex
from, [Edge]
groups) <- [(Vertex, [Edge])]
grouped]
    where
    in_bounds :: [Edge]
in_bounds = (Edge -> Bool) -> [Edge] -> [Edge]
forall a. (a -> Bool) -> [a] -> [a]
filter ((\Vertex
p -> Vertex -> Graph -> Bool
forall a. Vertex -> Array a -> Bool
Array.in_bounds Vertex
p Graph
graph) (Vertex -> Bool) -> (Edge -> Vertex) -> Edge -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Edge -> Vertex
forall a b. (a, b) -> a
fst) [Edge]
edges
    grouped :: [(Vertex, [Edge])]
grouped = (Edge -> Vertex) -> [Edge] -> [(Vertex, [Edge])]
forall key a. Ord key => (a -> key) -> [a] -> [(key, [a])]
Seq.keyed_group_sort Edge -> Vertex
forall a b. (a, b) -> a
fst [Edge]
in_bounds

-- | Increment all vertices at and above, insert new empty vertex.
insert_vertex :: Int -> Graph -> Graph
insert_vertex :: Vertex -> Graph -> Graph
insert_vertex Vertex
vertex Graph
graph = (Vertex -> Vertex) -> Graph -> Graph
map_vertices Vertex -> Vertex
incr Graph
graph
    where incr :: Vertex -> Vertex
incr Vertex
v = if Vertex
v Vertex -> Vertex -> Bool
forall a. Ord a => a -> a -> Bool
< Vertex
vertex then Vertex
v else Vertex
vVertex -> Vertex -> Vertex
forall a. Num a => a -> a -> a
+Vertex
1

-- | Remove a vertex.  All vertices pointing to the removed vertex instead
-- point to what pointed to it.
remove_vertex :: Int -> Graph -> Graph
remove_vertex :: Vertex -> Graph -> Graph
remove_vertex Vertex
vertex Graph
graph
    | Vertex
vertex Vertex -> Graph -> Bool
forall a. Vertex -> Array a -> Bool
`Array.in_bounds` Graph
graph =
        (Vertex -> Vertex) -> Graph -> Graph
map_vertices Vertex -> Vertex
decr (Vertex -> Graph -> Graph
unlink_vertex Vertex
vertex Graph
graph)
    | Bool
otherwise = Graph
graph
    where decr :: Vertex -> Vertex
decr Vertex
v = if Vertex
v Vertex -> Vertex -> Bool
forall a. Ord a => a -> a -> Bool
> Vertex
vertex then Vertex
vVertex -> Vertex -> Vertex
forall a. Num a => a -> a -> a
-Vertex
1 else Vertex
v

-- | All vertices pointing to the removed vertex instead point to what pointed
-- to it.  It will be removed from the list of roots.
unlink_vertex :: Int -> Graph -> Graph
unlink_vertex :: Vertex -> Graph -> Graph
unlink_vertex Vertex
vertex Graph
graph =
    ([Vertex] -> [Vertex]) -> Graph -> Graph
forall (a :: * -> * -> *) e' e i.
(IArray a e', IArray a e, Ix i) =>
(e' -> e) -> a i e' -> a i e
IArray.amap (Vertex -> [Vertex] -> [Vertex] -> [Vertex]
forall a. Eq a => a -> [a] -> [a] -> [a]
Seq.replace1 Vertex
v (Graph
graphGraph -> Vertex -> [Vertex]
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
!Vertex
v)) Graph
graph Graph -> [(Vertex, [Vertex])] -> Graph
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> [(i, e)] -> a i e
// [(Vertex
v, [])]
    where v :: Vertex
v = String -> Vertex -> Graph -> Vertex
forall a. String -> Vertex -> Array a -> Vertex
Array.assert_in_bounds String
"unlink_vertex" Vertex
vertex Graph
graph


-- | Transform all the vertices by the given function.  If multiple vertices
-- are transformed to the same value, the one with the originally highest
-- vertex wins.
map_vertices :: (Vertex -> Vertex) -> Graph -> Graph
map_vertices :: (Vertex -> Vertex) -> Graph -> Graph
map_vertices Vertex -> Vertex
f Graph
graph = [[Vertex]] -> Graph
forall a. [a] -> Array a
Array.from_list ([[Vertex]] -> Graph) -> [[Vertex]] -> Graph
forall a b. (a -> b) -> a -> b
$
    [Vertex] -> [(Vertex, [Vertex])] -> [[Vertex]]
forall a. a -> [(Vertex, a)] -> [a]
strip_indices [] ([(Vertex, [Vertex])] -> [[Vertex]])
-> [(Vertex, [Vertex])] -> [[Vertex]]
forall a b. (a -> b) -> a -> b
$ ((Vertex, [Vertex]) -> Vertex)
-> [(Vertex, [Vertex])] -> [(Vertex, [Vertex])]
forall k a. Eq k => (a -> k) -> [a] -> [a]
Seq.drop_initial_dups (Vertex, [Vertex]) -> Vertex
forall a b. (a, b) -> a
fst ([(Vertex, [Vertex])] -> [(Vertex, [Vertex])])
-> [(Vertex, [Vertex])] -> [(Vertex, [Vertex])]
forall a b. (a -> b) -> a -> b
$
        ((Vertex, [Vertex]) -> (Vertex, [Vertex]))
-> [(Vertex, [Vertex])] -> [(Vertex, [Vertex])]
forall a b. (a -> b) -> [a] -> [b]
map (\(Vertex
p, [Vertex]
cs) -> (Vertex -> Vertex
f Vertex
p, (Vertex -> Vertex) -> [Vertex] -> [Vertex]
forall a b. (a -> b) -> [a] -> [b]
map Vertex -> Vertex
f [Vertex]
cs)) (Graph -> [(Vertex, [Vertex])]
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> [(i, e)]
IArray.assocs Graph
graph)

strip_indices :: a -> [(Int, a)] -> [a]
strip_indices :: forall a. a -> [(Vertex, a)] -> [a]
strip_indices a
def = Vertex -> [(Vertex, a)] -> [a]
forall {t}. (Ord t, Num t) => t -> [(t, a)] -> [a]
go Vertex
0
    where
    go :: t -> [(t, a)] -> [a]
go t
_ [] = []
    go t
prev lst :: [(t, a)]
lst@((t
i, a
v):[(t, a)]
xs)
        | t
prev t -> t -> Bool
forall a. Ord a => a -> a -> Bool
< t
i = a
def a -> [a] -> [a]
forall a. a -> [a] -> [a]
: t -> [(t, a)] -> [a]
go (t
prevt -> t -> t
forall a. Num a => a -> a -> a
+t
1) [(t, a)]
lst
        | Bool
otherwise = a
v a -> [a] -> [a]
forall a. a -> [a] -> [a]
: t -> [(t, a)] -> [a]
go (t
prevt -> t -> t
forall a. Num a => a -> a -> a
+t
1) [(t, a)]
xs

-- | Move a vertex.  The graph remains the same, but the @from@ vertex number
-- will be changed to @to@ and vice versa.
move :: Vertex -> Vertex -> Graph -> Maybe Graph
move :: Vertex -> Vertex -> Graph -> Maybe Graph
move Vertex
from Vertex
to Graph
graph = (Graph -> Graph) -> Maybe Graph -> Maybe Graph
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Graph -> Graph
forall {a :: * -> * -> *}.
IArray a [Vertex] =>
a Vertex [Vertex] -> a Vertex [Vertex]
move (Maybe Graph -> Maybe Graph) -> Maybe Graph -> Maybe Graph
forall a b. (a -> b) -> a -> b
$ Vertex -> Graph -> Maybe Graph
forall a. Vertex -> Array a -> Maybe (Array a)
Array.check Vertex
to (Graph -> Maybe Graph) -> Maybe Graph -> Maybe Graph
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Vertex -> Graph -> Maybe Graph
forall a. Vertex -> Array a -> Maybe (Array a)
Array.check Vertex
from Graph
graph
    where
    -- Swap array elements.  Then swap all referents
    move :: a Vertex [Vertex] -> a Vertex [Vertex]
move a Vertex [Vertex]
graph
        | Vertex
from Vertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
== Vertex
to = a Vertex [Vertex]
graph
        | Bool
otherwise = ([Vertex] -> [Vertex]) -> a Vertex [Vertex] -> a Vertex [Vertex]
forall (a :: * -> * -> *) e' e i.
(IArray a e', IArray a e, Ix i) =>
(e' -> e) -> a i e' -> a i e
IArray.amap ((Vertex -> Vertex) -> [Vertex] -> [Vertex]
forall a b. (a -> b) -> [a] -> [b]
map Vertex -> Vertex
relink) (a Vertex [Vertex] -> a Vertex [Vertex])
-> a Vertex [Vertex] -> a Vertex [Vertex]
forall a b. (a -> b) -> a -> b
$
            a Vertex [Vertex]
graph a Vertex [Vertex] -> [(Vertex, [Vertex])] -> a Vertex [Vertex]
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> [(i, e)] -> a i e
// [(Vertex
from, a Vertex [Vertex]
grapha Vertex [Vertex] -> Vertex -> [Vertex]
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
!Vertex
to), (Vertex
to, a Vertex [Vertex]
grapha Vertex [Vertex] -> Vertex -> [Vertex]
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
!Vertex
from)]
    relink :: Vertex -> Vertex
relink Vertex
v
        | Vertex
v Vertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
== Vertex
from = Vertex
to
        | Vertex
v Vertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
== Vertex
to = Vertex
from
        | Bool
otherwise = Vertex
v