Utils: Type update-graph.

scribblings/utils.scrbl

@@ -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}
 

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?)
+ (contract-out [collect-by-key (-> (listof any/c) (listof any/c) (values (listof any/c) (listof (listof any/c))))]
-                                  (#: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))))]
                [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
 ;;; ===============