diff options
| -rw-r--r-- | AoC2022/16/solver.lisp | 92 |
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))) |