blob: f7c35b6cdcb72dbf0d4deb27485a57ef153bec42 (
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
193
194
195
196
197
198
199
200
201
202
203
|
(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))
;; (loop for k being the hash-keys in paths using (hash-value v)
;; do (format t "~a=>~a~%" k v))
(gethash to paths)))
(defun worthwhile-graph (graph)
(let ((interesting (remove-if #'zerop graph :key #'cadr))
(htgraph (make-hash-table :test #'eq :size 16)))
(loop for (from flow) in (cons '(aa 0) interesting)
do
(setf (gethash from htgraph)
(cons flow
(loop for (to) in interesting
when (not (eq from to))
collect (cons to (1- (length (shortest-path graph from to))))))))
htgraph))
(defun travel-time (path graph)
(loop for (from to) on path
while to
for neighbors = (cddr (assoc from graph :test #'eq))
for distance = (cdr (assoc to neighbors :test #'eq))
sum (1+ distance) into runtime
collect runtime))
(defun next-options (current-options open time-left)
(flet ((appropriate (next)
(destructuring-bind (next-node-name . time-there) next
(and (not (member next-node-name open :test #'eq))
(< (1+ time-there) time-left)))))
(remove-if-not #'appropriate (cdr current-options))))
(defun path-release-as (path graph start-time)
(loop for (from to) on path
while to
for neighbors = (cddr (assoc from graph :test #'eq))
for flow = (cadr (assoc to graph :test #'eq))
for distance = (cdr (assoc to neighbors :test #'eq))
sum (1+ distance) into runtime
sum (* flow (- start-time runtime)) into release
finally (return release)))
(defun path-release (path graph start-time)
(loop for (from to) on path
for node-from = (gethash from graph) then node-to
and node-to = (gethash to graph)
while node-to
for neighbors = (cdr node-from)
for flow = (car 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)))
;; (shortest-path (data "eg-in") 'AA 'CC)
(fiveam:test loads
(fiveam:is
(= 1648 (path-release '(AA DD JJ BB CC HH EE) (worthwhile-graph (data "eg-in")) 30)))
(fiveam:is
(= 1651 (path-release '(AA DD BB JJ HH EE CC) (worthwhile-graph (data "eg-in")) 30)))
(fiveam:is
(= 560 (path-release '(AA DD) (worthwhile-graph (data "eg-in")) 30))))
;;
;; part 1
(let* ((open '(aa))
(action-graph (worthwhile-graph (data "input")))
(start-time 30))
;; (path-release)
;; (loop for k being the hash-keys in open using (hash-value v)
;; do (format t "~a=>~a~%" k v))
(labels ((traverse (graph node open time-left current-flow)
(let ((next (next-options (gethash node graph) open time-left)))
(if (null next)
(reverse open)
(arrows:->
(lambda (next-node)
(destructuring-bind (name . time-there) next-node
(let ((flow (car (gethash name graph)))
(time-left (- time-left time-there 1)))
(traverse graph name (cons name open)
time-left
(+ current-flow
(* flow time-left))))))
(mapcar next)
(sort #'>= :key (lambda (path) (path-release path graph start-time)))
(car))))))
(traverse action-graph 'aa open start-time 0)))
;; part 2
(defun path-release2 (paths graph start-time)
(reduce #'+ paths
:key (lambda (path) (path-release path graph start-time))))
(path-release '(AA DD) (worthwhile-graph (data "eg-in")) 26)
(path-release '(AA DD EE) (worthwhile-graph (data "eg-in")) 26)
(path-release '(AA DD HH EE) (worthwhile-graph (data "eg-in")) 12)
(path-release '(AA DD EE HH) (worthwhile-graph (data "eg-in")) 12)
(path-release2 '((AA NU WK NC ZG EA CX QC) (AA RA XK YH NM YP XS)) (worthwhile-graph (data "input")) 26)
(path-release2 '((AA NU WK NC ZG EA CX QC) (AA XK YH NM YP XS)) (worthwhile-graph (data "input")) 26)
;; (travel-time
;; ;; '(AA NU WK NC ZG XK YH NM YP)
;; ;; '(AA NU WK NC ZG EA CX QC)
;; '(AA RA XK YH NM YP XS)
;; (worthwhile-graph (data "input")))
(defun part2 (filename)
(let* ((action-graph (worthwhile-graph (data filename)))
(start-time 26)
(actor (list `((aa) ,start-time 0) `((aa) ,start-time 0))))
;; (loop for k being the hash-keys in open using (hash-value v)
;; do (format t "~a=>~a~%" k v))
(labels ((traverse (graph actor open)
(if (loop for ac in actor
:always (zerop (cadr ac)))
(mapcar (lambda (a) (cons (reverse (car a)) (cdr a))) actor)
(destructuring-bind (path time-left previous-flow) (car actor)
;; (princ (car actor))
;; (princ (path-release2 (reverse open) graph start-time))
;; (princ (recover-paths (reverse open)))
;; (terpri)
(let* ((current-options (gethash (car path) graph))
(flow-released (car current-options))
(current-flow (+ previous-flow (* flow-released time-left)))
(next (next-options current-options open time-left)))
(if (null next)
(traverse graph
(append (cdr actor)
(list (list path 0 current-flow)))
open)
(arrows:->
(lambda (next-node)
(destructuring-bind (name . time-there) next-node
(let ((time-left (- time-left time-there 1)))
(traverse graph
(append (cdr actor) (list (list (cons name path) time-left
current-flow)))
(cons name open)))))
(mapcar next)
(sort #'>= :key (lambda (actor-paths)
;; (path-release2 actor-paths graph start-time)
(reduce #'+ actor-paths :key #'caddr)
))
(car))))))))
;; (princ)
(traverse action-graph actor '(aa)))))
(fiveam:test solution2
(fiveam:is
(= 1707 (reduce #'+ (solver "eg-in" 26 2) :key #'caddr)))
(fiveam:is
(= 2474 (reduce #'+ (part2 "input") :key #'caddr)))
)
(fiveam:run-all-tests)
;; (require :sb-sprof)
;; (sb-sprof:with-profiling (:max-samples 1000
;; :report :flat
;; :loop t
;; :show-progress t)
;; (dotimes (_ 100)
;; (part2 "eg-in"))
;; )
;; (time (part2 "eg-in"))
;; (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)))
|
