From 0179423be9b9f9cfa13ed718b6f6506562d770c1 Mon Sep 17 00:00:00 2001 From: Sergiu Ivanov Date: Tue, 8 Feb 2022 00:08:42 +0100 Subject: [PATCH] Utils: Type update-graph. --- scribblings/utils.scrbl | 21 +++++++ utils.rkt | 118 ++++++++++++++++++---------------------- 2 files changed, 74 insertions(+), 65 deletions(-) diff --git a/scribblings/utils.scrbl b/scribblings/utils.scrbl index c338c48..87d2c86 100644 --- a/scribblings/utils.scrbl +++ b/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} diff --git a/utils.rkt b/utils.rkt index 1e62ba1..a313fc4 100644 --- a/utils.rkt +++ b/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 ;;; ===============