aboutsummaryrefslogtreecommitdiffstats
path: root/AoC2022/16
diff options
context:
space:
mode:
Diffstat (limited to 'AoC2022/16')
-rw-r--r--AoC2022/16/solver.lisp92
1 files changed, 57 insertions, 35 deletions
diff --git a/AoC2022/16/solver.lisp b/AoC2022/16/solver.lisp
index e1dff91..d8cb718 100644
--- a/AoC2022/16/solver.lisp
+++ b/AoC2022/16/solver.lisp
@@ -42,7 +42,7 @@
(defun travel-time (path graph)
(loop for (from to) on path
while to
- for neighbors = (cddr (assoc from graph :test #'eq))
+ for neighbors = (cdddr (assoc from graph :test #'eq))
for distance = (cdr (assoc to neighbors :test #'eq))
sum (1+ distance) into runtime
collect runtime))
@@ -83,6 +83,10 @@
(reduce #'+ paths
:key (lambda (path) (path-release path graph start-time))))
+(defun path-to-symbols (path graph)
+ (loop for node in path
+ collect (cadr (assoc node graph :test #'=))))
+
(path-release '(AA DD) (worthwhile-graph (data "eg-in")) 26)
(path-release '(AA DD EE) (worthwhile-graph (data "eg-in")) 26)
@@ -100,40 +104,58 @@
(defun accumulated-flow (actor-paths)
(reduce #'+ actor-paths :key #'caddr))
-(defun traverse (graph actor open best-flow)
- (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)
- (let* ((current-options (assoc (car path) graph :test #'=))
- (travel-times (cdddr current-options))
- (flow-released (caddr current-options))
- (current-flow (+ previous-flow (* flow-released time-left)))
- (next
- (loop for (node . time-there) in travel-times
- :when (and (not (logtest node open))
- (let ((time-left (- time-left time-there 1)))
- (when (plusp time-left)
- (cons node (list (list (cons node path) time-left current-flow))))))
- :collect it)))
- (if (null next)
- (traverse graph
- (append (cdr actor)
- (list (list path 0 current-flow)))
- open best-flow)
- (reduce
- (lambda (acc term)
- (let* ((acc-flow (accumulated-flow acc))
- (next-actors
- (destructuring-bind (node . actor-next-move) term
- (traverse graph
- (append (cdr actor) actor-next-move)
- (logior node open)
- acc))))
- (if (>= acc-flow (accumulated-flow next-actors))
- acc next-actors)))
-
- next :initial-value best-flow))))))
+(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)))))
+
+(let* ((graph (worthwhile-graph (data "eg-in")))
+ (path '(1 64 8 32 2 16 4))
+ (sym-path (path-to-symbols path graph)))
+ (list
+ (path-release sym-path graph 30)
+ (travel-time path graph)
+ (max-possible-flow graph (list (list path 26 0)) 111))
+ )
+
+(defun traverse (graph actors open best-flow)
+ (destructuring-bind (current-actor . others) actors
+ (destructuring-bind (path time-left previous-flow) current-actor
+ (if (or (loop for ac in actors :always (zerop (cadr ac)))
+ (< (max-possible-flow graph actors open) (accumulated-flow best-flow)))
+ (mapcar (lambda (a) (cons (reverse (car a)) (cdr a))) actors)
+ (let* ((current-options (assoc (car path) graph :test #'=))
+ (travel-times (cdddr current-options))
+ (next
+ (loop for (node . time-there) in travel-times
+ :when (and (not (logtest node open))
+ (let ((time-left (- time-left time-there 1)))
+ (when (plusp time-left)
+ (let* ((flow-there (caddr (assoc node graph :test #'=)))
+ (next-flow (+ previous-flow (* flow-there time-left))))
+
+ (cons node (list (list (cons node path) time-left next-flow)))))))
+ :collect it)))
+ (if (null next)
+ (traverse graph
+ (append others
+ (list (list path 0 previous-flow)))
+ open best-flow)
+ (reduce
+ (lambda (acc term)
+ (let* ((acc-flow (accumulated-flow acc))
+ (next-actors
+ (destructuring-bind (node . actors-next-move) term
+ (traverse graph
+ (append (cdr actors) actors-next-move)
+ (logior node open)
+ acc))))
+ (if (> acc-flow (accumulated-flow next-actors))
+ acc next-actors)))
+ next
+ :initial-value best-flow)))))))
(defun solver (filename start-time actors)
(let* ((action-graph (worthwhile-graph (data filename)))