scolobb/dds
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

utils: Add update-vertices/unweighted.

Browse source
This commit is contained in:
Sergiu Ivanov 2020-02-23 19:17:16 +01:00
parent 39575f39c2
commit 4063a21bce
2 changed files with 43 additions and 2 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

23
utils-tests.rkt
View file

@ -2,7 +2,7 @@
;;; Tests for dds/utils. ;;; Tests for dds/utils.
(require rackunit "utils.rkt") (require rackunit graph "utils.rkt")
(test-case "HashTable Injection" (test-case "HashTable Injection"
(test-case "auto-hash-ref/explicit" (test-case "auto-hash-ref/explicit"
@ -59,3 +59,24 @@
(check-equal? (hash-ref m1 'b) '(or b (not a))) (check-equal? (hash-ref m1 'b) '(or b (not a)))
(check-equal? (hash-ref m2 '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))))) (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))))

22
utils.rkt
View file

@ -18,7 +18,8 @@
[read-org-table (-> string? (listof any/c))] [read-org-table (-> string? (listof any/c))]
[unstringify-pairs (-> (listof (general-pair/c string? string?)) [unstringify-pairs (-> (listof (general-pair/c string? string?))
(listof (general-pair/c symbol? any/c)))] (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 ;; Contracts
(contract-out [variable-mapping? contract?] (contract-out [variable-mapping? contract?]
[string-variable-mapping? contract?] [string-variable-mapping? contract?]
@ -203,3 +204,22 @@
;;; Typeset the graph via graphviz and display it. ;;; Typeset the graph via graphviz and display it.
(define-syntax-rule (dotit gr) (display (graphviz gr))) (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))))))