Utils: Type update-graph.
This commit is contained in:
Sergiu Ivanov
parent
45a60cd122
commit
0179423be9
2 changed files with 74 additions and 65 deletions
|
|
@ -297,6 +297,27 @@ permute vertex labels.
|
|||
(dotit (update-vertices/unweighted g double-labels))
|
||||
]}
|
||||
|
||||
@defproc[(update-graph [graph Graph]
|
||||
[#:v-func v-func (-> Any Any) identity]
|
||||
[#:e-func e-func (-> Any Any) identity])
|
||||
Graph]{
|
||||
|
||||
Given a (directed) graph, apply the transformation @racket[v-func] to every
|
||||
vertex label and, if the graph is a weighted graph, the transformation
|
||||
@racket[e-func] to every edge label. Both transformations default to identity
|
||||
functions. If @racket[graph] is an weighted graph, the result is a weighted
|
||||
graph. If @racket[graph] is an unweighted graph, the result is an
|
||||
unweighted graph.
|
||||
|
||||
@examples[#:eval utils-evaluator
|
||||
(define g (weighted-graph/directed '((10 a b) (11 b c))))
|
||||
(define (double-labels [x : Any])
|
||||
(define x-str (symbol->string (cast x Symbol)))
|
||||
(string->symbol (string-append x-str x-str)))
|
||||
(define (double-edges [x : Any])
|
||||
(* 2 (cast x Number)))
|
||||
(dotit (update-graph g #:v-func double-labels #:e-func double-edges))
|
||||
]}
|
||||
|
||||
@section{Additional list and hash map utilities}
|
||||
|
||||
|
|
|
|||
118
utils.rkt
118
utils.rkt
|
|
@ -22,7 +22,7 @@
|
|||
handle-org-booleans map-sexp read-org-sexp unorg unstringify-pairs
|
||||
read-org-variable-mapping unorgv read-symbol-list drop-first-last
|
||||
list-sets->list-strings pretty-print-set pretty-print-set-sets
|
||||
update-vertices/unweighted dotit)
|
||||
update-vertices/unweighted update-graph dotit)
|
||||
|
||||
(define-type Variable Symbol)
|
||||
(define-type (VariableMapping A) (Immutable-HashTable Variable A))
|
||||
|
|
@ -329,6 +329,56 @@
|
|||
(check-true (has-edge? new-gr2 'bb 'aa))
|
||||
(check-true (has-edge? new-gr2 'bb 'cc))
|
||||
(check-true (has-edge? new-gr2 'cc 'bb))))
|
||||
|
||||
(: update-graph (->* (Graph) (#:v-func (-> Any Any) #:e-func (-> Any Any)) Graph))
|
||||
(define (update-graph gr #:v-func [v-func identity] #:e-func [e-func identity])
|
||||
(cond
|
||||
[(unweighted-graph? gr)
|
||||
(unweighted-graph/directed
|
||||
(for/list ([e (in-edges gr)]) : (Listof (List Any Any))
|
||||
(match-let ([(list u v) e])
|
||||
(list (v-func u) (v-func v)))))]
|
||||
[else
|
||||
(weighted-graph/directed
|
||||
(for/list ([e (in-edges gr)]) : (Listof (List Any Any Any))
|
||||
(match-let ([(list u v) e])
|
||||
(list (e-func (edge-weight gr u v))
|
||||
(v-func u) (v-func v)))))]))
|
||||
|
||||
(module+ test
|
||||
(test-case "update-graph"
|
||||
(define gr1 (directed-graph '((a b) (b c))))
|
||||
(define gr2 (undirected-graph '((a b) (b c))))
|
||||
(define (dbl [x : Any])
|
||||
(define x-str (symbol->string (cast x Symbol)))
|
||||
(string->symbol (string-append x-str x-str)))
|
||||
(define new-gr1-ug (update-graph gr1 #:v-func dbl))
|
||||
(define new-gr2-ug (update-graph gr2 #:v-func dbl))
|
||||
(define gr3 (weighted-graph/directed '((10 a b) (11 b c))))
|
||||
(define new-gr3 (update-graph gr3
|
||||
#:v-func dbl
|
||||
#:e-func (λ (x) (* 2 (cast x Number)))))
|
||||
|
||||
(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)))
|
||||
)
|
||||
|
||||
(require 'typed)
|
||||
|
|
@ -337,17 +387,13 @@
|
|||
map-sexp read-org-sexp unorg unstringify-pairs
|
||||
read-org-variable-mapping unorgv read-symbol-list drop-first-last
|
||||
list-sets->list-strings pretty-print-set pretty-print-set-sets
|
||||
update-vertices/unweighted dotit)
|
||||
update-vertices/unweighted update-graph dotit)
|
||||
|
||||
;;; Untyped section.
|
||||
|
||||
(provide
|
||||
;; Functions
|
||||
(contract-out [update-graph (->* (graph?)
|
||||
(#:v-func (-> any/c any/c)
|
||||
#:e-func (-> any/c any/c))
|
||||
graph?)]
|
||||
[collect-by-key (-> (listof any/c) (listof any/c) (values (listof any/c) (listof (listof any/c))))]
|
||||
(contract-out [collect-by-key (-> (listof any/c) (listof any/c) (values (listof any/c) (listof (listof any/c))))]
|
||||
[collect-by-key/sets (-> (listof any/c) (listof any/c) (values (listof any/c) (listof (set/c any/c))))]
|
||||
|
||||
[ht-values/list->set (-> (hash/c any/c (listof any/c)) (hash/c any/c (set/c any/c)))]
|
||||
|
|
@ -385,64 +431,6 @@
|
|||
(cons/c key-contract val-contract)))
|
||||
|
||||
|
||||
;;; ==========================
|
||||
;;; Additional graph utilities
|
||||
;;; ==========================
|
||||
|
||||
;;; 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])
|
||||
(define edges
|
||||
(for/list ([e (in-edges gr)])
|
||||
(match-let ([(list u v) e])
|
||||
(cond
|
||||
[(unweighted-graph? gr) (list (v-func u) (v-func v))]
|
||||
[else (list (e-func (edge-weight gr u v))
|
||||
(v-func u) (v-func v))]))))
|
||||
(cond
|
||||
[(unweighted-graph? gr) (unweighted-graph/directed edges)]
|
||||
[else
|
||||
(weighted-graph/directed edges)]))
|
||||
|
||||
(module+ test
|
||||
(test-case "update-graph"
|
||||
(define gr1 (directed-graph '((a b) (b c))))
|
||||
(define gr2 (undirected-graph '((a b) (b c))))
|
||||
(define dbl (λ (x) (let ([x-str (symbol->string x)])
|
||||
(string->symbol (string-append x-str x-str)))))
|
||||
(define new-gr1-ug (update-graph gr1 #:v-func dbl))
|
||||
(define new-gr2-ug (update-graph gr2 #:v-func dbl))
|
||||
(define gr3 (weighted-graph/directed '((10 a b) (11 b c))))
|
||||
(define new-gr3 (update-graph gr3 #:v-func dbl #:e-func (λ (x) (* 2 x))))
|
||||
|
||||
(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)))
|
||||
|
||||
|
||||
;;; ===============
|
||||
;;; Pretty printing
|
||||
;;; ===============
|
||||
|
|
|
|||
Loading…
Reference in a new issue