From 4063a21bce5192f5b53fa7cad22858c731d6bf42 Mon Sep 17 00:00:00 2001
From: Sergiu Ivanov <sivanov@colimite.fr>
Date: Sun, 23 Feb 2020 19:17:16 +0100
Subject: [PATCH] utils: Add update-vertices/unweighted.

---
 utils-tests.rkt | 23 ++++++++++++++++++++++-
 utils.rkt       | 22 +++++++++++++++++++++-
 2 files changed, 43 insertions(+), 2 deletions(-)

diff --git a/utils-tests.rkt b/utils-tests.rkt
index a2e2954..67e4876 100644
--- a/utils-tests.rkt
+++ b/utils-tests.rkt
@@ -2,7 +2,7 @@
 
 ;;; Tests for dds/utils.
 
-(require rackunit "utils.rkt")
+(require rackunit graph "utils.rkt")
 
 (test-case "HashTable Injection"
   (test-case "auto-hash-ref/explicit"
@@ -59,3 +59,24 @@
     (check-equal? (hash-ref m1 'b) '(or b (not a)))
     (check-equal? (hash-ref m2 'b) '(or b (not a)))
     (check-equal? (hash-ref m3 'b) '(or b (not a)))))
+
+(test-case "Additional graph utilities"
+  (let* ([gr1 (directed-graph '((a b) (b c)))]
+         [gr2 (undirected-graph '((a b) (b c)))]
+         [dbl (λ (x) (let ([x-str (symbol->string x)])
+                       (string->symbol (string-append x-str x-str))))]
+         [new-gr1 (update-vertices/unweighted gr1 dbl)]
+         [new-gr2 (update-vertices/unweighted gr2 dbl)])
+    (check-false (has-vertex? new-gr1 'a))
+    (check-true (has-vertex? new-gr1 'aa))
+    (check-false (has-vertex? new-gr1 'b))
+    (check-true (has-vertex? new-gr1 'bb))
+    (check-false (has-vertex? new-gr1 'c))
+    (check-true (has-vertex? new-gr1 'cc))
+    (check-true (has-edge? new-gr1 'aa 'bb))
+    (check-true (has-edge? new-gr1 'bb 'cc))
+
+    (check-true (has-edge? new-gr2 'aa 'bb))
+    (check-true (has-edge? new-gr2 'bb 'aa))
+    (check-true (has-edge? new-gr2 'bb 'cc))
+    (check-true (has-edge? new-gr2 'cc 'bb))))
diff --git a/utils.rkt b/utils.rkt
index 59f717d..f363f25 100644
--- a/utils.rkt
+++ b/utils.rkt
@@ -18,7 +18,8 @@
                [read-org-table (-> string? (listof any/c))]
                [unstringify-pairs (-> (listof (general-pair/c string? string?))
                                       (listof (general-pair/c symbol? any/c)))]
-               [read-org-variable-mapping (-> string? variable-mapping?)])
+               [read-org-variable-mapping (-> string? variable-mapping?)]
+               [update-vertices/unweighted (-> graph? (-> any/c any/c) graph?)])
  ;; Contracts
  (contract-out [variable-mapping? contract?]
                [string-variable-mapping? contract?]
@@ -203,3 +204,22 @@
 
 ;;; Typeset the graph via graphviz and display it.
 (define-syntax-rule (dotit gr) (display (graphviz gr)))
+
+
+;;; ==========================
+;;; Additional graph utilities
+;;; ==========================
+
+;;; Apply a transformation to every vertex in the unweighted graph,
+;;; return the new graph.  If the transformation function maps two
+;;; vertices to the same values, these vertices will be merged in the
+;;; resulting graph.  The transformation function may be called
+;;; multiple times for the same vertex.
+;;;
+;;; This function does not rely on rename-vertex!, so it can be used
+;;; to permute vertex labels.
+(define (update-vertices/unweighted gr func)
+  (unweighted-graph/directed
+   (for/list ([e (in-edges gr)])
+     (match-let ([(list u v) e])
+       (list (func u) (func v))))))