early exit for unpromissing paths

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)))