advent-2024/p16/p16.org

#+title: Solution to p16

Load map
#+begin_src emacs-lisp :results none
  (require 'dash)
  (with-temp-buffer
      (insert-file-contents "input2")
      (goto-char (point-min))
      (replace-regexp "^\\(#.*#\\)$" "\"\\1\"")
      (goto-char (point-min))
      (insert "(setq data '(")
      (goto-char (point-max))
      (insert "))")
      (eval-buffer))

  (setq data-chars (-map (lambda (str) (--map (string-to-char it) (split-string str "\\|.+" t)))
             data)
      height (length data-chars)
      width (length (car data-chars)))

  (setq start (list 1 (- height 2)))
#+end_src

and split into a list of list of chars
#+begin_src emacs-lisp :results none
  (defun char-at (p)
    (nth (car p) (nth (cadr p) data-chars)))

  (setq char-things-alist '((?# . wall)
                            (?. . free)
                            (?S . start)
                            (?E . end)))

  (defun thing-at (p)
      "Returns which object (if any) is present at position P"
      (cdr (assoc (char-at p) char-things-alist)))
#+end_src

Define some aux functions
#+begin_src emacs-lisp :results none
  (setq max-lisp-eval-depth 1000000) ; burn baby burn

  (defun dot (a b)
    "Return the dot product of the two vectors"
    (-reduce #'+ (-map (lambda (x) (* (car x) (cdr x))) (-zip-pair a b))))

  (defun neighbour (p dir)
    "Returns the neighbour to P in the direction DIR"
    (list (+ (car p) (car dir))
          (+ (cadr p) (cadr dir))))
#+end_src

Thia is the naïve implementation. Explore the maze;
this function returns a list of paths and the
associated scores; it blows the stack on the actual input
#+begin_src emacs-lisp
  (defun >nil (a b)
    (when b
      (or (not a) (> a b))))

  (defun explore (p dir score &optional past)
    "Explore the maze starting at position P and in the direction
  DIR. Returns nil if we will dead-end or loop or the score
  if we reach the end"
    (if (eq (thing-at p) 'end) score
      (unless (-contains-p past p)	; loop
	(let* ((forward-dirs (--filter (>= (dot it dir) 0)
				       '((0 1) (0 -1) (-1 0) (1 0))))
	       (acceptable-dirs (--filter (not (eq (thing-at (neighbour p it)) 'wall)) forward-dirs)))
	  (-min-by #'>nil (-map (lambda (newdir)
				  (explore (neighbour p newdir) newdir
					   (+ score (if (equal newdir dir) 1 1001))
					   (cons p past)))
				acceptable-dirs))))))

  (explore start '(1 0) 0)
#+end_src

For debugging, print the map and some aux info
#+begin_src emacs-lisp :results none
  (setq dir-alist '( ((1 0) . ?→)
                     ((-1 0). ?←)
                     ((0 -1). ?↑)
                     ((0 1) . ?↓)))

  (defun plot (p s)
      (goto-line (+ (cadr p) 1))
      (move-to-column (car p))
      (insert s)
      (delete-char 1))

  (defun print-map (&optional p)
    (with-temp-buffer
      (-each data (lambda (x) (insert x) (insert "\n")))
      (-each book (lambda (x) (plot x ?X)))
      (-each start-list (lambda (x) (plot (car x) (cdr (assoc (cadr x) dir-alist)))))
      (when p (plot p ?@))
      (write-file "tmp")) )
#+end_src

Let us try with a different approach.  Now we start from a point and a
direction; we do one round of explorations and end up with a list of
starting points, directions and accumulated scores.
we stop at each turn
#+begin_src emacs-lisp
  (setq start-vector (list start '(1 0) 0)) ; starting point, direction and score

  (defun next-dirs (dir)
    (--filter (>= (dot it dir) 0) '((0 1) (0 -1) (-1 0) (1 0))))

  (defun acceptable-p (p dir)
    (not (eq (thing-at (neighbour p dir)) 'wall)))

  (defun sort-vecs (a b)
    (< (caddr a) (caddr b)))

  (defun delta-score (olddir newdir)
    (if (equal olddir newdir) 1 1001))

  (defun explore (start-vect)
    (if (eq (thing-at (car start-vect)) 'end) (progn (push (caddr start-vect) scores) nil)
      (let* ((p (car start-vect))
	     (dir (cadr start-vect))
	     (score (caddr start-vect))
	     (acceptable-next-dirs (--filter (acceptable-p p it) (next-dirs dir))))
	(unless (-contains-p book (list p dir))
	  (push (list p dir) book)
	  (--map (list (neighbour p it) it (+ score (delta-score it dir))) acceptable-next-dirs)))))

  (setq book nil
	scores nil)

  (setq start-list (list start-vector))
  (while  (setq start-list (-concat (explore (car start-list)) (cdr  start-list)))
    (setq start-list (-sort #'sort-vecs start-list)))
  scores
#+end_src

#+results:
| 81444 | 72428 |

And this is for part 2. We find the "best" route and keep a pile of
discarded routes.  Routes can be discarded because they enter an area
that another route has visited already, but they may give the same
score.  Hence at the end we look (recursively) in the discard pile and
put the ones that end on the best paths with the same score in the
best pile.
#+begin_src emacs-lisp
  (setq start-vector (list start '(1 0) 0)) ; starting point, direction and score

  (defun next-dirs (dir)
    (--filter (>= (dot it dir) 0) '((0 1) (0 -1) (-1 0) (1 0))))

  (defun acceptable-p (p dir)
    (not (eq (thing-at (neighbour p dir)) 'wall)))

  (defun sort-vecs (a b)
    (< (caddar a) (caddar b)))

  (defun delta-score (olddir newdir)
    (if (equal olddir newdir) 1 1001))

  (defun explore (start-vects)
    (let ((start-vect (car start-vects)))
      (if (eq (thing-at (car start-vect)) 'end) (progn (push start-vects scores) nil)
        (let* ((p (car start-vect))
               (dir (cadr start-vect))
               (score (caddr start-vect))
               (acceptable-next-dirs (--filter (acceptable-p p it) (next-dirs dir))))
          (if (-contains-p book (list p dir)) (progn (push start-vects discard) nil)
            (push (list p dir) book)
            (--map (cons (list (neighbour p it) it (+ score (delta-score it dir))) start-vects) acceptable-next-dirs))))))

  (setq book nil
        scores nil
        discard nil)

  (setq start-list (list (list start-vector)))
  (while  (setq start-list (-concat (explore (car start-list)) (cdr  start-list)))
    (setq start-list (-sort #'sort-vecs start-list)))
  (let ((best (list (cadr scores)))
        (repechage t))
    (while repechage
      (setq repechage (-filter (lambda (candidate)
                                 (--any-p (-contains-p it (car candidate)) best))
                               discard))
      (setq best (-union repechage best)
            discard (-difference discard repechage)))
    (length (-distinct (--mapcat (-map #'car it) best))))
#+end_src

#+results:
: 456