aoc-cl/src/2024/day18.lisp

(defpackage :aoc/2024/18
  (:use :cl :aoc :aoc/maze :alexandria :trivia :lla :queues)
  (:export
   #:sample-data
   #:sample-data2
   #:part1
   #:part2
   #:in-bounds-p
   #:next-moves
   ))

(in-package :aoc/2024/18)

(defun parse-line (line)
  (let ((p (mapcar #'parse-integer (ppcre:split "," line))))
    (make-pos :x (first p) :y (second p))))


(defun parse-input (lines)
  (let ((mem (make-hash-table :test #'equalp)))
    (loop
      for p in (mapcar #'parse-line lines)
      for i from 1
      do (setf (gethash p mem) i))
    mem))


(defstruct memory size map)

(defparameter input-text (test-input 2024 18))
(defparameter input-data
  (make-memory
   :size 70
   :map (parse-input input-text)))

(defparameter sample-text (aoc:split-lines "5,4
4,2
4,5
3,0
2,1
6,3
2,4
1,5
0,6
3,3
2,6
5,1
1,2
5,5
2,5
6,5
1,4
0,4
6,4
1,1
6,1
1,0
0,5
1,6
2,0"))

(defparameter sample-data
  (make-memory
   :size 6
   :map (parse-input sample-text)))

(defun in-bounds-p (mem pos)
  (and
   (<= 0 (pos-x pos))
   (<= 0 (pos-y pos))
   (>= (memory-size mem) (pos-x pos))
   (>= (memory-size mem) (pos-y pos))
   ))

(defun next-moves (mem pos &optional (tm 1024))
  "return conses of next pos get there"
  (loop for d in '(#\^ #\v #\> #\<)
	for p = (pos-move pos d)
	
	if (and
	    (in-bounds-p mem p)
	    (< tm (gethash p (memory-map mem) 1000000)))
	  collect p))

(defun best-path (map time)
  (let ((start (make-pos :x 0 :y 0))
	(finish (make-pos :x (memory-size map) :y (memory-size map)))
	(path-finder (make-a-star
		      #'(lambda (map pos) (loop
					    for p in (next-moves map pos time)
					    collect (cons p 1)))
		      #'manhattan-distance)))
    (funcall path-finder map start finish)))

(defun solve-part1 (data time)
  (let ((path (best-path data time)))
    (caar path))
  )

(defun part1 (data &optional (time 1024))
  (format nil "~A" (solve-part1 data time)))

(defun pos-at-time (mem tm)
  (loop
    for k being the hash-keys of (memory-map mem)
    for v being the hash-values of (memory-map mem)
    if (= v tm)
      return k))


(defun find-block-position (mem )
  (let* ((delta (ash 1 (ceiling (log (hash-table-count (memory-map mem)) 2))))
	 (tm   0)
	 (best-tm 0))
    (loop
      for x = 1
      until (zerop delta)
      if (best-path mem tm)
	do (progn
	     (setf best-tm (max best-tm tm))
	     (incf tm delta))
      else
	do (decf tm delta)
      do (setf delta (ash delta -1))
      finally (return (pos-at-time mem (1+ best-tm))))))

(defun part2 (data)
  (let ((first-block-pos (find-block-position data)))
    (format nil "~A,~A" (pos-x first-block-pos) (pos-y first-block-pos))))

(defun solve-day ()
  (format t "part1: ~A~%" (part1 input-data))
  (format t "part2: ~A~%" (part2 input-data)))

(defun submit ()
  (let ((p1 (part1 input-data))
        (p2 (part2 input-data)))
    (if p1 (submit-part1 2024 18 p1))
    (if p2 (submit-part2 2024 18 p2))))