1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
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<?) ","))
|
