aoc-cl/src/2024/day18.lisp

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

(in-package :aoc/2024/18)

(defstruct pos
  (x 0 :type fixnum)
  (y 0 :type fixnum))

(defun pos-move (pos dir)
  (case dir
    (#\^ (make-pos :x (pos-x pos) :y (1- (pos-y pos))))
    (#\v (make-pos :x (pos-x pos) :y (1+ (pos-y pos))))
    (#\< (make-pos :x (1- (pos-x pos)) :y (pos-y pos)))
    (#\> (make-pos :x (1+ (pos-x pos)) :y (pos-y pos)))
    ))

(defun show-map (map &optional (dest t))
  (let ((w (array-dimension map 1))
	(h (array-dimension map 0)))
    (format
     dest "~{~A~}"
     (loop
       for row from 0 below h
       collect (format nil "~A~%"
		       (coerce
			(loop for col from 0 below w
			      collect (aref map row col))
			'string))))))

(defun get-pos (map pos)
  (aref map (pos-y pos) (pos-x pos)))

(defun set-pos (map pos tile)
  (setf (aref map (pos-y pos) (pos-x pos)) tile))

(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 distance-estimate-f (finish)
  "estimate the distance for a reindeer from given finish"
  (let ((a finish))
    (lambda (b)
      (+
       (abs (- (pos-x a) (pos-x b)))
       (abs (- (pos-y a) (pos-y b)))
       ))))

(defstruct state score path)

(defun compare-states-f (finish)
  (let ((dist-est (distance-estimate-f finish)))
    (lambda (s1 s2)
      (< (+ (state-score s1)
	    (funcall dist-est (car (state-path s1))))
	 (+ (state-score s2)
	    (funcall dist-est (car (state-path s2))))))))

(defun best-path (map time)
  (let* ((start (make-pos :x 0 :y 0))
	 (finish (make-pos :x (memory-size map) :y (memory-size map)))
	 (state-comparison (compare-states-f finish))
	 (best (make-hash-table :test #'equalp))
	 (todo (make-queue :priority-queue :compare state-comparison)))
    (qpush todo (make-state
		 :path (list start)
		 :score 0))    
    (loop
      for s = (qpop todo)
      until (or
	     (null s)
	     (equalp (first (state-path s)) finish))
      finally (return s)
      do (loop
	   for next in (next-moves map (first (state-path s)) time)
	   for score = (+ (state-score s) 1)
	   if (> (gethash next best 1000000000) score)
	     do (progn
		  (qpush todo
			 (make-state
			  :path (cons next (state-path s))
			  :score score))
		  (setf (gethash next best) score)))

      )))

(defun solve-part1 (data time)
  (let ((path (best-path data time)))
    (state-score 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
      do (format t "delta: ~A, tm: ~A, best-tm: ~A~%" delta tm best-tm)
      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))))