{-# LANGUAGE GADTs #-}

module HGraph.Directed
       ( DirectedGraph(..)
       , Adjacency(..)
       , Mutable(..)
       )
where

import qualified Data.Map as M
import qualified Data.Set as S

class DirectedGraph t where
  empty :: t a -> t a
  vertices :: t a -> [a]
  numVertices :: Integral b => t a -> b
  numVertices t a
d = Int -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> b) -> Int -> b
forall a b. (a -> b) -> a -> b
$ [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([a] -> Int) -> [a] -> Int
forall a b. (a -> b) -> a -> b
$ t a -> [a]
forall (t :: * -> *) a. DirectedGraph t => t a -> [a]
vertices t a
d
  arcs :: t a -> [(a,a)]
  numArcs :: Integral b => t a -> b
  numArcs t a
d = Int -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> b) -> Int -> b
forall a b. (a -> b) -> a -> b
$ [(a, a)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([(a, a)] -> Int) -> [(a, a)] -> Int
forall a b. (a -> b) -> a -> b
$ t a -> [(a, a)]
forall (t :: * -> *) a. DirectedGraph t => t a -> [(a, a)]
arcs t a
d
  linearizeVertices :: t a -> (t Int, [(Int, a)])
  isVertex :: t a -> a -> Bool

class Adjacency t where
  outneighbors :: t a -> a -> [a]
  inneighbors  :: t a -> a -> [a]
  outdegree :: Integral b => t a -> a -> b
  outdegree t a
d a
v = Int -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> b) -> Int -> b
forall a b. (a -> b) -> a -> b
$ [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([a] -> Int) -> [a] -> Int
forall a b. (a -> b) -> a -> b
$ t a -> a -> [a]
forall (t :: * -> *) a. Adjacency t => t a -> a -> [a]
outneighbors t a
d a
v
  indegree :: Integral b => t a -> a -> b
  indegree t a
d a
v = Int -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> b) -> Int -> b
forall a b. (a -> b) -> a -> b
$ [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([a] -> Int) -> [a] -> Int
forall a b. (a -> b) -> a -> b
$ t a -> a -> [a]
forall (t :: * -> *) a. Adjacency t => t a -> a -> [a]
inneighbors t a
d a
v
  arcExists :: t a -> (a,a) -> Bool
  metaBfs :: Ord a => t a -> a -> ([a] -> [a]) -> ([a] -> [a]) -> [a]
  metaBfs t a
d a
v [a] -> [a]
inFilter [a] -> [a]
outFilter =
    Set a -> Set a -> [a]
metaBfs' Set a
forall a. Set a
S.empty ([a] -> Set a
forall a. Ord a => [a] -> Set a
S.fromList ([a] -> Set a) -> [a] -> Set a
forall a b. (a -> b) -> a -> b
$ ([a] -> [a]
inFilter ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ t a -> a -> [a]
forall (t :: * -> *) a. Adjacency t => t a -> a -> [a]
inneighbors t a
d a
v) [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ ([a] -> [a]
outFilter ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ t a -> a -> [a]
forall (t :: * -> *) a. Adjacency t => t a -> a -> [a]
outneighbors t a
d a
v))
    where
      metaBfs' :: Set a -> Set a -> [a]
metaBfs' Set a
visited Set a
toVisit = 
        let vs :: [a]
vs = Set a -> [a]
forall a. Set a -> [a]
S.toList Set a
toVisit
            newToVisit :: Set a
newToVisit =
              ([Set a] -> Set a
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions ([Set a] -> Set a) -> [Set a] -> Set a
forall a b. (a -> b) -> a -> b
$ (a -> Set a) -> [a] -> [Set a]
forall a b. (a -> b) -> [a] -> [b]
map
                ([a] -> Set a
forall a. Ord a => [a] -> Set a
S.fromList ([a] -> Set a) -> (a -> [a]) -> a -> Set a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 
                  (\a
v -> ([a] -> [a]
inFilter ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ t a -> a -> [a]
forall (t :: * -> *) a. Adjacency t => t a -> a -> [a]
inneighbors t a
d a
v) [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ ([a] -> [a]
outFilter ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ t a -> a -> [a]
forall (t :: * -> *) a. Adjacency t => t a -> a -> [a]
outneighbors t a
d a
v)))
                [a]
vs
              )
              Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
`S.difference` Set a
visited
        in if Set a -> Bool
forall a. Set a -> Bool
S.null Set a
newToVisit then [a]
vs else [a]
vs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ Set a -> Set a -> [a]
metaBfs' (Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
S.union ([a] -> Set a
forall a. Ord a => [a] -> Set a
S.fromList [a]
vs) Set a
visited) Set a
newToVisit

class Mutable t where
  addVertex    :: a -> t a -> t a
  removeVertex :: a -> t a -> t a
  addArc    :: (a,a) -> t a -> t a
  removeArc :: (a,a) -> t a -> t a