From 9e778f3fb0239ac85fe9d4d20f3bb2c7ef7e4942 Mon Sep 17 00:00:00 2001
From: Sergiu Ivanov <sivanov@colimite.fr>
Date: Mon, 1 Nov 2021 09:40:22 +0100
Subject: [PATCH] Add coloring.

---
 graph.rkt | 18 ++++++++++++++++++
 1 file changed, 18 insertions(+)

diff --git a/graph.rkt b/graph.rkt
index 016f73b..c7a84a1 100644
--- a/graph.rkt
+++ b/graph.rkt
@@ -42,6 +42,8 @@
            bellman-ford dijkstra dag-shortest-paths
            floyd-warshall transitive-closure johnson
 
+           coloring
+
            graphviz)
 
   ;; Wrap the opaque graph structure coming from the generic
@@ -213,6 +215,10 @@
   (define (johnson g)
     (g:johnson (gg g)))
 
+  ;; 8 Coloring
+  (define (coloring g num-colors #:order [order (λ (x) x)])
+    (g:coloring (gg g) num-colors #:order order))
+
   ;; 10 Graphviz
   (define (graphviz g #:output [output #f] #:colors [colors #f])
     (g:graphviz (gg g) #:output output #:colors colors)))
@@ -317,6 +323,11 @@
   [transitive-closure (-> Graph (Mutable-HashTable (List Any Any) Boolean))]
   [johnson (-> Graph (Mutable-HashTable (List Any Any) Number))]
 
+  ;; 8 Coloring
+  [coloring (->* (Graph Natural)
+                 (#:order (-> (Listof Any) (Listof Any)))
+                 (U (Mutable-HashTable Any Number) False))]
+
   ;; 10 Graphviz
   [graphviz (->* (Graph)
                  (#:output Output-Port
@@ -518,6 +529,13 @@
                     ((d b) . +inf.0)
                     ((a b) . 1))))
 
+  (test-case "8 Coloring"
+    (define g0 (undirected-graph '((a b) (b c) (c d) (d a))))
+    (check-equal? (hash->ordered-list (cast (coloring g0 5)
+                                            (Mutable-HashTable Any Number)))
+                  '((a . 0) (b . 1) (c . 0) (d . 1)))
+    (check-false (coloring g0 1)))
+
   (test-case "10 Graphviz"
     (define g (directed-graph '((a b) (b c))))
     (check-equal? (graphviz g)