{- |
Description: Graph coloring
Copyright: Copyright (C) 2021 Yoo Chung
License: GPL-3.0-or-later
Maintainer: dev@chungyc.org

Some solutions to "Problems.P86" of Ninety-Nine Haskell "Problems".
-}
module Solutions.P86 (colorGraph) where

import           Data.List       (sortOn)
import           Data.Map.Lazy   (Map)
import qualified Data.Map.Lazy   as Map
import qualified Data.Set        as Set
import           Problems.Graphs

-- | Color a graph
-- using [Welch-Powell's algorithm](https://graphstream-project.org/doc/Algorithms/Welsh-Powell/).
-- Uses distinct integers to represent distinct colors,
-- and returns the association list between vertexes and their colors.
colorGraph :: G -> [(Vertex, Int)]
colorGraph :: G -> [(Int, Int)]
colorGraph G
g = Map Int Int -> [(Int, Int)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map Int Int -> [(Int, Int)]) -> Map Int Int -> [(Int, Int)]
forall a b. (a -> b) -> a -> b
$ G -> [Int] -> Int -> Map Int Int -> Map Int Int
colorVertexes G
g (G -> [Int]
sortByDegree G
g) Int
1 Map Int Int
forall k a. Map k a
Map.empty

colorVertexes :: G -> [Vertex] -> Int -> Map Vertex Int -> Map Vertex Int
colorVertexes :: G -> [Int] -> Int -> Map Int Int -> Map Int Int
colorVertexes G
_ [] Int
_ Map Int Int
coloring = Map Int Int
coloring
colorVertexes G
g (Int
v:[Int]
vs) Int
color Map Int Int
coloring = G -> [Int] -> Int -> Map Int Int -> Map Int Int
colorVertexes G
g [Int]
remaining (Int
colorInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Map Int Int
coloring'
  where ([Int]
remaining, Map Int Int
coloring') = G
-> Int
-> [Int]
-> Int
-> ([Int], Map Int Int)
-> ([Int], Map Int Int)
colorOthers G
g Int
v [Int]
vs Int
color ([], Int -> Int -> Map Int Int -> Map Int Int
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Int
v Int
color Map Int Int
coloring)

colorOthers :: G -> Vertex -> [Vertex] -> Int -> ([Vertex], Map Vertex Int) -> ([Vertex], Map Vertex Int)
colorOthers :: G
-> Int
-> [Int]
-> Int
-> ([Int], Map Int Int)
-> ([Int], Map Int Int)
colorOthers G
_ Int
_ [] Int
_ ([Int]
uncolored, Map Int Int
coloring) = ([Int] -> [Int]
forall a. [a] -> [a]
reverse [Int]
uncolored, Map Int Int
coloring)
colorOthers G
g Int
v (Int
v':[Int]
vs') Int
color ([Int]
uncolored,Map Int Int
coloring)
  | G -> Int -> Map Int Int -> Int -> Bool
neighborsHaveColor G
g Int
color Map Int Int
coloring Int
v' = G
-> Int
-> [Int]
-> Int
-> ([Int], Map Int Int)
-> ([Int], Map Int Int)
colorOthers G
g Int
v [Int]
vs' Int
color (Int
v' Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
uncolored, Map Int Int
coloring)
  | Bool
otherwise                              = G
-> Int
-> [Int]
-> Int
-> ([Int], Map Int Int)
-> ([Int], Map Int Int)
colorOthers G
g Int
v [Int]
vs' Int
color ([Int]
uncolored, Int -> Int -> Map Int Int -> Map Int Int
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Int
v' Int
color Map Int Int
coloring)

neighborsHaveColor :: G -> Int -> Map Vertex Int -> Vertex -> Bool
neighborsHaveColor :: G -> Int -> Map Int Int -> Int -> Bool
neighborsHaveColor G
g Int
color Map Int Int
coloring Int
v = (Int -> Bool) -> Set Int -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Int -> Map Int Int -> Int -> Bool
hasColor Int
color Map Int Int
coloring) (Set Int -> Bool) -> Set Int -> Bool
forall a b. (a -> b) -> a -> b
$ Int -> G -> Set Int
forall g. Graph g => Int -> g -> Set Int
neighbors Int
v G
g

hasColor :: Int -> Map Vertex Int -> Vertex -> Bool
hasColor :: Int -> Map Int Int -> Int -> Bool
hasColor Int
color Map Int Int
coloring Int
v = Maybe Int -> Bool
isColor (Maybe Int -> Bool) -> Maybe Int -> Bool
forall a b. (a -> b) -> a -> b
$ Int -> Map Int Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
v Map Int Int
coloring
  where isColor :: Maybe Int -> Bool
isColor Maybe Int
Nothing  = Bool
False
        isColor (Just Int
c) = Int
color Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
c

-- In descending order.
sortByDegree :: G -> [Vertex]
sortByDegree :: G -> [Int]
sortByDegree G
g = (Int -> Int) -> [Int] -> [Int]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn ((-) Int
0 (Int -> Int) -> (Int -> Int) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Int -> Int
forall a. Set a -> Int
Set.size (Set Int -> Int) -> (Int -> Set Int) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> G -> Set Int) -> G -> Int -> Set Int
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> G -> Set Int
forall g. Graph g => Int -> g -> Set Int
neighbors G
g) [Int]
vs
  where vs :: [Int]
vs = Set Int -> [Int]
forall a. Set a -> [a]
Set.toList (Set Int -> [Int]) -> Set Int -> [Int]
forall a b. (a -> b) -> a -> b
$ G -> Set Int
forall g. Graph g => g -> Set Int
vertexes G
g