day 21: implement stable bipartite matching result

21.rkt

@@ -16,10 +16,10 @@
 
 (define (part2 input)
   (match-define (data lines all-is all-as tainted) input)
-  (define G (undirected-graph
+  (define matching
+    (maximum-bipartite-matching/stable
       (for*/list ([(k v*) (in-hash tainted)] [v (in-set v*)])
         (list k v))))
-  (define matching (maximum-bipartite-matching G))
 
   (string-join
     (map second (sort matching string<? #:key first))

scripts/aoc.rkt

@@ -5,6 +5,7 @@
 (require "aoc-lib.rkt" threading syntax/parse/define (for-syntax racket/syntax) graph)
 (provide answer dbg memoize define/memoized
          band bor bxor bnot bshl bshr bset? bfield
+         maximum-bipartite-matching/stable
          (all-from-out threading syntax/parse/define graph)
          (for-syntax (all-from-out racket/syntax)))
 
@@ -31,6 +32,22 @@
 (define-simple-macro (define/memoized (name:id arg:id) body:expr ...+)
   (define name (memoize (λ (arg) body ...))))
 
+;; helper for maximum-bipartite-matching
+;; given an edge list where each first item corresponds to the left set and each second item
+;; corresponds to the right set, return a matching list where the first item is from the left set
+;; and the second item is from the right
+(define (maximum-bipartite-matching/stable edges)
+  (when (empty? edges) (error "provided empty edges list"))
+  (define left (list->set (map first edges)))
+  (define G (undirected-graph edges))
+  (define matching (maximum-bipartite-matching G))
+  (define num-first-lefts
+    (for/sum ([m (in-list matching)] #:when (set-member? left (first m)))
+      1))
+  (if (> num-first-lefts (/ (set-count left) 2))
+    matching
+    (map #{list (second %) (first %)} matching)))
+
 ;; submit a solution to the server if not already submitted
 (define (answer day part answer)
   (printf "answer ~a.~a: ~s\n" day part answer)