For day 16, we are solving a maze. We want to find the lowest cost
path from the start to the end. Taking a step straight ahead costs
1, but turning left or right costs 1000.
This puzzle was the most vexing of all the puzzles. The solution
is straightforward but the devil is the details. I found myself
constantly mired in the CARs and CDRs of the path data structure,
descending too far or not far enough. I tried several different
representations for a path, each one with its own set of problems.
Trying to keep track of the direction of the steps in the path
turned out to be an exercise in frustration.
The algorithm is a variant of Dijkstra’s algorithm, which finds the
shortest weighted path in a graph. In our case, the graph is
derived from the maze. The vertices of the graph are the locations
in the maze with three or more paths leading out of them. The edges
in the graph are the steps between the vertices. But you cannot
compute the cost of a path by summing the weights of the edges, as
the final edge in the path may be reached either by proceeding straight
through the prior vertex, or by turing left or right at the prior
vertex. Thus I modified Dijkstra's algorithm to be edge-oriented rather than
vertex-oriented. This turned out to be a key to solving the problem.
With the vertex-oriented solutions, I had to keep track of the orientation of the path
as it entered and left the vertex, and annotating the steps along the path with their orientation
turned into a bookkeeping nightmare. With the edge-oriented solution, I could discard the orientation information
as I advanced the algorithm and reconstruct the orientation information only after I had generated
a candidate path. This greatly simplified the bookkeeping.
The algorithm uses a pure functional weight-balanced binary tree as a priority
queue for the paths. The tree is kept in order of increasing path
score, so the lowest scoring path is always the leftmost path in the
tree. In my original implementation, I punted and used a linear
priority queue. This is simple, and it works, but is far too slow. The
weight-balanced binary tree was cribbed from MIT-Scheme.
;;; -*- Lisp -*-
(in-package "ADVENT2024/DAY16")
(defun read-input (input-pathname)
(read-file-into-grid
(char-interner #’identity (find-package "ADVENT2024/DAY16"))
input-pathname))
(defun start-and-goal (maze)
(let ((inverse (invert-grid maze ’|.|)))
(values (first (gethash ’S inverse))
(first (gethash ’E inverse)))))
Since Dijkstra’s algorithm is a graph algorithm, we need to
represent the maze as a graph. We simplify the graph by flooding
the dead ends.
(defun dead-end? (maze coord)
(and (on-grid? maze coord)
(eql (grid-ref maze coord) ’|.|)
(let ((n (coord-north coord))
(s (coord-south coord))
(e (coord-east coord))
(w (coord-west coord)))
(let ((n* (or (not (on-grid? maze n))
(eql (grid-ref maze n) ’\#)))
(s* (or (not (on-grid? maze s))
(eql (grid-ref maze s) ’\#)))
(e* (or (not (on-grid? maze e))
(eql (grid-ref maze e) ’\#)))
(w* (or (not (on-grid? maze w))
(eql (grid-ref maze w) ’\#))))
(or (and n* e* w*)
(and e* n* s*)
(and s* e* w*)
(and w* n* s*))))))
(defun flood-dead-end! (maze coord)
(when (dead-end? maze coord)
(setf (grid-ref maze coord) ’\#)
(flood-dead-end! maze (coord-north coord))
(flood-dead-end! maze (coord-south coord))
(flood-dead-end! maze (coord-east coord))
(flood-dead-end! maze (coord-west coord))))
(defun flood-dead-ends! (maze)
(iterate ((coord (scan-grid-coords maze)))
(flood-dead-end! maze coord)))
We then mark the vertices of the graph by looking for locations
with three or more paths leading out of them.
(defun vertex? (maze coord)
(and (on-grid? maze coord)
(eql (grid-ref maze coord) ’|.|)
(let ((n (coord-north coord))
(s (coord-south coord))
(e (coord-east coord))
(w (coord-west coord)))
(let ((n* (and (on-grid? maze n) (member (grid-ref maze n) ’(\. + S E))))
(s* (and (on-grid? maze s) (member (grid-ref maze s) ’(\. + S E))))
(e* (and (on-grid? maze e) (member (grid-ref maze e) ’(\. + S E))))
(w* (and (on-grid? maze w) (member (grid-ref maze w) ’(\. + S E)))))
(or (and n* e* w*)
(and e* n* s*)
(and s* e* w*)
(and w* n* s*))))))
(defun mark-vertices! (maze)
(let ((vertices ’()))
(iterate ((coord (scan-grid-coords maze)))
(when (vertex? maze coord)
(setf (grid-ref maze coord) ’+)
(push coord vertices)))
vertices))
After flooding the dead ends and marking the vertices, all the edges begin and end at a vertex.
It isn’t necessary for the solution, but it helps to be able to
visualize the maze. The show-maze procedure will print
the maze to the standard output. The show-maze
procedure takes an optional list of coords to highlight in the
maze.
(defun show-maze (maze &optional highlight)
(format t "~&")
(dotimes (row (grid-height maze))
(format t "~%")
(dotimes (col (grid-width maze))
(cond ((eql (grid-ref maze (coord col row)) ’\#)
(format t "#"))
((member (coord col row) highlight :test #’equal)
(format t "O"))
((eql (grid-ref maze (coord col row)) ’|S|)
(format t "S"))
((eql (grid-ref maze (coord col row)) ’|E|)
(format t "E"))
((eql (grid-ref maze (coord col row)) ’+)
(format t "+"))
(t
(format t "."))))))
Between the vertices, we have the edges of the graph. An edge is
simply the a list of coordinates between two vertices. The first
and last coordinates of the edge are vertices. To find all the
coordinates between two vertices, we walk the edge from the start
until we reach another vertex. We don’t maintain direction.
Instead, we just make sure that the new coordinate isn’t the last
one in the edge we are walking so that we move forward.
(defun walk-edge (maze coord edge)
(let ((n (coord-north coord))
(s (coord-south coord))
(e (coord-east coord))
(w (coord-west coord)))
(cond ((and (on-grid? maze n)
(not (equal n (first edge)))
(eql (grid-ref maze n) ’|.|))
(walk-edge maze n (cons coord edge)))
((and (on-grid? maze n)
(not (equal n (first edge)))
(member (grid-ref maze n) ’(+ S E)))
(list* n coord edge))
((and (on-grid? maze e)
(not (equal e (first edge)))
(eql (grid-ref maze e) ’|.|))
(walk-edge maze e (cons coord edge)))
((and (on-grid? maze e)
(not (equal e (first edge)))
(member (grid-ref maze e) ’(+ S E)))
(list* e coord edge))
((and (on-grid? maze s)
(not (equal s (first edge)))
(eql (grid-ref maze s) ’|.|))
(walk-edge maze s (cons coord edge)))
((and (on-grid? maze s)
(not (equal s (first edge)))
(member (grid-ref maze s) ’(+ S E)))
(list* s coord edge))
((and (on-grid? maze w)
(not (equal w (first edge)))
(eql (grid-ref maze w) ’|.|))
(walk-edge maze w (cons coord edge)))
((and (on-grid? maze w)
(not (equal w (first edge)))
(member (grid-ref maze w) ’(+ S E)))
(list* w coord edge)))))
Given a vertex, we can find all the edges that lead out of that
vertex.
(defun vertex-edges (maze vertex)
(let ((n (coord-north vertex))
(s (coord-south vertex))
(e (coord-east vertex))
(w (coord-west vertex))
(edges ’()))
(when (and (on-grid? maze n) (member (grid-ref maze n) ’(|.| + S E)))
(push (walk-edge maze n (list vertex)) edges))
(when (and (on-grid? maze s) (member (grid-ref maze s) ’(|.| + S E)))
(push (walk-edge maze s (list vertex)) edges))
(when (and (on-grid? maze e) (member (grid-ref maze e) ’(|.| + S E)))
(push (walk-edge maze e (list vertex)) edges))
(when (and (on-grid? maze w) (member (grid-ref maze w) ’(|.| + S E)))
(push (walk-edge maze w (list vertex)) edges))
edges))
Given the ordered list of coords in a path through the maze, we
need to be able to score it. There is a cost of 1 for every step,
and a cost of 1000 for every turn. We calculate these
separately.
To find the directions of the steps in the path, we examine
adjacent coords. If the columns are the same, the direction is
north/south. If the rows are the same, the direction is east/west.
The very first direction is east/west because the start is always
facing east. Once we have a sequence of the directions, we examine
adjacent directions to see if they are the same. If they are, we
went straight, otherwise we turned.
(defun count-turns (coord-list)
(multiple-value-bind (bs as)
(chunk 2 1 (multiple-value-bind (ls rs) (chunk 2 1 (scan ’list coord-list))
(catenate (#M(lambda (l r)
(cond ((= (column l) (column r)) ’ns)
((= (row l) (row r)) ’ew)
(t (error "Funky coord-list."))))
ls
rs)
(scan ’list (list ’ew)))))
(collect-length (choose (#Mnot (#Meq bs as))))))
(defun score-coord-list (coord-list)
(1- (+ (length coord-list)
(* 1000 (count-turns coord-list)))))
We represent a path as a list of edges. Given a list of edges, we
need to stitch them together to create a list of coords in order to
score the path. We cannot simply append the edges together, as the
vertices between the edges will be duplicated. Instead, we drop
the last coord (the ending vertex) from each edge except the
first.
(defun at-goal? (path goal)
(equal (first (first path)) goal))
(defun path->coord-list (path)
(if (null (rest path))
(first path)
(append (butlast (first path)) (path->coord-list (rest path)))))
Given a path, we can extend it by finding the edges that lead out
of the last vertex in the path. We discard the edge that
came into the vertex, as we don’t want to backtrack.
(defun path-extensions (maze path)
(let* ((latest-edge (first path))
(latest-vertex (first latest-edge))
(back-edge (reverse latest-edge))
(outgoing-edges (remove back-edge (vertex-edges maze latest-vertex) :test #’equal)))
(map ’list (lambda (edge) (cons edge path)) outgoing-edges)))
As I mentioned earlier, we use a weight-balanced binary tree as a
priority queue. I didn’t bother trying to abstract this. I’m just
manipulate the raw nodes of the tree. Each node has a key, which
is the score, and a value, which is a list of paths that have that
score. We compare keys with the < function.
Weight-balanced binary trees are pure functional — adding or popping
the queue returns a new queue rather than side effecting the
existing one.
(defun make-priority-queue ()
wtree::empty)
(defun pq-insert (pq entry score)
(let* ((probe (wtree::node/find #’< pq score)))
(wtree::node/add #’< pq score (cons entry (and probe (wtree::node/v probe))))))
(defun pq-pop (pq)
(let* ((node (wtree::node/min pq))
(score (wtree::node/k node))
(value-list (wtree::node/v node))
(value (car value-list))
(tail (cdr value-list)))
(if (null tail)
(values value score (wtree::node/delmin pq))
(values value score (wtree::node/add #’< (wtree::node/delmin pq) score tail)))))
We finally arrive at the solve-maze procedure. This
proceeds in three parts. First, we prepare the maze by flooding the
dead ends and marking the vertices. We
initialize visited-edges which is a hash table mapping
an edge to the lowest score that has been found for a path ending in
that edge. We initialize predecessor-edges which is a
hash table mapping an edge to the edge that came before it in the
lowest scoring path. The initial edges are the ones leading out of
the start vertex, and the initial paths are the paths each
containing one of the initial edges.
The second part is the main iteration. The outer iteration pops
the lowest scoring path so far from the priority queue. If the path
ends at the goal, we have found one solution and we proceed to part
three where we collect other solutions that with the same score that
end at the goal. Otherwise, we enter an inner loop over all ways we
can extend the path by one edge. For each extension, we score the
extension and look up the most recent edge in
the visited-edges.
If we have not visited the edge before, we store the edge
in visited-edges and store its predecessor
in predecessor-edges. If we have visited the edge
before, we have three cases. If the score of the extension is
greater that the score we have seen before, we discard the
extension. If the score of the extension is equal to the score we
have see before, we add the edge preceeding the final edge to
the predecessor-edges, but do not pursue this path
further. If the score of the extension is less than the score we
have previously found, we update the visited-edges with
the new lower score and update the predecessor-edges so
that this path is the only path leading to the final edge.
When we find a path that ends at the goal, we enter the third part
of the procedure. We pop paths from the priority queue collecting
any other paths that have also reached the goal with the same
score. Finally, we return the list of shortest paths.
(defun solve-maze (maze)
(flood-dead-ends! maze)
(mark-vertices! maze)
(multiple-value-bind (start goal)
(start-and-goal maze)
(let* ((visited-edges (make-hash-table :test ’equal))
(predecessor-edges (make-hash-table :test ’equal))
;; The initial edges are the ones that start at the start vertex.
(initial-edges (vertex-edges maze start))
;; A path is a list of edges. An initial path is a list of one edge starting at the start vertex.
(initial-paths (map ’list #’list initial-edges)))
(dolist (edge initial-edges)
(setf (gethash edge visited-edges) (score-path (list edge))))
;; Main loop, iteratively extend the lowest scoring path.
(let iter ((scored-paths (do ((pq (make-priority-queue) (pq-insert pq (car initial-paths) (score-path (car initial-paths))))
(initial-paths initial-paths (cdr initial-paths)))
((null initial-paths) pq))))
(unless (wtree::empty? scored-paths)
(multiple-value-bind (path path-score next-scored-paths) (pq-pop scored-paths)
(if (at-goal? path goal)
;; Reached the goal. Keep popping until we have all solutions.
(let solution-iter ((solutions (list path))
(next-scored-paths next-scored-paths))
(if (wtree::empty? next-scored-paths)
solutions
(multiple-value-bind (other-path other-path-score next-scored-paths) (pq-pop next-scored-paths)
(if (= other-path-score path-score)
(solution-iter (if (at-goal? other-path goal)
(cons other-path solutions)
solutions)
next-scored-paths)
(values solutions predecessor-edges)))))
(let iter1 ((extensions (path-extensions maze path))
(next-scored-paths next-scored-paths))
(if (null extensions)
(iter next-scored-paths)
(let* ((extension (first extensions))
(extension-score (score-path extension))
(latest-edge (first extension))
(predecessor (second extension))
(prior-score (gethash latest-edge visited-edges)))
(cond ((null prior-score)
(setf (gethash latest-edge visited-edges) extension-score
(gethash latest-edge predecessor-edges) (list predecessor))
(iter1 (rest extensions)
(pq-insert next-scored-paths extension extension-score)))
;; If we have found an extension with a worse score, we ignore it.
((> extension-score prior-score)
(iter1 (rest extensions) next-scored-paths))
;; If we have found an extension with an equal score, we add the predecessor,
;; but do not pursue it further.
((= extension-score prior-score)
(push predecessor (gethash latest-edge predecessor-edges))
(iter1 (rest extensions) next-scored-paths))
;; If we have found an extension with a better score, we replace the prior extension.
((< extension-score prior-score)
(setf (gethash latest-edge visited-edges) extension-score
(gethash latest-edge predecessor-edges) (list predecessor))
(iter1 (rest extensions)
(pq-insert next-scored-paths extension extension-score))))))))))))))
Of note is how the inner and outer iterations interact. The inner
iteration is initialized with one of the loop variables of the outer
loop. When the inner loop is done, it tail calls the outer loop
with the loop variable it originally got from the outer loop. This
gives the effect of the inner loop sharing a loop variable with the
outer loop.
collect-minimum-coords collects all the coords along
all minimal paths that lead through edges on the edge list.
(defun collect-minimum-coords (edge-list predecessor-table)
(fold-left (lambda (coords edge)
(union coords
(union edge (collect-minimum-coords (gethash edge predecessor-table) predecessor-table)
:test #’equal)
:test #’equal))
’()
edge-list))
For part 1 of the puzzle, we solve the maze and return the score of
a shortest path.
(defun part-1 ()
(let ((maze (read-input (input-pathname))))
(multiple-value-bind (paths predecessor-table) (solve-maze maze)
(declare (ignore predecessor-table))
(score-path (first paths)))))
For part 2 of the puzzle, we solve the maze and collect the coords of
all the minimal paths that lead through the edges of the shortest
paths.
(defun part-2 ()
(let ((maze (read-input (input-pathname))))
(multiple-value-bind (paths predecessor-table) (solve-maze maze)
(let ((minimum-coords (collect-minimum-coords (map ’list #’first paths) predecessor-table)))
(length minimum-coords)))))
