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
forall x. IntLikeGraph x -> IntLikeGraph x -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: 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
Eq, Int -> IntLikeGraph x -> ShowS
[IntLikeGraph x] -> ShowS
IntLikeGraph x -> String
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
showList :: [IntLikeGraph x] -> ShowS
$cshowList :: forall x. [IntLikeGraph x] -> ShowS
show :: IntLikeGraph x -> String
$cshow :: forall x. IntLikeGraph x -> String
showsPrec :: Int -> IntLikeGraph x -> ShowS
$cshowsPrec :: forall x. Int -> IntLikeGraph x -> ShowS
Show, IntLikeGraph x -> ()
forall x. IntLikeGraph x -> ()
forall a. (a -> ()) -> NFData a
rnf :: IntLikeGraph x -> ()
$crnf :: forall x. IntLikeGraph x -> ()
NFData)

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

adjacencyIntMultiMap :: IntLikeGraph x -> IntLikeMultiMap x x
adjacencyIntMultiMap :: forall x. IntLikeGraph x -> IntLikeMultiMap x x
adjacencyIntMultiMap = coerce :: forall a b. Coercible a b => a -> b
coerce forall b c a. (b -> c) -> (a -> b) -> a -> c
. AdjacencyIntMap -> IntMap IntSet
AdjacencyIntMap.adjacencyIntMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = coerce :: forall a b. Coercible a b => a -> b
coerce forall b c a. (b -> c) -> (a -> b) -> a -> c
. AdjacencyIntMap -> [Int]
AdjacencyIntMap.vertexList forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall x. AdjacencyIntMap -> IntLikeGraph x
IntLikeGraph forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Int, Int)] -> AdjacencyIntMap
AdjacencyIntMap.edges forall b c a. (b -> c) -> (a -> b) -> a -> c
. coerce :: 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 = forall g. Graph g => g -> g -> g
overlay (forall x. Coercible x Int => [(x, x)] -> IntLikeGraph x
fromDirectedEdges [(x, x)]
es) (forall x. Coercible x Int => [(x, x)] -> IntLikeGraph x
fromDirectedEdges (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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 = coerce :: forall a b. Coercible a b => a -> b
coerce forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> AdjacencyIntMap -> [Int]
AIMA.reachable (coerce :: forall a b. Coercible a b => a -> b
coerce x
x) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall x. IntLikeGraph x -> AdjacencyIntMap
unIntLikeGraph
{-# INLINE reachable #-}

newtype Component = Component { Component -> Int
unComponent :: Int }
  deriving stock (Int -> Component -> ShowS
[Component] -> ShowS
Component -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Component] -> ShowS
$cshowList :: [Component] -> ShowS
show :: Component -> String
$cshow :: Component -> String
showsPrec :: Int -> Component -> ShowS
$cshowsPrec :: Int -> Component -> ShowS
Show)
  deriving newtype (Component -> Component -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Component -> Component -> Bool
$c/= :: Component -> Component -> Bool
== :: Component -> Component -> Bool
$c== :: Component -> Component -> Bool
Eq, Eq 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
min :: Component -> Component -> Component
$cmin :: Component -> Component -> Component
max :: Component -> Component -> Component
$cmax :: Component -> Component -> Component
>= :: Component -> Component -> Bool
$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
compare :: Component -> Component -> Ordering
$ccompare :: Component -> Component -> Ordering
Ord, Int -> Component
Component -> Int
Component -> [Component]
Component -> Component
Component -> Component -> [Component]
Component -> Component -> Component -> [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
enumFromThenTo :: Component -> Component -> Component -> [Component]
$cenumFromThenTo :: Component -> Component -> Component -> [Component]
enumFromTo :: Component -> Component -> [Component]
$cenumFromTo :: Component -> Component -> [Component]
enumFromThen :: Component -> Component -> [Component]
$cenumFromThen :: Component -> Component -> [Component]
enumFrom :: Component -> [Component]
$cenumFrom :: Component -> [Component]
fromEnum :: Component -> Int
$cfromEnum :: Component -> Int
toEnum :: Int -> Component
$ctoEnum :: Int -> Component
pred :: Component -> Component
$cpred :: Component -> Component
succ :: Component -> Component
$csucc :: Component -> Component
Enum, Eq Component
Int -> Component -> Int
Component -> Int
forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: Component -> Int
$chash :: Component -> Int
hashWithSalt :: Int -> Component -> Int
$chashWithSalt :: Int -> Component -> Int
Hashable, Component -> ()
forall a. (a -> ()) -> NFData a
rnf :: Component -> ()
$crnf :: 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 forall k v. IntLikeEquiv k v
ILE.empty where
  g :: IntLikeGraph x
g = forall x. Coercible x Int => [(x, x)] -> IntLikeGraph x
fromUndirectedEdges [(x, x)]
es
  startVs :: IntLikeSet x
startVs = forall x. Coercible x Int => [x] -> IntLikeSet x
ILS.fromList (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 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 = 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' = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (forall a b c. (a -> b -> c) -> b -> a -> c
flip (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'' = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (forall a b c. (a -> b -> c) -> b -> a -> c
flip 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 forall a. Num a => a -> a -> a
+ Int
1) IntLikeSet x
vs'' IntLikeEquiv Component x
eqv'