From e1cf64a822d14ce47f326594a32ae5196c9a5d4a Mon Sep 17 00:00:00 2001 From: Sergiu Ivanov Date: Sun, 6 Feb 2022 23:44:03 +0100 Subject: [PATCH] utils: Typed update-vertices/unweighted. --- scribblings/utils.scrbl | 22 ++++++++++++ utils.rkt | 77 +++++++++++++++++++---------------------- 2 files changed, 58 insertions(+), 41 deletions(-) diff --git a/scribblings/utils.scrbl b/scribblings/utils.scrbl index cf34ba4..e18fdb0 100644 --- a/scribblings/utils.scrbl +++ b/scribblings/utils.scrbl @@ -277,6 +277,28 @@ Typeset the graph via graphviz and display it. (dotit (weighted-graph/directed '((1 a b) (2 b c)))) ]} + +@defproc[(update-vertices/unweighted [graph Graph] [func (-> Any Any)]) Graph]{ + +Applies a transformation to every vertex in the unweighted graph and returns +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 @racket[rename-vertex!], so it can be used to +permute vertex labels. + +@examples[#:eval utils-evaluator +(define g (directed-graph '((a b) (b c)))) +(define (double-labels [x : Any]) + (define x-str (symbol->string (cast x Symbol))) + (string->symbol (string-append x-str x-str))) +(dotit (update-vertices/unweighted g double-labels)) +]} + + @section{Additional list and hash map utilities} @section{Functions and procedures} diff --git a/utils.rkt b/utils.rkt index bfb6b11..1e62ba1 100644 --- a/utils.rkt +++ b/utils.rkt @@ -21,7 +21,8 @@ extract-symbols any->string stringify-variable-mapping string->any 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 dotit) + list-sets->list-strings pretty-print-set pretty-print-set-sets + update-vertices/unweighted dotit) (define-type Variable Symbol) (define-type (VariableMapping A) (Immutable-HashTable Variable A)) @@ -297,6 +298,37 @@ (check-equal? (pretty-print-set-sets (set (set 'a 'b) (set 'c))) "{a b}{c}"))) (define dotit (compose display graphviz)) + + (: update-vertices/unweighted (-> Graph (-> Any Any) Graph)) + (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)))))) + + (module+ test + (test-case "update-vertices/unweighted" + (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 (update-vertices/unweighted gr1 dbl)) + (define 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)))) ) (require 'typed) @@ -304,14 +336,14 @@ extract-symbols any->string stringify-variable-mapping string->any 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 dotit) + list-sets->list-strings pretty-print-set pretty-print-set-sets + update-vertices/unweighted dotit) ;;; Untyped section. (provide ;; Functions - (contract-out [update-vertices/unweighted (-> graph? (-> any/c any/c) graph?)] - [update-graph (->* (graph?) + (contract-out [update-graph (->* (graph?) (#:v-func (-> any/c any/c) #:e-func (-> any/c any/c)) graph?)] @@ -357,43 +389,6 @@ ;;; 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)))))) - -(module+ test - (test-case "update-vertices/unweighted" - (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 (update-vertices/unweighted gr1 dbl)) - (define 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)))) - ;;; 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