1 files changed, 27 insertions, 0 deletions
diff --git a/80-89/86.hs b/80-89/86.hs
new file mode 100644
index 0000000..b05f39e
--- /dev/null
+++ b/80-89/86.hs
@@ -0,0 +1,27 @@
+import Data.Ord (comparing)
+import Data.List (foldl', sortBy)
+
+data Graph a = Graph [a] [(a, a)] deriving (Show, Eq)
+data Adjacency a = Adj [(a, [a])] deriving (Show, Eq)
+
+graphToAdj :: Eq a => Graph a -> Adjacency a
+
+graphToAdj (Graph [] _) = Adj []
+graphToAdj (Graph (v:vs) e) = Adj ((v, e >>= pick):l)
+    where pick (a, b)
+            | a == v = [b]
+            | b == v = [a]
+            | otherwise = []
+          Adj l = graphToAdj $ Graph vs e
+
+kColor :: Eq a => Graph a -> [(a, Int)]
+
+takeUntil _ [] = []
+takeUntil p (x:xs) = x:if p x then [] else takeUntil p xs
+
+kColor g = last $ takeUntil (\c' -> length c' == length vs') $ scanl (\c' x -> round c' x) [] [1..]
+    where (Adj vs) = graphToAdj g
+          vs' = sortBy (comparing (length . snd)) vs
+          getc c u = filter ((== u) . fst) c
+          ok c l cur = all (/= cur) [snd $ head col | v <- l, let col = getc c v, col /= []]
+          round c cur = foldl' (\c' (u, adj) -> if (getc c' u == []) && ok c' adj cur then (u, cur):c' else c') c vs'