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

utils: Add update-graph.

Browse source
This commit is contained in:
Sergiu Ivanov 2020-02-29 17:21:56 +01:00
parent 6e5c73bcb2
commit 1e524f167c
2 changed files with 49 additions and 3 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

29
utils-tests.rkt
View file

@ -68,7 +68,11 @@
[dbl (λ (x) (let ([x-str (symbol->string x)]) [dbl (λ (x) (let ([x-str (symbol->string x)])
(string->symbol (string-append x-str x-str))))] (string->symbol (string-append x-str x-str))))]
[new-gr1 (update-vertices/unweighted gr1 dbl)] [new-gr1 (update-vertices/unweighted gr1 dbl)]
[new-gr2 (update-vertices/unweighted gr2 dbl)]) [new-gr2 (update-vertices/unweighted gr2 dbl)]
[new-gr1-ug (update-graph gr1 #:v-func dbl)]
[new-gr2-ug (update-graph gr2 #:v-func dbl)]
[gr3 (weighted-graph/directed '((10 a b) (11 b c)))]
[new-gr3 (update-graph gr3 #:v-func dbl #:e-func (λ (x) (* 2 x)))])
(check-false (has-vertex? new-gr1 'a)) (check-false (has-vertex? new-gr1 'a))
(check-true (has-vertex? new-gr1 'aa)) (check-true (has-vertex? new-gr1 'aa))
(check-false (has-vertex? new-gr1 'b)) (check-false (has-vertex? new-gr1 'b))
@ -81,4 +85,25 @@
(check-true (has-edge? new-gr2 'aa 'bb)) (check-true (has-edge? new-gr2 'aa 'bb))
(check-true (has-edge? new-gr2 'bb 'aa)) (check-true (has-edge? new-gr2 'bb 'aa))
(check-true (has-edge? new-gr2 'bb 'cc)) (check-true (has-edge? new-gr2 'bb 'cc))
(check-true (has-edge? new-gr2 'cc 'bb)))) (check-true (has-edge? new-gr2 'cc 'bb))
(check-false (has-vertex? new-gr1-ug 'a))
(check-true (has-vertex? new-gr1-ug 'aa))
(check-false (has-vertex? new-gr1-ug 'b))
(check-true (has-vertex? new-gr1-ug 'bb))
(check-false (has-vertex? new-gr1-ug 'c))
(check-true (has-vertex? new-gr1-ug 'cc))
(check-true (has-edge? new-gr1-ug 'aa 'bb))
(check-true (has-edge? new-gr1-ug 'bb 'cc))
(check-true (has-edge? new-gr2-ug 'aa 'bb))
(check-true (has-edge? new-gr2-ug 'bb 'aa))
(check-true (has-edge? new-gr2-ug 'bb 'cc))
(check-true (has-edge? new-gr2-ug 'cc 'bb))
(check-true (has-edge? new-gr3 'aa 'bb))
(check-false (has-edge? new-gr3 'bb 'aa))
(check-true (has-edge? new-gr3 'bb 'cc))
(check-false (has-edge? new-gr3 'cc 'bb))
(check-equal? (edge-weight new-gr3 'aa 'bb) 20)
(check-equal? (edge-weight new-gr3 'bb 'cc) 22)))

23
utils.rkt
View file

@ -19,7 +19,11 @@
[unstringify-pairs (-> (listof (general-pair/c string? any/c)) [unstringify-pairs (-> (listof (general-pair/c string? any/c))
(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?)]) [update-vertices/unweighted (-> graph? (-> any/c any/c) graph?)]
[update-graph (->* (graph?)
(#:v-func (-> any/c any/c)
#:e-func (-> 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?]
@ -228,3 +232,20 @@
(for/list ([e (in-edges gr)]) (for/list ([e (in-edges gr)])
(match-let ([(list u v) e]) (match-let ([(list u v) e])
(list (func u) (func v)))))) (list (func u) (func v))))))
;;; Given a graph, apply a transformation v-func to every vertex label
;;; and, if the graph is a weighted graph, the transformation e-func
;;; to every edge label. Both transformations default to identity
;;; functions. If gr is an weighted graph, the result is a weighted
;;; graph. If gr is an unweighted graph, the result is an unweighted
;;; graph.
(define (update-graph gr #:v-func [v-func identity] #:e-func [e-func identity])
(let ([edges (for/list ([e (in-edges gr)])
(match-let ([(list u v) e])
(if (unweighted-graph? gr)
(list (v-func u) (v-func v))
(list (e-func (edge-weight gr u v))
(v-func u) (v-func v)))))])
(if (unweighted-graph? gr)
(unweighted-graph/directed edges)
(weighted-graph/directed edges))))