aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorOscar Najera <hi@oscarnajera.com>2022-12-20 00:03:30 +0100
committerOscar Najera <hi@oscarnajera.com>2022-12-20 00:06:41 +0100
commitcaaf5de9066daebfcb4bbd4a3f4953746739c225 (patch)
treeefcd28d71f3c51bcaa285f6883becf1971cf212b
parentf7037e40585d74f2ed1812f52d9b8fed37172b01 (diff)
downloadscratch-caaf5de9066daebfcb4bbd4a3f4953746739c225.tar.gz
scratch-caaf5de9066daebfcb4bbd4a3f4953746739c225.tar.bz2
scratch-caaf5de9066daebfcb4bbd4a3f4953746739c225.zip
reorder cleanup
-rw-r--r--AoC2022/16/solver.lisp209
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))))