{-# Language ImportQualifiedPost #-}
{-|
Module      : Advent.MaxClique
Description : Maximal clique enumerator
Copyright   : (c) Eric Mertens, 2018-2021
License     : ISC
Maintainer  : emertens@gmail.com

Implementation of <https://en.wikipedia.org/wiki/Bron–Kerbosch_algorithm>

The Bron–Kerbosch algorithm is an enumeration algorithm for finding all maximal cliques in an undirected graph.

A clique is a subset of verticies in a graph such that all the verticies are connected by an edge.

A /maximal/ clique is a clique such that no more verticies could be added to it while preserving the clique property.

This example shows the expected output on a simple graph. The example uses an inefficient
graph input representation to keep the example simple.

@
    ┌─┐   ┌─┐
 ┌──│4│───│5│──┐
 │  └─┘   └─┘  │
┌─┐  │     │  ┌─┐
│6│  │     │  │1│
└─┘  │     │  └─┘
    ┌─┐   ┌─┐  │
    │3│───│2│──┘
    └─┘   └─┘
@

>>> let adjList = [(1,2),(1,5),(2,3),(2,5),(3,4),(4,5),(4,6)]
>>> maxCliques (\x y -> (min x y, max x y) `elem` adjList) [1..6]
[[1,2,5],[2,3],[3,4],[4,5],[4,6]]

-}
module Advent.MaxClique (maxCliques, maxCliquesInt) where

import Data.IntMap qualified as IntMap
import Data.IntSet (IntSet)
import Data.IntSet qualified as IntSet

-- | Find the maximal cliques of a graph.
--
-- Self-edges are allowed and are filtered out.
maxCliques ::
  (a -> a -> Bool) {- ^ test for edge between nodes -} ->
  [a]              {- ^ all nodes -} ->
  [[a]]            {- ^ maximal cliques -}
maxCliques :: forall a. (a -> a -> Bool) -> [a] -> [[a]]
maxCliques a -> a -> Bool
adj [a]
xs = (IntSet -> [a]) -> [IntSet] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map IntSet -> [a]
recover ((Int -> IntSet) -> IntSet -> [IntSet]
maxCliquesInt (IntMap IntSet
edges IntMap IntSet -> Int -> IntSet
forall a. IntMap a -> Int -> a
IntMap.!) (IntMap a -> IntSet
forall a. IntMap a -> IntSet
IntMap.keysSet IntMap a
nodes))
  where
    recover :: IntSet -> [a]
recover = IntMap a -> [a]
forall a. IntMap a -> [a]
IntMap.elems (IntMap a -> [a]) -> (IntSet -> IntMap a) -> IntSet -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap a -> IntSet -> IntMap a
forall a. IntMap a -> IntSet -> IntMap a
IntMap.restrictKeys IntMap a
nodes
    nodes :: IntMap a
nodes = [(Int, a)] -> IntMap a
forall a. [(Int, a)] -> IntMap a
IntMap.fromList ([Int] -> [a] -> [(Int, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [a]
xs)
    edges :: IntMap IntSet
edges =
      (Int -> a -> IntSet) -> IntMap a -> IntMap IntSet
forall a b. (Int -> a -> b) -> IntMap a -> IntMap b
IntMap.mapWithKey
        (\Int
i a
v ->
          IntMap a -> IntSet
forall a. IntMap a -> IntSet
IntMap.keysSet
            ((Int -> a -> Bool) -> IntMap a -> IntMap a
forall a. (Int -> a -> Bool) -> IntMap a -> IntMap a
IntMap.filterWithKey (\Int
j a
u -> Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
j Bool -> Bool -> Bool
&& a -> a -> Bool
adj a
v a
u) IntMap a
nodes))
        IntMap a
nodes

-- | Bron-Kerbosh algorithm on graphs labeled with integers. The graph should have no self-edges.
maxCliquesInt ::
  (Int -> IntSet) {- ^ node to adjacent nodes -} ->
  IntSet          {- ^ all nodes -} ->
  [IntSet]        {- ^ maximal cliques -}
maxCliquesInt :: (Int -> IntSet) -> IntSet -> [IntSet]
maxCliquesInt Int -> IntSet
neighbors IntSet
nodes = IntSet -> IntSet -> IntSet -> [IntSet] -> [IntSet]
top IntSet
IntSet.empty IntSet
IntSet.empty IntSet
nodes []
  where
    top :: IntSet -> IntSet -> IntSet -> [IntSet] -> [IntSet]
top IntSet
r IntSet
x IntSet
p
      | IntSet -> Bool
IntSet.null IntSet
p, IntSet -> Bool
IntSet.null IntSet
x = (IntSet
rIntSet -> [IntSet] -> [IntSet]
forall a. a -> [a] -> [a]
:)
      | Bool
otherwise = [Int] -> IntSet -> IntSet -> IntSet -> [IntSet] -> [IntSet]
loop (IntSet -> [Int]
IntSet.elems IntSet
p') IntSet
r IntSet
x IntSet
p 
      where
        pivot :: Int
pivot = [Int] -> Int
forall a. HasCallStack => [a] -> a
head (IntSet -> [Int]
IntSet.elems IntSet
p)
        p' :: IntSet
p' = IntSet
p IntSet -> IntSet -> IntSet
IntSet.\\ Int -> IntSet
neighbors Int
pivot

    loop :: [Int] -> IntSet -> IntSet -> IntSet -> [IntSet] -> [IntSet]
loop []     IntSet
_ IntSet
_ IntSet
_ = [IntSet] -> [IntSet]
forall a. a -> a
id
    loop (Int
v:[Int]
vs) IntSet
r IntSet
x IntSet
p 
      = IntSet -> IntSet -> IntSet -> [IntSet] -> [IntSet]
top (Int -> IntSet -> IntSet
IntSet.insert Int
v IntSet
r) (IntSet -> IntSet -> IntSet
IntSet.intersection IntSet
ns IntSet
x) (IntSet -> IntSet -> IntSet
IntSet.intersection IntSet
ns IntSet
p)
      ([IntSet] -> [IntSet])
-> ([IntSet] -> [IntSet]) -> [IntSet] -> [IntSet]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> IntSet -> IntSet -> IntSet -> [IntSet] -> [IntSet]
loop [Int]
vs IntSet
r (Int -> IntSet -> IntSet
IntSet.insert Int
v IntSet
x) (Int -> IntSet -> IntSet
IntSet.delete Int
v IntSet
p)
      where ns :: IntSet
ns = Int -> IntSet
neighbors Int
v