small js to track visit - pub/hi/scratch - Short Software projects to try things out

diff options

author	Oscar Najera <hi@oscarnajera.com>	2025-02-09 15:07:28 +0100
committer	Oscar Najera <hi@oscarnajera.com>	2025-02-09 15:07:28 +0100
commit	d75062d57029f09a0b51b640e2b4f0a1a50fa6e1 (patch)
tree	3ac527ef3c6c67b7bae2c69c18fb1449dd996940 /AoC2022/01/input
parent	050efc586b961f46f6e917cb8e4f522234f975cc (diff)
download	scratch-d75062d57029f09a0b51b640e2b4f0a1a50fa6e1.tar.gz scratch-d75062d57029f09a0b51b640e2b4f0a1a50fa6e1.tar.bz2 scratch-d75062d57029f09a0b51b640e2b4f0a1a50fa6e1.zip

small js to track visit

Diffstat (limited to 'AoC2022/01/input')

0 files changed, 0 insertions, 0 deletions

(ql:quickload '(fiveam cl-ppcre uiop arrows)) (defun data (filename) (with-open-file (in filename) (loop for line = (read-line in nil nil) while line collect (cl-ppcre:register-groups-bind (val (#'parse-integer flow) others) ("Valve (\\w+) has flow rate=(\\d+); tunnels? leads? to valves? (.+)" line) `(,(intern val) ,flow ,@(mapcar #'intern (cl-ppcre:split ", " others))))))) (defun next-steps (current graph paths) (flet ((appropriate (next) (and (not (gethash next paths)) ;; not visited (setf (gethash next paths) (cons next (gethash current paths)))))) (remove-if-not #'appropriate ;; name flow connections -> cddr (cddr (assoc current graph :test #'eq))))) (defun shortest-path (graph from to) (let ((paths (make-hash-table :test #'eq))) (setf (gethash from paths) (list from)) (labels ((traverse (queue paths) (unless (null queue) (let ((next (next-steps (car queue) graph paths))) (unless (member to next :test #'eq) (traverse (append (cdr queue) next) paths)))))) (traverse (list from) paths)) (gethash to paths))) (defun worthwhile-graph (graph) (let ((interesting (remove-if #'zerop graph :key #'cadr))) (loop for (from flow) in (cons '(aa 0) interesting) for label from 0 collect (apply #'list (ash 1 label) from flow (loop for (to) in interesting for target-label from 1 when (not (eq from to)) collect (cons (ash 1 target-label) (1- (length (shortest-path graph from to))))))))) (defun accumulated-flow (actor-paths) (reduce #'+ actor-paths :key #'caddr)) (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))))) (defun traverse (graph actors open best-flow all-valves) (if (or (zerop (logxor open all-valves)) (zerop (cadar actors)) (< (max-possible-flow graph actors open) (accumulated-flow best-flow))) (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 (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))) (actor (loop repeat actors collect `((1) ,start-time 0))) (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)))) (fiveam:is (= 1754 (accumulated-flow (solver "input" 30 1)))) (fiveam:is (= 1707 (accumulated-flow (solver "eg-in" 26 2)))) (fiveam:is (= 2474 (accumulated-flow (solver "input" 26 2))))) ;; (require :sb-sprof) ;; (sb-sprof:with-profiling (:max-samples 1000 ;; :report :flat ;; :loop t ;; :show-progress t) ;; (solver "input" 19 2)) ;; (time (solver "input" 19 2)) ;; (length (worthwhile-graph (data "input"))) ;; (loop for (name flow . neighbors) in (worthwhile-graph (data "input")) ;; do (loop for (nn . dist) in neighbors ;; do (format t "~a -> ~a [label=\"~d\"]~%" name nn dist)))


context:
space:
mode: