blob: f3ecf5d79715286eb09ab03ad5f2ff2914031c0d (
plain)
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
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
|
(ql:quickload '(fiveam cl-ppcre uiop arrows))
(defun data (filename)
(with-open-file (in filename)
(loop for line = (read-line in nil nil)
while line
collect (cl-ppcre:register-groups-bind (val (#'parse-integer flow) others)
("Valve (\\w+) has flow rate=(\\d+); tunnels? leads? to valves? (.+)" line)
`(,(intern val) ,flow ,@(mapcar #'intern (cl-ppcre:split ", " others)))))))
(defun next-steps (current graph paths)
(flet ((appropriate (next)
(and (not (gethash next paths)) ;; not visited
(setf (gethash next paths) (cons next (gethash current paths))))))
(remove-if-not #'appropriate
;; name flow connections -> cddr
(cddr (assoc current graph :test #'eq)))))
(defun shortest-path (graph from to)
(let ((paths (make-hash-table :test #'eq)))
(setf (gethash from paths) (list from))
(labels ((traverse (queue paths)
(unless (null queue)
(let ((next (next-steps (car queue) graph paths)))
(unless (member to next :test #'eq)
(traverse (append (cdr queue) next) paths))))))
(traverse (list from) paths))
(gethash to paths)))
(defun worthwhile-graph (graph)
(let ((interesting (remove-if #'zerop graph :key #'cadr)))
(loop for (from flow) in (cons '(aa 0) interesting)
for label from 0
collect (apply #'list (ash 1 label) from flow
(loop for (to) in interesting
for target-label from 1
when (not (eq from to))
collect (cons (ash 1 target-label) (1- (length (shortest-path graph from to)))))))))
(defun accumulated-flow (actor-paths)
(reduce #'+ actor-paths :key #'caddr))
(defun max-possible-flow (graph actors open)
(let ((actors-min-time-left (reduce #'max actors :key #'cadr)))
(+ (accumulated-flow actors)
(loop for (node name flow) in graph
:when (not (logtest node open))
:sum (* flow actors-min-time-left)))))
(defun traverse (graph actors open best-flow all-valves)
(if (or (zerop (logxor open all-valves))
(zerop (cadar actors))
(< (max-possible-flow graph actors open) (accumulated-flow best-flow)))
(mapcar (lambda (a) (cons (reverse (car a)) (cdr a))) actors)
(destructuring-bind (current-actor . others) actors
(destructuring-bind (path time-left previous-flow) current-actor
(let ((next
(loop for (next-node . time-there) in (cdddr (assoc (car path) graph :test #'=))
:when (and (not (logtest next-node open))
(let ((time-left (- time-left time-there 1)))
(when (plusp time-left)
(let* ((flow-there (caddr (assoc next-node graph :test #'=)))
(next-flow (+ previous-flow (* flow-there time-left))))
(cons next-node (list (list (cons next-node path) time-left next-flow)))))))
:collect it)))
(if (null next)
;; for performance reasons I don't understand separating this
;; no-op option to move to next actor is faster that preparing
;; the identity move within next before
;; (format t "hit open ~a actors: ~a~%" open actors)
(traverse graph
(append others
(list (list path 0 previous-flow)))
open best-flow all-valves)
(reduce
(lambda (acc term)
(let* ((acc-flow (accumulated-flow acc))
(new-flow
(destructuring-bind (node . actors-next-move) term
(traverse graph
(append (cdr actors) actors-next-move)
(logior node open)
acc all-valves))))
(if (> acc-flow (accumulated-flow new-flow))
acc new-flow)))
next
:initial-value best-flow)))))))
(defun solver (filename start-time actors)
(let* ((action-graph (worthwhile-graph (data filename)))
(actor (loop repeat actors collect `((1) ,start-time 0)))
(all-valves (loop for (idx) in action-graph sum idx)))
(traverse action-graph actor 1 nil all-valves)))
;; Auxiliary functions for inspection
(defun path->symbols (path graph)
(loop for node in path
collect (cadr (assoc node graph :test #'=))))
(defun path<-symbols (path graph)
(loop for node in path
collect (car (rassoc node graph :key #'car :test #'eq))))
(defun travel-time (path graph)
(if (every #'symbolp path)
(travel-time (path<-symbols path graph) graph)
(loop for (from to) on path
while to
for neighbors = (cdddr (assoc from graph :test #'eq))
for distance = (cdr (assoc to neighbors :test #'eq))
sum (1+ distance) into runtime
collect runtime)))
(defun path-release (path graph start-time)
(if (every #'symbolp path)
(path-release (path<-symbols path graph) graph start-time)
(loop for (from to) on path
for node-from = (assoc from graph) then node-to
and node-to = (assoc to graph)
while node-to
for neighbors = (cdddr node-from)
for flow = (caddr node-to)
for distance = (cdr (assoc to neighbors :test #'eq))
sum (1+ distance) into runtime
sum (* flow (- start-time runtime)) into release
finally (return release))))
(defun many-path-release (paths graph start-time)
(reduce #'+ paths
:key (lambda (path) (path-release path graph start-time))))
(fiveam:test paths
(let ((graph-eg (worthwhile-graph (data "eg-in")))
(test-path '(1 8 32)))
(arrows:->
(path->symbols test-path graph-eg)
(path<-symbols graph-eg)
(equal test-path)
(fiveam:is))
(fiveam:is (equal (travel-time '(AA CC DD JJ) graph-eg) '(3 5 9)))
(fiveam:is
(= 1648 (path-release '(AA DD JJ BB CC HH EE) graph-eg 30)))
(fiveam:is
(= 1651 (path-release '(AA DD BB JJ HH EE CC) graph-eg 30)))
(fiveam:is (= 480 (path-release '(AA DD) graph-eg 26)))
(fiveam:is (= 560 (path-release '(AA DD) graph-eg 30)))
(fiveam:is (= 546 (path-release '(AA DD EE) graph-eg 26)))
(fiveam:is (= 313 (path-release '(AA DD HH EE) graph-eg 12)))
(fiveam:is (= 312 (path-release '(AA DD EE HH) graph-eg 12))))
(let ((graph-input (worthwhile-graph (data "input"))))
(fiveam:is (= 2473 (many-path-release '((AA NU WK NC ZG EA CX QC) (AA RA XK YH NM YP XS)) graph-input 26)))
(fiveam:is (= 2474 (many-path-release '((AA NU WK NC ZG EA CX QC) (AA XK YH NM YP XS)) graph-input 26)))))
(fiveam:test partial-sections
(let* ((graph (worthwhile-graph (data "eg-in")))
(path '(1 64 8 32 2 16 4)))
(fiveam:is (= 1595 (path-release path graph 30)))
(fiveam:is (equal '(3 7 12 19 23 26) (travel-time path graph)))
(fiveam:is (= 78 (max-possible-flow graph (list (list path 26 0)) 111))))
(let* ((graph (worthwhile-graph (data "input")))
(path '(1 1024 32768 128 8192 2 2048 64 4096)))
(list
(fiveam:is (= 1754 (path-release path graph 30)))
(fiveam:is (equal '(3 6 9 12 19 22 25 28) (travel-time path graph)))
(fiveam:is (= 3588 (max-possible-flow graph (list (list path 26 0)) 111))))))
(fiveam:test solutions
(fiveam:is
(= 1651 (accumulated-flow (solver "eg-in" 30 1))))
(fiveam:is
(= 1754 (accumulated-flow (solver "input" 30 1))))
(fiveam:is
(= 1707 (accumulated-flow (solver "eg-in" 26 2))))
(fiveam:is
(= 2474 (accumulated-flow (solver "input" 26 2)))))
;; (require :sb-sprof)
;; (sb-sprof:with-profiling (:max-samples 1000
;; :report :flat
;; :loop t
;; :show-progress t)
;; (solver "input" 19 2))
;; (time (solver "input" 19 2))
;; (length (worthwhile-graph (data "input")))
;; (loop for (name flow . neighbors) in (worthwhile-graph (data "input"))
;; do (loop for (nn . dist) in neighbors
;; do (format t "~a -> ~a [label=\"~d\"]~%" name nn dist)))
|
