Day 23

1 files changed, 142 insertions, 0 deletions

diff --git a/day23.scm b/day23.scm
new file mode 100644
index 0000000..9b6d8e7
--- /dev/null
+++ b/day23.scm
@@ -0,0 +1,142 @@
+(library (day23)
+  (export part1 part2)
+  (import (ice-9 rdelim)
+          (ice-9 regex)
+          (pfds sets)
+          (guile)
+          (srfi srfi-69)
+          (srfi srfi-88)
+          (srfi srfi-89)))
+
+(define +line-regex+ (make-regexp "^([a-z][a-z])-([a-z][a-z])$"))
+
+(define (node? obj)
+  (and (string? obj)
+       (= (string-length obj) 2)
+       (char<=? #\a (string-ref obj 0) #\z)
+       (char<=? #\a (string-ref obj 1) #\z)))
+
+(define (node=? . nodes)
+  (apply string=? nodes))
+
+(define (network? obj)
+  ;; Also, the table maps from node? to set? of node? (comparator string<?) and
+  ;; the graph represented this way should be symmetric and antireflexive.
+  (hash-table? obj))
+
+(define (network-connects? nw n1 n2)
+  (and (hash-table-exists? nw n1)
+       (set-member? (hash-table-ref nw n1) n2)))
+
+(define (make-network)
+  (make-hash-table))
+
+(define (network-connect! nw n1 n2)
+  (define (add n1 n2)
+    (define set (hash-table-ref nw n1 (lambda () (make-set string<?))))
+    (hash-table-set! nw n1 (set-insert set n2)))
+  (unless (string=? n1 n2)
+    (add n1 n2)
+    (add n2 n1)))
+
+(define (set-for-each proc set)
+  (set-fold (lambda (v base) (proc v)) #f set))
+
+(define* (read-network (port (current-input-port)))
+  (define nw (make-network))
+  (let iter ()
+    (define line (read-line port))
+    (unless (or (eof-object? line) (string=? "" line))
+      (let ((mtch (regexp-exec +line-regex+ line)))
+        (unless mtch (error "Expected a connection line, like 'aa-bb'." line))
+        (network-connect! nw (match:substring mtch 1) (match:substring mtch 2)))
+      (iter)))
+  nw)
+
+(define (network-for-each proc nw)
+  (hash-table-walk
+   nw (lambda (u set)
+        (set-for-each (lambda (v) (when (string<? u v) (proc u v))) set))))
+
+(define* (print-network nw (port (current-output-port)))
+  (network-for-each (lambda (u v) (format port "~a-~a\n" u v)) nw))
+
+(define (t-prefix? node)
+  (char=? #\t (string-ref node 0)))
+
+(define (count-increment n1 n2)
+  ;; Each three-element set is counted as many times as there are permutations
+  ;; of the elements where the first one starts with t, so here we compensate
+  ;; for that.
+  (/ 1/2 (+ 1 (if (t-prefix? n1) 1 0) (if (t-prefix? n2) 1 0))))
+
+(define* (count-3-tuples nw)
+  (define count 0)
+  (define (parse-node! k set)
+    (when (t-prefix? k)
+      (set-for-each
+       (lambda (v1)
+         (set-for-each
+          (lambda (v2)
+            (when (network-connects? nw v1 v2)
+              (set! count (+ count (count-increment v1 v2)))))
+          set))
+       set)))
+  (hash-table-walk nw parse-node!)
+  count)
+
+(define* (part1 (port (current-input-port)))
+  (count-3-tuples (read-network port)))
+
+(define (generate-dotted-graph nw port)
+  (display "graph G {\n" port)
+  (display "\tnode[shape=point]\n" port)
+  (network-for-each (lambda (u v) (format port "\t~a--~a\n" u v)) nw)
+  (display "}\n" port))
+
+(define (find-k-clique nw k)
+  ;; We start with the empty clique, and all nodes in the graph as candidates
+  ;; for adding to the clique.
+  ;; Then, for each candidate node:
+  ;; - If the candidate connects with every node in the current clique, we
+  ;;   search by expanding the current clique with the current candidate and
+  ;;   using as candidates the nodes from the current set of candidates that
+  ;;   also connect with this newly-added element.  We do this by recursion.
+  ;; - If it doesn't connect to every node of the clique, or if the search above
+  ;;   fails, we remove the current element from the current set of candidates,
+  ;;   as an optimization.
+  (define (recur clique intersection)
+    (define (fold-elem elem acc)
+      ;; acc can be:
+      ;; the set of elements that have not been discarded yet, or
+      ;; (cons #t found-clique), if a k-clique has been found.
+      (if (pair? acc)
+          acc
+          (let* ((connected (hash-table-ref nw elem))
+                 (found-clique (and (subset? clique connected)
+                                    (recur (set-insert clique elem)
+                                           (set-intersection acc connected)))))
+            (if found-clique
+                (cons #t found-clique)
+                (set-remove acc elem)))))
+    (cond ((= (set-size clique) k) clique)
+          ((< (+ (set-size clique) (set-size intersection)) k) #f)
+          (else (let ((folded (set-fold fold-elem intersection intersection)))
+                  (and (pair? folded) (cdr folded))))))
+  (recur (make-set string<?)
+         (list->set (map car (hash-table->alist nw)) string<?)))
+
+(define (maximum-clique nw)
+  (let binary-search ((low 0) (high (hash-table-size nw)))
+    (if (= low high)
+        #f
+        (let* ((mid (quotient (+ low high) 2))
+               (clique (find-k-clique nw mid)))
+          (if clique
+              (or (binary-search (+ mid 1) high) clique)
+              (binary-search low mid))))))
+
+(define* (part2 (port (current-input-port)))
+  (define nw (read-network port))
+  (define clique (maximum-clique nw))
+  (string-join (sort! (set->list clique) string<?) ","))