diff --git a/scribblings/utils.scrbl b/scribblings/utils.scrbl index 647eced..db99b99 100644 --- a/scribblings/utils.scrbl +++ b/scribblings/utils.scrbl @@ -327,6 +327,20 @@ unweighted graph. @section{Additional list and hash map utilities} +@defproc[(collect-by-key [keys (Listof Any)] [vals (Listof Any)]) + (Values (Listof Any) (Listof (Listof Any)))]{ + +Given a list of keys and the corresponding values, collects all the values +associated to any given key and returns a list of keys without duplicates, and +a list containing the corresponding list of values. + +If @racket[keys] can be treated as edges (i.e. pairs of vertices), the results +produced by this function are suitable for graph constructors. + +@examples[#:eval utils-evaluator +(collect-by-key '(a b a) '(1 2 3)) +]} + @section{Functions and procedures} @section{Randomness} diff --git a/utils.rkt b/utils.rkt index 0872935..008f987 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 update-graph dotit) + update-vertices/unweighted update-graph dotit collect-by-key) (define-type Variable Symbol) (define-type (VariableMapping A) (Immutable-HashTable Variable A)) @@ -379,6 +379,23 @@ (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))) + + (: collect-by-key (-> (Listof Any) (Listof Any) + (Values (Listof Any) (Listof (Listof Any))))) + (define (collect-by-key keys vals) + (for/fold ([ht : (HashTable Any (Listof Any)) + (make-immutable-hash)] + #:result (values (hash-keys ht) (hash-values ht))) + ([e keys] + [l vals]) + ((inst hash-update Any (Listof Any)) ht e (λ (ls) (cons l ls)) (λ () empty)))) + + (module+ test + (test-case "collect-by-key" + (define-values (e1 l1) (collect-by-key '((1 2) (1 3)) '(a b))) + (define-values (e2 l2) (collect-by-key '((1 2) (1 2)) '(a b))) + (check-equal? e1 '((1 2) (1 3))) (check-equal? l1 '((a) (b))) + (check-equal? e2 '((1 2))) (check-equal? l2 '((b a))))) ) (require 'typed) @@ -387,14 +404,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 update-graph dotit) + update-vertices/unweighted update-graph dotit collect-by-key) ;;; Untyped section. (provide ;; Functions - (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))))] + (contract-out [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)))] [hash->list/ordered (-> hash? (listof (cons/c any/c any/c)))] @@ -435,25 +451,6 @@ ;;; Additional list and hash map utilities ;;; ====================================== -;;; Collects labels for duplicate edges into a sets of labels. -;;; -;;; More precisely, given a list of edges and weights, produces a new -;;; list of edges without duplicates, and a list of lists of weights -;;; in which each element corresponds to the edge (the input is -;;; suitable for graph constructors). -(define (collect-by-key edges labels) - (for/fold ([ht (make-immutable-hash)] - #:result (values (hash-keys ht) (hash-values ht))) - ([e edges] [l labels]) - (hash-update ht e (λ (ls) (cons l ls)) empty))) - -(module+ test - (test-case "collect-by-key" - (define-values (e1 l1) (collect-by-key '((1 2) (1 3)) '(a b))) - (define-values (e2 l2) (collect-by-key '((1 2) (1 2)) '(a b))) - (check-equal? e1 '((1 2) (1 3))) (check-equal? l1 '((a) (b))) - (check-equal? e2 '((1 2))) (check-equal? l2 '((b a))))) - ;;; Like collect-by-key, but returns a list of sets of weights. (define (collect-by-key/sets edges labels) (let-values ([(es ls) (collect-by-key edges labels)])