day-17.lisp (3708B)
1 (defpackage #:aoc/day-17 2 (:use #:cl #:aoc/utils) 3 (:export #:day-17)) 4 (in-package #:aoc/day-17) 5 6 (defparameter *dirs* '(:left (-1 . 0) 7 :up (0 . -1) 8 :right (1 . 0) 9 :down (0 . 1))) 10 11 (defparameter *next-dirs* '(:left (:up :down) 12 :up (:left :right) 13 :right (:up :down) 14 :down (:left :right))) 15 16 (defun make-side-in-map-p (map closed) 17 (lambda (side) 18 (or (< (point-x (car side)) 0) 19 (< (point-y (car side)) 0) 20 (>= (point-x (car side)) (input-map-width map)) 21 (>= (point-y (car side)) (input-map-height map)) 22 (gethash side closed)))) 23 24 (defun next-steps-crucible (map pos dir steps closed) 25 (let (sides) 26 (when (< steps 3) 27 (push (list (point+ pos (getf *dirs* dir)) 28 dir 29 (1+ steps)) 30 sides)) 31 (loop for next in (getf *next-dirs* dir) 32 do (push (list (point+ pos (getf *dirs* next)) 33 next 34 1) 35 sides)) 36 (remove-if (make-side-in-map-p map closed) sides))) 37 38 (defun next-steps-ultra-crucible (map pos dir steps closed) 39 (let (sides) 40 (when (< steps 10) 41 (push (list (point+ pos (getf *dirs* dir)) 42 dir 43 (1+ steps)) 44 sides)) 45 (when (> steps 3) 46 (loop for next in (getf *next-dirs* dir) 47 do (push (list (point+ pos (getf *dirs* next)) 48 next 49 1) 50 sides))) 51 (remove-if (make-side-in-map-p map closed) sides))) 52 53 (defun find-path-with-lowest-head-loss (map next-steps) 54 (loop with todo = (let ((q (make-queue :priority-queue :compare (lambda (a b) 55 (< (fourth a) 56 (fourth b)))))) 57 (qpush q (list (cons 0 0) :right 0 0 nil)) 58 (qpush q (list (cons 0 0) :down 0 0 nil)) 59 q) 60 with closed = (make-hash-table :test 'equal) 61 with goal = (cons (1- (input-map-width map)) 62 (1- (input-map-height map))) 63 while (> (qsize todo) 0) 64 for (pos dir steps heat-loss) = (qpop todo) 65 when (equal pos goal) 66 do (return heat-loss) 67 do (setf (gethash (list pos dir steps) closed) t) 68 do (loop for (next next-dir steps) in (funcall next-steps map pos dir steps closed) 69 for cost = (char-number (map-cell map next)) 70 for next-heat-cost = (+ heat-loss cost) 71 for existing = (queue-find todo (lambda (existing) 72 (and (equal (first existing) next) 73 (eq (second existing) next-dir) 74 (eql (third existing) steps)))) 75 for existing-value = (and existing 76 (queues::node-value existing)) 77 do (cond 78 ((and existing-value 79 (< next-heat-cost (fourth existing-value))) 80 (setf (fourth existing-value) next-heat-cost)) 81 ((null existing-value) 82 (qpush todo (list next next-dir steps next-heat-cost))))))) 83 84 (defun day-17 (input) 85 (let ((map (make-map input))) 86 (values (find-path-with-lowest-head-loss map #'next-steps-crucible) 87 (find-path-with-lowest-head-loss map #'next-steps-ultra-crucible))))