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))))))