diff --git a/utils.rkt b/utils.rkt index 1fbe20d..b5d5a69 100644 --- a/utils.rkt +++ b/utils.rkt @@ -50,7 +50,12 @@ [boolean-power (-> number? (listof (listof boolean?)))] [boolean-power/stream (-> number? (stream/c (listof boolean?)))] [any->01 (-> any/c (or/c 0 1))] - [01->boolean (-> (or/c 0 1) boolean?)]) + [01->boolean (-> (or/c 0 1) boolean?)] + [hash-intersect (->* [(and/c hash? immutable?)] + [#:combine (-> any/c any/c any/c) + #:combine/key (-> any/c any/c any/c any/c)] + #:rest (listof hash?) + (and/c hash? immutable?))]) ;; Contracts (contract-out [variable-mapping? contract?] [string-variable-mapping? contract?] @@ -586,6 +591,38 @@ (test-case "lists-transpose" (check-equal? (lists-transpose '((1 2) (a b))) '((1 a) (2 b))))) +;;; Like hash-union, but computes the intersection of hash +;;; tables. +;;; +;;; The intersections are computed by functional update, intersecting +;;; the first hash table with every other one supplied, one by one. +;;; The new mappings are computed either using combine or combine/key. +;;; +;;; TODO: I submitted this function to the Racket repository. Remove +;;; this function from this module when the update gets applied. +(define (hash-intersect + #:combine [combine #f] + #:combine/key [combine/key + (if combine + (λ (_ x y) (combine x y)) + (error 'hash-intersection))] + one . rest) + (define common-keys (apply set-intersect (map hash-keys (cons one rest)))) + (define res (for/hash ([k (in-list common-keys)]) + (values k (hash-ref one k)))) + (for*/fold ([res res]) ([hm (in-list rest)] + [(k v) (in-hash res)]) + (hash-set res k (combine/key k v (hash-ref hm k))))) + +(module+ test + (test-case "hash-intersect" + (define h1 #hash((a . 1) (b . 2) (c . 3))) + (define h2 #hash((a . 4) (b . 5))) + (define h3 #hash((a . 7) (c . 8))) + (check-equal? (hash-intersect h1 h2 h3 #:combine +) + '#hash((a . 12))) + (check-equal? (hash-intersect h1 h3 #:combine -) + '#hash((a . -6) (c . -5))))) ;;; ========= ;;; Functions