module IntLike.Graph
  ( IntLikeGraph (..)
  , adjacencyIntMultiMap
  , vertexList
  , fromDirectedEdges
  , fromUndirectedEdges
  , reachable
  , Component (..)
  , undirectedComponents
  )
where

import Algebra.Graph.AdjacencyIntMap (AdjacencyIntMap)
import qualified Algebra.Graph.AdjacencyIntMap as AdjacencyIntMap
import qualified Algebra.Graph.AdjacencyIntMap.Algorithm as AIMA
import Algebra.Graph.Class (Graph (..))
import Control.DeepSeq (NFData)
import Data.Coerce (Coercible, coerce)
import Data.Foldable (foldl')
import Data.Hashable (Hashable)
import Data.Tuple (swap)
import IntLike.Equiv (IntLikeEquiv)
import qualified IntLike.Equiv as ILE
import IntLike.Map (IntLikeMap (..))
import IntLike.MultiMap (IntLikeMultiMap)
import IntLike.Set (IntLikeSet (..))
import qualified IntLike.Set as ILS

newtype IntLikeGraph x = IntLikeGraph {forall x. IntLikeGraph x -> AdjacencyIntMap
unIntLikeGraph :: AdjacencyIntMap}
  deriving newtype (IntLikeGraph x -> IntLikeGraph x -> Bool
(IntLikeGraph x -> IntLikeGraph x -> Bool)
-> (IntLikeGraph x -> IntLikeGraph x -> Bool)
-> Eq (IntLikeGraph x)
forall x. IntLikeGraph x -> IntLikeGraph x -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall x. IntLikeGraph x -> IntLikeGraph x -> Bool
== :: IntLikeGraph x -> IntLikeGraph x -> Bool
$c/= :: forall x. IntLikeGraph x -> IntLikeGraph x -> Bool
/= :: IntLikeGraph x -> IntLikeGraph x -> Bool
Eq, Eq (IntLikeGraph x)
Eq (IntLikeGraph x) =>
(IntLikeGraph x -> IntLikeGraph x -> Ordering)
-> (IntLikeGraph x -> IntLikeGraph x -> Bool)
-> (IntLikeGraph x -> IntLikeGraph x -> Bool)
-> (IntLikeGraph x -> IntLikeGraph x -> Bool)
-> (IntLikeGraph x -> IntLikeGraph x -> Bool)
-> (IntLikeGraph x -> IntLikeGraph x -> IntLikeGraph x)
-> (IntLikeGraph x -> IntLikeGraph x -> IntLikeGraph x)
-> Ord (IntLikeGraph x)
IntLikeGraph x -> IntLikeGraph x -> Bool
IntLikeGraph x -> IntLikeGraph x -> Ordering
IntLikeGraph x -> IntLikeGraph x -> IntLikeGraph x
forall x. Eq (IntLikeGraph x)
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
forall x. IntLikeGraph x -> IntLikeGraph x -> Bool
forall x. IntLikeGraph x -> IntLikeGraph x -> Ordering
forall x. IntLikeGraph x -> IntLikeGraph x -> IntLikeGraph x
$ccompare :: forall x. IntLikeGraph x -> IntLikeGraph x -> Ordering
compare :: IntLikeGraph x -> IntLikeGraph x -> Ordering
$c< :: forall x. IntLikeGraph x -> IntLikeGraph x -> Bool
< :: IntLikeGraph x -> IntLikeGraph x -> Bool
$c<= :: forall x. IntLikeGraph x -> IntLikeGraph x -> Bool
<= :: IntLikeGraph x -> IntLikeGraph x -> Bool
$c> :: forall x. IntLikeGraph x -> IntLikeGraph x -> Bool
> :: IntLikeGraph x -> IntLikeGraph x -> Bool
$c>= :: forall x. IntLikeGraph x -> IntLikeGraph x -> Bool
>= :: IntLikeGraph x -> IntLikeGraph x -> Bool
$cmax :: forall x. IntLikeGraph x -> IntLikeGraph x -> IntLikeGraph x
max :: IntLikeGraph x -> IntLikeGraph x -> IntLikeGraph x
$cmin :: forall x. IntLikeGraph x -> IntLikeGraph x -> IntLikeGraph x
min :: IntLikeGraph x -> IntLikeGraph x -> IntLikeGraph x
Ord, Int -> IntLikeGraph x -> ShowS
[IntLikeGraph x] -> ShowS
IntLikeGraph x -> String
(Int -> IntLikeGraph x -> ShowS)
-> (IntLikeGraph x -> String)
-> ([IntLikeGraph x] -> ShowS)
-> Show (IntLikeGraph x)
forall x. Int -> IntLikeGraph x -> ShowS
forall x. [IntLikeGraph x] -> ShowS
forall x. IntLikeGraph x -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall x. Int -> IntLikeGraph x -> ShowS
showsPrec :: Int -> IntLikeGraph x -> ShowS
$cshow :: forall x. IntLikeGraph x -> String
show :: IntLikeGraph x -> String
$cshowList :: forall x. [IntLikeGraph x] -> ShowS
showList :: [IntLikeGraph x] -> ShowS
Show, IntLikeGraph x -> ()
(IntLikeGraph x -> ()) -> NFData (IntLikeGraph x)
forall x. IntLikeGraph x -> ()
forall a. (a -> ()) -> NFData a
$crnf :: forall x. IntLikeGraph x -> ()
rnf :: IntLikeGraph x -> ()
NFData)

instance Coercible x Int => Graph (IntLikeGraph x) where
  type Vertex (IntLikeGraph x) = x
  empty :: IntLikeGraph x
empty = AdjacencyIntMap -> IntLikeGraph x
forall x. AdjacencyIntMap -> IntLikeGraph x
IntLikeGraph AdjacencyIntMap
AdjacencyIntMap.empty
  vertex :: Vertex (IntLikeGraph x) -> IntLikeGraph x
vertex Vertex (IntLikeGraph x)
v = AdjacencyIntMap -> IntLikeGraph x
forall x. AdjacencyIntMap -> IntLikeGraph x
IntLikeGraph (Int -> AdjacencyIntMap
AdjacencyIntMap.vertex (x -> Int
forall a b. Coercible a b => a -> b
coerce x
Vertex (IntLikeGraph x)
v))
  overlay :: IntLikeGraph x -> IntLikeGraph x -> IntLikeGraph x
overlay IntLikeGraph x
x IntLikeGraph x
y = AdjacencyIntMap -> IntLikeGraph x
forall x. AdjacencyIntMap -> IntLikeGraph x
IntLikeGraph (AdjacencyIntMap -> AdjacencyIntMap -> AdjacencyIntMap
AdjacencyIntMap.overlay (IntLikeGraph x -> AdjacencyIntMap
forall x. IntLikeGraph x -> AdjacencyIntMap
unIntLikeGraph IntLikeGraph x
x) (IntLikeGraph x -> AdjacencyIntMap
forall x. IntLikeGraph x -> AdjacencyIntMap
unIntLikeGraph IntLikeGraph x
y))
  connect :: IntLikeGraph x -> IntLikeGraph x -> IntLikeGraph x
connect IntLikeGraph x
x IntLikeGraph x
y = AdjacencyIntMap -> IntLikeGraph x
forall x. AdjacencyIntMap -> IntLikeGraph x
IntLikeGraph (AdjacencyIntMap -> AdjacencyIntMap -> AdjacencyIntMap
AdjacencyIntMap.connect (IntLikeGraph x -> AdjacencyIntMap
forall x. IntLikeGraph x -> AdjacencyIntMap
unIntLikeGraph IntLikeGraph x
x) (IntLikeGraph x -> AdjacencyIntMap
forall x. IntLikeGraph x -> AdjacencyIntMap
unIntLikeGraph IntLikeGraph x
y))

adjacencyIntMultiMap :: IntLikeGraph x -> IntLikeMultiMap x x
adjacencyIntMultiMap :: forall x. IntLikeGraph x -> IntLikeMultiMap x x
adjacencyIntMultiMap = IntMap IntSet -> IntLikeMultiMap x x
forall a b. Coercible a b => a -> b
coerce (IntMap IntSet -> IntLikeMultiMap x x)
-> (IntLikeGraph x -> IntMap IntSet)
-> IntLikeGraph x
-> IntLikeMultiMap x x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AdjacencyIntMap -> IntMap IntSet
AdjacencyIntMap.adjacencyIntMap (AdjacencyIntMap -> IntMap IntSet)
-> (IntLikeGraph x -> AdjacencyIntMap)
-> IntLikeGraph x
-> IntMap IntSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntLikeGraph x -> AdjacencyIntMap
forall x. IntLikeGraph x -> AdjacencyIntMap
unIntLikeGraph
{-# INLINE adjacencyIntMultiMap #-}

vertexList :: Coercible x Int => IntLikeGraph x -> [x]
vertexList :: forall x. Coercible x Int => IntLikeGraph x -> [x]
vertexList = [Int] -> [x]
forall a b. Coercible a b => a -> b
coerce ([Int] -> [x])
-> (IntLikeGraph x -> [Int]) -> IntLikeGraph x -> [x]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AdjacencyIntMap -> [Int]
AdjacencyIntMap.vertexList (AdjacencyIntMap -> [Int])
-> (IntLikeGraph x -> AdjacencyIntMap) -> IntLikeGraph x -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntLikeGraph x -> AdjacencyIntMap
forall x. IntLikeGraph x -> AdjacencyIntMap
unIntLikeGraph
{-# INLINE vertexList #-}

fromDirectedEdges :: Coercible x Int => [(x, x)] -> IntLikeGraph x
fromDirectedEdges :: forall x. Coercible x Int => [(x, x)] -> IntLikeGraph x
fromDirectedEdges = AdjacencyIntMap -> IntLikeGraph x
forall x. AdjacencyIntMap -> IntLikeGraph x
IntLikeGraph (AdjacencyIntMap -> IntLikeGraph x)
-> ([(x, x)] -> AdjacencyIntMap) -> [(x, x)] -> IntLikeGraph x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Int, Int)] -> AdjacencyIntMap
AdjacencyIntMap.edges ([(Int, Int)] -> AdjacencyIntMap)
-> ([(x, x)] -> [(Int, Int)]) -> [(x, x)] -> AdjacencyIntMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(x, x)] -> [(Int, Int)]
forall a b. Coercible a b => a -> b
coerce
{-# INLINE fromDirectedEdges #-}

fromUndirectedEdges :: Coercible x Int => [(x, x)] -> IntLikeGraph x
fromUndirectedEdges :: forall x. Coercible x Int => [(x, x)] -> IntLikeGraph x
fromUndirectedEdges [(x, x)]
es = IntLikeGraph x -> IntLikeGraph x -> IntLikeGraph x
forall g. Graph g => g -> g -> g
overlay ([(x, x)] -> IntLikeGraph x
forall x. Coercible x Int => [(x, x)] -> IntLikeGraph x
fromDirectedEdges [(x, x)]
es) ([(x, x)] -> IntLikeGraph x
forall x. Coercible x Int => [(x, x)] -> IntLikeGraph x
fromDirectedEdges (((x, x) -> (x, x)) -> [(x, x)] -> [(x, x)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (x, x) -> (x, x)
forall a b. (a, b) -> (b, a)
swap [(x, x)]
es))
{-# INLINE fromUndirectedEdges #-}

reachable :: Coercible x Int => x -> IntLikeGraph x -> [x]
reachable :: forall x. Coercible x Int => x -> IntLikeGraph x -> [x]
reachable x
x = [Int] -> [x]
forall a b. Coercible a b => a -> b
coerce ([Int] -> [x])
-> (IntLikeGraph x -> [Int]) -> IntLikeGraph x -> [x]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AdjacencyIntMap -> Int -> [Int])
-> Int -> AdjacencyIntMap -> [Int]
forall a b c. (a -> b -> c) -> b -> a -> c
flip AdjacencyIntMap -> Int -> [Int]
AIMA.reachable (x -> Int
forall a b. Coercible a b => a -> b
coerce x
x) (AdjacencyIntMap -> [Int])
-> (IntLikeGraph x -> AdjacencyIntMap) -> IntLikeGraph x -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntLikeGraph x -> AdjacencyIntMap
forall x. IntLikeGraph x -> AdjacencyIntMap
unIntLikeGraph
{-# INLINE reachable #-}

newtype Component = Component {Component -> Int
unComponent :: Int}
  deriving stock (Int -> Component -> ShowS
[Component] -> ShowS
Component -> String
(Int -> Component -> ShowS)
-> (Component -> String)
-> ([Component] -> ShowS)
-> Show Component
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Component -> ShowS
showsPrec :: Int -> Component -> ShowS
$cshow :: Component -> String
show :: Component -> String
$cshowList :: [Component] -> ShowS
showList :: [Component] -> ShowS
Show)
  deriving newtype (Component -> Component -> Bool
(Component -> Component -> Bool)
-> (Component -> Component -> Bool) -> Eq Component
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Component -> Component -> Bool
== :: Component -> Component -> Bool
$c/= :: Component -> Component -> Bool
/= :: Component -> Component -> Bool
Eq, Eq Component
Eq Component =>
(Component -> Component -> Ordering)
-> (Component -> Component -> Bool)
-> (Component -> Component -> Bool)
-> (Component -> Component -> Bool)
-> (Component -> Component -> Bool)
-> (Component -> Component -> Component)
-> (Component -> Component -> Component)
-> Ord Component
Component -> Component -> Bool
Component -> Component -> Ordering
Component -> Component -> Component
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
$ccompare :: Component -> Component -> Ordering
compare :: Component -> Component -> Ordering
$c< :: Component -> Component -> Bool
< :: Component -> Component -> Bool
$c<= :: Component -> Component -> Bool
<= :: Component -> Component -> Bool
$c> :: Component -> Component -> Bool
> :: Component -> Component -> Bool
$c>= :: Component -> Component -> Bool
>= :: Component -> Component -> Bool
$cmax :: Component -> Component -> Component
max :: Component -> Component -> Component
$cmin :: Component -> Component -> Component
min :: Component -> Component -> Component
Ord, Int -> Component
Component -> Int
Component -> [Component]
Component -> Component
Component -> Component -> [Component]
Component -> Component -> Component -> [Component]
(Component -> Component)
-> (Component -> Component)
-> (Int -> Component)
-> (Component -> Int)
-> (Component -> [Component])
-> (Component -> Component -> [Component])
-> (Component -> Component -> [Component])
-> (Component -> Component -> Component -> [Component])
-> Enum Component
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: Component -> Component
succ :: Component -> Component
$cpred :: Component -> Component
pred :: Component -> Component
$ctoEnum :: Int -> Component
toEnum :: Int -> Component
$cfromEnum :: Component -> Int
fromEnum :: Component -> Int
$cenumFrom :: Component -> [Component]
enumFrom :: Component -> [Component]
$cenumFromThen :: Component -> Component -> [Component]
enumFromThen :: Component -> Component -> [Component]
$cenumFromTo :: Component -> Component -> [Component]
enumFromTo :: Component -> Component -> [Component]
$cenumFromThenTo :: Component -> Component -> Component -> [Component]
enumFromThenTo :: Component -> Component -> Component -> [Component]
Enum, Eq Component
Eq Component =>
(Int -> Component -> Int)
-> (Component -> Int) -> Hashable Component
Int -> Component -> Int
Component -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
$chashWithSalt :: Int -> Component -> Int
hashWithSalt :: Int -> Component -> Int
$chash :: Component -> Int
hash :: Component -> Int
Hashable, Component -> ()
(Component -> ()) -> NFData Component
forall a. (a -> ()) -> NFData a
$crnf :: Component -> ()
rnf :: Component -> ()
NFData)

undirectedComponents :: Coercible x Int => [(x, x)] -> IntLikeEquiv Component x
undirectedComponents :: forall x. Coercible x Int => [(x, x)] -> IntLikeEquiv Component x
undirectedComponents [(x, x)]
es = Int
-> IntLikeSet x
-> IntLikeEquiv Component x
-> IntLikeEquiv Component x
go Int
0 IntLikeSet x
startVs IntLikeEquiv Component x
forall k v. IntLikeEquiv k v
ILE.empty
 where
  g :: IntLikeGraph x
g = [(x, x)] -> IntLikeGraph x
forall x. Coercible x Int => [(x, x)] -> IntLikeGraph x
fromUndirectedEdges [(x, x)]
es
  startVs :: IntLikeSet x
startVs = [x] -> IntLikeSet x
forall x. Coercible x Int => [x] -> IntLikeSet x
ILS.fromList (IntLikeGraph x -> [x]
forall x. Coercible x Int => IntLikeGraph x -> [x]
vertexList IntLikeGraph x
g)
  go :: Int
-> IntLikeSet x
-> IntLikeEquiv Component x
-> IntLikeEquiv Component x
go Int
i IntLikeSet x
vs IntLikeEquiv Component x
eqv =
    case IntLikeSet x -> Maybe (x, IntLikeSet x)
forall x.
Coercible x Int =>
IntLikeSet x -> Maybe (x, IntLikeSet x)
ILS.minView IntLikeSet x
vs of
      Maybe (x, IntLikeSet x)
Nothing -> IntLikeEquiv Component x
eqv
      Just (x
v, IntLikeSet x
vs') ->
        let rs :: [x]
rs = x -> IntLikeGraph x -> [x]
forall x. Coercible x Int => x -> IntLikeGraph x -> [x]
reachable x
v IntLikeGraph x
g
            -- partial: ok by construction of graph and defn of reachable
            eqv' :: IntLikeEquiv Component x
eqv' = (IntLikeEquiv Component x -> x -> IntLikeEquiv Component x)
-> IntLikeEquiv Component x -> [x] -> IntLikeEquiv Component x
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((x -> IntLikeEquiv Component x -> IntLikeEquiv Component x)
-> IntLikeEquiv Component x -> x -> IntLikeEquiv Component x
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Component
-> x -> IntLikeEquiv Component x -> IntLikeEquiv Component x
forall k v.
(Coercible k Int, Coercible v Int) =>
k -> v -> IntLikeEquiv k v -> IntLikeEquiv k v
ILE.partialInsert (Int -> Component
Component Int
i))) IntLikeEquiv Component x
eqv [x]
rs
            vs'' :: IntLikeSet x
vs'' = (IntLikeSet x -> x -> IntLikeSet x)
-> IntLikeSet x -> [x] -> IntLikeSet x
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((x -> IntLikeSet x -> IntLikeSet x)
-> IntLikeSet x -> x -> IntLikeSet x
forall a b c. (a -> b -> c) -> b -> a -> c
flip x -> IntLikeSet x -> IntLikeSet x
forall x. Coercible x Int => x -> IntLikeSet x -> IntLikeSet x
ILS.delete) IntLikeSet x
vs' [x]
rs
        in  Int
-> IntLikeSet x
-> IntLikeEquiv Component x
-> IntLikeEquiv Component x
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) IntLikeSet x
vs'' IntLikeEquiv Component x
eqv'