module Solutions.P85 (isomorphic, isomorphic', isomorphic'') where
import Data.List (permutations, sortOn)
import Data.Map (Map, (!))
import qualified Data.Map as Map
import Data.Ord (Down (..))
import Data.Set (Set)
import qualified Data.Set as Set
import Problems.Graphs
isomorphic :: G -> G -> Bool
isomorphic :: G -> G -> Bool
isomorphic G
g G
g'
| Bool -> Bool
not Bool
sameSize = Bool
False
| Bool -> Bool
not Bool
sameDegrees = Bool
False
| Set Vertex -> Bool
forall a. Set a -> Bool
Set.null (Set Vertex -> Bool) -> Set Vertex -> Bool
forall a b. (a -> b) -> a -> b
$ G -> Set Vertex
forall g. Graph g => g -> Set Vertex
vertexes G
g = Set Vertex -> Bool
forall a. Set a -> Bool
Set.null (Set Vertex -> Bool) -> Set Vertex -> Bool
forall a b. (a -> b) -> a -> b
$ G -> Set Vertex
forall g. Graph g => g -> Set Vertex
vertexes G
g'
| Bool
otherwise = Map Vertex Vertex
-> Set Vertex -> (G, Set Vertex) -> (G, Set Vertex) -> Bool
expand Map Vertex Vertex
forall k a. Map k a
Map.empty (Vertex -> Set Vertex
forall a. a -> Set a
Set.singleton Vertex
v) (G
g, G -> Set Vertex
forall g. Graph g => g -> Set Vertex
vertexes G
g) (G
g', G -> Set Vertex
forall g. Graph g => g -> Set Vertex
vertexes G
g')
where v :: Vertex
v = G -> Set Vertex -> Vertex
maxDegreeVertex G
g (Set Vertex -> Vertex) -> Set Vertex -> Vertex
forall a b. (a -> b) -> a -> b
$ G -> Set Vertex
forall g. Graph g => g -> Set Vertex
vertexes G
g
sameSize :: Bool
sameSize = Set Vertex -> Vertex
forall a. Set a -> Vertex
Set.size (G -> Set Vertex
forall g. Graph g => g -> Set Vertex
vertexes G
g) Vertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
== Set Vertex -> Vertex
forall a. Set a -> Vertex
Set.size (G -> Set Vertex
forall g. Graph g => g -> Set Vertex
vertexes G
g')
sameDegrees :: Bool
sameDegrees = Map Vertex (Set Vertex) -> Map Vertex (Set Vertex) -> Bool
isSameDegrees (G -> Map Vertex (Set Vertex)
classifyVertexDegrees G
g) (G -> Map Vertex (Set Vertex)
classifyVertexDegrees G
g')
maxDegreeVertex :: G -> Set Vertex -> Vertex
maxDegreeVertex :: G -> Set Vertex -> Vertex
maxDegreeVertex G
g Set Vertex
vs
| (Vertex
v:[Vertex]
_) <- [Vertex]
ranked = Vertex
v
| Bool
otherwise = Vertex
forall a. HasCallStack => a
undefined
where ranked :: [Vertex]
ranked = (Vertex -> Down Vertex) -> [Vertex] -> [Vertex]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Vertex -> Down Vertex
forall a. a -> Down a
Down (Vertex -> Down Vertex)
-> (Vertex -> Vertex) -> Vertex -> Down Vertex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Vertex -> Vertex
forall a. Set a -> Vertex
Set.size (Set Vertex -> Vertex)
-> (Vertex -> Set Vertex) -> Vertex -> Vertex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Vertex -> G -> Set Vertex) -> G -> Vertex -> Set Vertex
forall a b c. (a -> b -> c) -> b -> a -> c
flip Vertex -> G -> Set Vertex
forall g. Graph g => Vertex -> g -> Set Vertex
neighbors G
g) ([Vertex] -> [Vertex]) -> [Vertex] -> [Vertex]
forall a b. (a -> b) -> a -> b
$ Set Vertex -> [Vertex]
forall a. Set a -> [a]
Set.toList Set Vertex
vs
expand :: Map Vertex Vertex -> Set Vertex -> (G, Set Vertex) -> (G, Set Vertex) -> Bool
expand :: Map Vertex Vertex
-> Set Vertex -> (G, Set Vertex) -> (G, Set Vertex) -> Bool
expand Map Vertex Vertex
bijection Set Vertex
frontier (G
g, Set Vertex
vs) (G
g', Set Vertex
vs')
| Set Vertex -> Bool
forall a. Set a -> Bool
Set.null Set Vertex
vs = Bool
True
| Set Vertex -> Bool
forall a. Set a -> Bool
Set.null Set Vertex
frontier = Map Vertex Vertex
-> Set Vertex -> (G, Set Vertex) -> (G, Set Vertex) -> Bool
expand Map Vertex Vertex
bijection (Vertex -> Set Vertex
forall a. a -> Set a
Set.singleton (Vertex -> Set Vertex) -> Vertex -> Set Vertex
forall a b. (a -> b) -> a -> b
$ Set Vertex -> Vertex
forall a. Set a -> a
Set.findMin Set Vertex
vs) (G
g, Set Vertex
vs) (G
g', Set Vertex
vs')
| Bool
otherwise = (Vertex -> Bool) -> Set Vertex -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Map Vertex Vertex
-> Set Vertex
-> (G, Set Vertex)
-> (G, Set Vertex)
-> Vertex
-> Vertex
-> Bool
expand' Map Vertex Vertex
bijection Set Vertex
frontier (G
g, Set Vertex
vs) (G
g', Set Vertex
vs') Vertex
v) Set Vertex
us
where v :: Vertex
v = G -> Set Vertex -> Vertex
maxDegreeVertex G
g Set Vertex
frontier
us :: Set Vertex
us = (Vertex -> Bool) -> Set Vertex -> Set Vertex
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (G -> G -> Map Vertex Vertex -> Vertex -> Vertex -> Bool
isMatch G
g G
g' Map Vertex Vertex
bijection Vertex
v) Set Vertex
vs'
expand' :: Map Vertex Vertex -> Set Vertex -> (G, Set Vertex) -> (G, Set Vertex) -> Vertex -> Vertex -> Bool
expand' :: Map Vertex Vertex
-> Set Vertex
-> (G, Set Vertex)
-> (G, Set Vertex)
-> Vertex
-> Vertex
-> Bool
expand' Map Vertex Vertex
bijection Set Vertex
frontier (G
g, Set Vertex
vs) (G
h, Set Vertex
us) Vertex
v Vertex
u = Map Vertex Vertex
-> Set Vertex -> (G, Set Vertex) -> (G, Set Vertex) -> Bool
expand Map Vertex Vertex
bijection' Set Vertex
frontier' (G
g, Set Vertex
vs') (G
h, Set Vertex
us')
where bijection' :: Map Vertex Vertex
bijection' = Vertex -> Vertex -> Map Vertex Vertex -> Map Vertex Vertex
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Vertex
v Vertex
u Map Vertex Vertex
bijection
frontier' :: Set Vertex
frontier' = Set Vertex -> Set Vertex -> Set Vertex
forall a. Ord a => Set a -> Set a -> Set a
Set.union (Vertex -> Set Vertex -> Set Vertex
forall a. Ord a => a -> Set a -> Set a
Set.delete Vertex
v Set Vertex
frontier) (Set Vertex -> Set Vertex) -> Set Vertex -> Set Vertex
forall a b. (a -> b) -> a -> b
$ Set Vertex -> Set Vertex -> Set Vertex
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection Set Vertex
vs' (Set Vertex -> Set Vertex) -> Set Vertex -> Set Vertex
forall a b. (a -> b) -> a -> b
$ Vertex -> G -> Set Vertex
forall g. Graph g => Vertex -> g -> Set Vertex
neighbors Vertex
v G
g
vs' :: Set Vertex
vs' = Vertex -> Set Vertex -> Set Vertex
forall a. Ord a => a -> Set a -> Set a
Set.delete Vertex
v Set Vertex
vs
us' :: Set Vertex
us' = Vertex -> Set Vertex -> Set Vertex
forall a. Ord a => a -> Set a -> Set a
Set.delete Vertex
u Set Vertex
us
isMatch :: G -> G -> Map Vertex Vertex -> Vertex -> Vertex -> Bool
isMatch :: G -> G -> Map Vertex Vertex -> Vertex -> Vertex -> Bool
isMatch G
g G
g' Map Vertex Vertex
bijection Vertex
v Vertex
v' = Bool
equalDegrees Bool -> Bool -> Bool
&& Bool
consistentNeighbors
where equalDegrees :: Bool
equalDegrees = Set Vertex -> Vertex
forall a. Set a -> Vertex
Set.size (Vertex -> G -> Set Vertex
forall g. Graph g => Vertex -> g -> Set Vertex
neighbors Vertex
v G
g) Vertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
== Set Vertex -> Vertex
forall a. Set a -> Vertex
Set.size (Vertex -> G -> Set Vertex
forall g. Graph g => Vertex -> g -> Set Vertex
neighbors Vertex
v' G
g')
consistentNeighbors :: Bool
consistentNeighbors = (Vertex -> Bool) -> Set Vertex -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Maybe Vertex -> Bool
isNeighbor (Maybe Vertex -> Bool)
-> (Vertex -> Maybe Vertex) -> Vertex -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Vertex -> Map Vertex Vertex -> Maybe Vertex)
-> Map Vertex Vertex -> Vertex -> Maybe Vertex
forall a b c. (a -> b -> c) -> b -> a -> c
flip Vertex -> Map Vertex Vertex -> Maybe Vertex
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Map Vertex Vertex
bijection) (Set Vertex -> Bool) -> Set Vertex -> Bool
forall a b. (a -> b) -> a -> b
$ Vertex -> G -> Set Vertex
forall g. Graph g => Vertex -> g -> Set Vertex
neighbors Vertex
v G
g
isNeighbor :: Maybe Vertex -> Bool
isNeighbor Maybe Vertex
Nothing = Bool
True
isNeighbor (Just Vertex
u) = Vertex -> Set Vertex -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Vertex
u (Set Vertex -> Bool) -> Set Vertex -> Bool
forall a b. (a -> b) -> a -> b
$ Vertex -> G -> Set Vertex
forall g. Graph g => Vertex -> g -> Set Vertex
neighbors Vertex
v' G
g'
classifyVertexDegrees :: G -> Map Int (Set Vertex)
classifyVertexDegrees :: G -> Map Vertex (Set Vertex)
classifyVertexDegrees (G Map Vertex (Set Vertex)
m) = (Set Vertex -> Set Vertex -> Set Vertex)
-> [(Vertex, Set Vertex)] -> Map Vertex (Set Vertex)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Set Vertex -> Set Vertex -> Set Vertex
forall a. Ord a => Set a -> Set a -> Set a
Set.union [(Vertex, Set Vertex)]
l
where l :: [(Vertex, Set Vertex)]
l = (Vertex -> (Vertex, Set Vertex))
-> [Vertex] -> [(Vertex, Set Vertex)]
forall a b. (a -> b) -> [a] -> [b]
map (\Vertex
v -> (Set Vertex -> Vertex
forall a. Set a -> Vertex
Set.size (Set Vertex -> Vertex) -> Set Vertex -> Vertex
forall a b. (a -> b) -> a -> b
$ Map Vertex (Set Vertex)
m Map Vertex (Set Vertex) -> Vertex -> Set Vertex
forall k a. Ord k => Map k a -> k -> a
! Vertex
v, Vertex -> Set Vertex
forall a. a -> Set a
Set.singleton Vertex
v)) ([Vertex] -> [(Vertex, Set Vertex)])
-> [Vertex] -> [(Vertex, Set Vertex)]
forall a b. (a -> b) -> a -> b
$ Map Vertex (Set Vertex) -> [Vertex]
forall k a. Map k a -> [k]
Map.keys Map Vertex (Set Vertex)
m
isSameDegrees :: Map Int (Set Vertex) -> Map Int (Set Vertex) -> Bool
isSameDegrees :: Map Vertex (Set Vertex) -> Map Vertex (Set Vertex) -> Bool
isSameDegrees Map Vertex (Set Vertex)
m Map Vertex (Set Vertex)
m' =
Map Vertex (Set Vertex) -> [Vertex]
forall k a. Map k a -> [k]
Map.keys Map Vertex (Set Vertex)
m [Vertex] -> [Vertex] -> Bool
forall a. Eq a => a -> a -> Bool
== Map Vertex (Set Vertex) -> [Vertex]
forall k a. Map k a -> [k]
Map.keys Map Vertex (Set Vertex)
m' Bool -> Bool -> Bool
&&
(Vertex -> Bool) -> [Vertex] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Vertex
d -> Set Vertex -> Vertex
forall a. Set a -> Vertex
Set.size (Map Vertex (Set Vertex)
m Map Vertex (Set Vertex) -> Vertex -> Set Vertex
forall k a. Ord k => Map k a -> k -> a
! Vertex
d) Vertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
== Set Vertex -> Vertex
forall a. Set a -> Vertex
Set.size (Map Vertex (Set Vertex)
m' Map Vertex (Set Vertex) -> Vertex -> Set Vertex
forall k a. Ord k => Map k a -> k -> a
! Vertex
d)) (Map Vertex (Set Vertex) -> [Vertex]
forall k a. Map k a -> [k]
Map.keys Map Vertex (Set Vertex)
m)
isomorphic' :: G -> G -> Bool
isomorphic' :: G -> G -> Bool
isomorphic' G
g G
g'
| Set Vertex -> Vertex
forall a. Set a -> Vertex
Set.size Set Vertex
vs Vertex -> Vertex -> Bool
forall a. Eq a => a -> a -> Bool
/= Set Vertex -> Vertex
forall a. Set a -> Vertex
Set.size Set Vertex
vs' = Bool
False
| Bool
otherwise = ([Vertex] -> Bool) -> [[Vertex]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\[Vertex]
p -> (Set Vertex
vs, Set Edge
es) (Set Vertex, Set Edge) -> (Set Vertex, Set Edge) -> Bool
forall a. Eq a => a -> a -> Bool
== (Set Vertex, Set Edge)
-> [Vertex] -> [Vertex] -> (Set Vertex, Set Edge)
permute (Set Vertex
vs', Set Edge
es') [Vertex]
vl [Vertex]
p) ([[Vertex]] -> Bool) -> [[Vertex]] -> Bool
forall a b. (a -> b) -> a -> b
$ [Vertex] -> [[Vertex]]
forall a. [a] -> [[a]]
permutations [Vertex]
vl'
where (Set Vertex
vs, Set Edge
es) = G -> (Set Vertex, Set Edge)
forall g. Graph g => g -> (Set Vertex, Set Edge)
sets G
g
(Set Vertex
vs', Set Edge
es') = G -> (Set Vertex, Set Edge)
forall g. Graph g => g -> (Set Vertex, Set Edge)
sets G
g'
vl :: [Vertex]
vl = Set Vertex -> [Vertex]
forall a. Set a -> [a]
Set.toList Set Vertex
vs
vl' :: [Vertex]
vl' = Set Vertex -> [Vertex]
forall a. Set a -> [a]
Set.toList Set Vertex
vs'
permute :: (Set Vertex, Set Edge) -> [Vertex] -> [Vertex] -> (Set Vertex, Set Edge)
permute :: (Set Vertex, Set Edge)
-> [Vertex] -> [Vertex] -> (Set Vertex, Set Edge)
permute (Set Vertex
vs, Set Edge
es) [Vertex]
vl [Vertex]
vl' = (Set Vertex
vs', Set Edge
es')
where translate :: Map Vertex Vertex
translate = [(Vertex, Vertex)] -> Map Vertex Vertex
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Vertex, Vertex)] -> Map Vertex Vertex)
-> [(Vertex, Vertex)] -> Map Vertex Vertex
forall a b. (a -> b) -> a -> b
$ [Vertex] -> [Vertex] -> [(Vertex, Vertex)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Vertex]
vl [Vertex]
vl'
vs' :: Set Vertex
vs' = Map Vertex Vertex -> Set Vertex -> Set Vertex
mapVertexes Map Vertex Vertex
translate Set Vertex
vs
es' :: Set Edge
es' = Map Vertex Vertex -> Set Edge -> Set Edge
mapEdges Map Vertex Vertex
translate Set Edge
es
mapVertexes :: Map Vertex Vertex -> Set Vertex -> Set Vertex
mapVertexes :: Map Vertex Vertex -> Set Vertex -> Set Vertex
mapVertexes Map Vertex Vertex
translate = (Vertex -> Vertex) -> Set Vertex -> Set Vertex
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (Map Vertex Vertex
translate !)
mapEdges :: Map Vertex Vertex -> Set Edge -> Set Edge
mapEdges :: Map Vertex Vertex -> Set Edge -> Set Edge
mapEdges Map Vertex Vertex
translate = (Edge -> Edge) -> Set Edge -> Set Edge
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (\(Edge (Vertex
u, Vertex
v)) -> (Vertex, Vertex) -> Edge
Edge (Vertex -> Vertex
f Vertex
u, Vertex -> Vertex
f Vertex
v))
where f :: Vertex -> Vertex
f = Map Vertex Vertex -> Vertex -> Vertex
forall k a. Ord k => Map k a -> k -> a
(!) Map Vertex Vertex
translate
isomorphic'' :: G -> G -> Bool
isomorphic'' :: G -> G -> Bool
isomorphic'' G
g G
g' =
Map Vertex (Set Vertex) -> Map Vertex (Set Vertex) -> Bool
isSameDegrees Map Vertex (Set Vertex)
degrees Map Vertex (Set Vertex)
degrees' Bool -> Bool -> Bool
&&
([(Vertex, Vertex)] -> Bool) -> [[(Vertex, Vertex)]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\[(Vertex, Vertex)]
p -> (Set Vertex, Set Edge)
-> [(Vertex, Vertex)] -> (Set Vertex, Set Edge)
permute' (Set Vertex
vs, Set Edge
es) [(Vertex, Vertex)]
p (Set Vertex, Set Edge) -> (Set Vertex, Set Edge) -> Bool
forall a. Eq a => a -> a -> Bool
== (Set Vertex
vs', Set Edge
es')) [[(Vertex, Vertex)]]
bijections
where degrees :: Map Vertex (Set Vertex)
degrees = G -> Map Vertex (Set Vertex)
classifyVertexDegrees G
g
degrees' :: Map Vertex (Set Vertex)
degrees' = G -> Map Vertex (Set Vertex)
classifyVertexDegrees G
g'
(Set Vertex
vs, Set Edge
es) = G -> (Set Vertex, Set Edge)
forall g. Graph g => g -> (Set Vertex, Set Edge)
sets G
g
(Set Vertex
vs', Set Edge
es') = G -> (Set Vertex, Set Edge)
forall g. Graph g => g -> (Set Vertex, Set Edge)
sets G
g'
groupByDegree :: Map k (Set a) -> [[a]]
groupByDegree Map k (Set a)
m = (Set a -> [a]) -> [Set a] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map Set a -> [a]
forall a. Set a -> [a]
Set.toAscList ([Set a] -> [[a]]) -> [Set a] -> [[a]]
forall a b. (a -> b) -> a -> b
$ Map k (Set a) -> [Set a]
forall k a. Map k a -> [a]
Map.elems Map k (Set a)
m
bijections :: [[(Vertex, Vertex)]]
bijections = [[Vertex]] -> [[Vertex]] -> [[(Vertex, Vertex)]]
combineLists (Map Vertex (Set Vertex) -> [[Vertex]]
forall {k} {a}. Map k (Set a) -> [[a]]
groupByDegree Map Vertex (Set Vertex)
degrees) (Map Vertex (Set Vertex) -> [[Vertex]]
forall {k} {a}. Map k (Set a) -> [[a]]
groupByDegree Map Vertex (Set Vertex)
degrees')
permute' :: (Set Vertex, Set Edge) -> [(Vertex, Vertex)] -> (Set Vertex, Set Edge)
permute' :: (Set Vertex, Set Edge)
-> [(Vertex, Vertex)] -> (Set Vertex, Set Edge)
permute' (Set Vertex
vs, Set Edge
es) [(Vertex, Vertex)]
p = (Set Vertex
vs', Set Edge
es')
where translate :: Map Vertex Vertex
translate = [(Vertex, Vertex)] -> Map Vertex Vertex
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Vertex, Vertex)]
p
vs' :: Set Vertex
vs' = Map Vertex Vertex -> Set Vertex -> Set Vertex
mapVertexes Map Vertex Vertex
translate Set Vertex
vs
es' :: Set Edge
es' = Map Vertex Vertex -> Set Edge -> Set Edge
mapEdges Map Vertex Vertex
translate Set Edge
es
combineLists :: [[Vertex]] -> [[Vertex]] -> [[(Vertex,Vertex)]]
combineLists :: [[Vertex]] -> [[Vertex]] -> [[(Vertex, Vertex)]]
combineLists [] [] = [[]]
combineLists ([Vertex]
l:[[Vertex]]
ls) ([Vertex]
l':[[Vertex]]
ls') = ([(Vertex, Vertex)] -> [[(Vertex, Vertex)]])
-> [[(Vertex, Vertex)]] -> [[(Vertex, Vertex)]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\[(Vertex, Vertex)]
p -> ([(Vertex, Vertex)] -> [(Vertex, Vertex)])
-> [[(Vertex, Vertex)]] -> [[(Vertex, Vertex)]]
forall a b. (a -> b) -> [a] -> [b]
map ([(Vertex, Vertex)] -> [(Vertex, Vertex)] -> [(Vertex, Vertex)]
forall a. [a] -> [a] -> [a]
++ [(Vertex, Vertex)]
p) [[(Vertex, Vertex)]]
bijections) ([[(Vertex, Vertex)]] -> [[(Vertex, Vertex)]])
-> [[(Vertex, Vertex)]] -> [[(Vertex, Vertex)]]
forall a b. (a -> b) -> a -> b
$ [[Vertex]] -> [[Vertex]] -> [[(Vertex, Vertex)]]
combineLists [[Vertex]]
ls [[Vertex]]
ls'
where bijections :: [[(Vertex, Vertex)]]
bijections = ([Vertex] -> [(Vertex, Vertex)])
-> [[Vertex]] -> [[(Vertex, Vertex)]]
forall a b. (a -> b) -> [a] -> [b]
map ([Vertex] -> [Vertex] -> [(Vertex, Vertex)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Vertex]
l) ([[Vertex]] -> [[(Vertex, Vertex)]])
-> [[Vertex]] -> [[(Vertex, Vertex)]]
forall a b. (a -> b) -> a -> b
$ [Vertex] -> [[Vertex]]
forall a. [a] -> [[a]]
permutations [Vertex]
l'
combineLists [[Vertex]]
_ [[Vertex]]
_ = [[(Vertex, Vertex)]]
forall a. HasCallStack => a
undefined