diff options
| -rw-r--r-- | AoC2022/16/solver.lisp | 209 |
1 files changed, 105 insertions, 104 deletions
diff --git a/AoC2022/16/solver.lisp b/AoC2022/16/solver.lisp index 9f9ac68..f3ecf5d 100644 --- a/AoC2022/16/solver.lisp +++ b/AoC2022/16/solver.lisp @@ -25,8 +25,6 @@ (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) @@ -39,68 +37,6 @@ when (not (eq from to)) collect (cons (ash 1 target-label) (1- (length (shortest-path graph from to))))))))) -(defun travel-time (path 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-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 = (rassoc from graph :key #'car) then node-to - and node-to = (rassoc to graph :key #'car) - while node-to - for neighbors = (cdddr node-from) - for flow = (caddr node-to) - for distance = (cdr (assoc (car node-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)))) - -(defun path-release2 (paths graph start-time) - (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) -(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 accumulated-flow (actor-paths) (reduce #'+ actor-paths :key #'caddr)) @@ -111,15 +47,6 @@ :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 all-valves) (if (or (zerop (logxor open all-valves)) (zerop (cadar actors)) @@ -127,37 +54,37 @@ (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 - (destructuring-bind (current-node _label _flow . travel-times) - (assoc (car path) graph :test #'=) - (let ((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) - (progn - ;; (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)) - (next-actors - (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 next-actors)) - acc next-actors))) - next - :initial-value best-flow)))))))) + (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))) @@ -165,6 +92,80 @@ (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)))) |