A buggy implementation of a solution for Advent of Code Day 16 2024

advent-of-code-day16.lisp

(in-package #:cl-user)

;;; Parsing the grid
(defun read-char! (in k-char k-eos)
  "Returns (k-char char). If end of stream returns (k-eos)"
  (let ((char (read-char in nil nil)))
    (cond
      (char (funcall k-char char))
      (t (funcall k-eos)))))

(defun read-line-char! (in k-char k-eol)
  "Returns (k-char char). If end of line or end of stream returns (k-eol).
Discards #\return characters."
  (read-char! in
	      (lambda (char)
		(case char
		  (#\newline (funcall k-eol))
		  ;; Discard #\return characters.
		  (#\return (read-line-char! in k-char k-eol))
		  (t (funcall k-char char))))
	      k-eol))

(defun read-grid-row! (in char row width)
  (let ((row (cons char row))
	(width (1+ width)))
    (read-line-char! in
		     (lambda (char) (read-grid-row! in char row width))
		     (lambda () (values row width)))))

(defun read-grid-rows! (in rows width height)
  (read-line-char! in
		   (lambda (char)
		     (multiple-value-bind (row width) (read-grid-row! in char () 0)
		       (read-grid-rows! in (cons row rows) width (1+ height))))
		   (lambda () (values rows width height))))

(defun read-grid! (in)
  "Read the grid into a stack of rows, where each row is a stack of characters.
Returns (values rows-stack width height)"
  (read-grid-rows! in () 0 0))

(defun fill-grid-row! (grid row-stack x y start end)
  (cond
    (row-stack
     (let ((char (first row-stack)))
       (setf (aref grid y x) char)
       (fill-grid-row! grid (rest row-stack) (1- x) y
		       (or start (and (char= char #\S) (cons x y)))
		       (or end (and (char= char #\E) (cons x y))))))
    ;; finished parsing this row.
    (t (values start end))))

(defun fill-grid-rows! (rows-stack y start end grid width)
  (cond
    (rows-stack
     (multiple-value-bind (start end) (fill-grid-row! grid (first rows-stack) (1- width) y start end)
       (fill-grid-rows! (rest rows-stack) (1- y) start end grid width)))
    (t (values grid start end))))

(defun init-grid (rows-stack width height)
  "Parse the rows-stack from READ-GRID! into a 2d array with dimensions (height width).
Returns (values grid start end)."
  (let ((grid (make-array (list height width) :initial-element #\.)))
    (fill-grid-rows! rows-stack (1- height) nil nil grid width)))

(defun insert-sorted (list value compare key)
  "Insert value into list in sorted order. Compares using (compare (key value) (key element))"
  (let ((value-key (funcall key value)))
    (labels ((iter (list)
	       (cond
		 ((null list) (list value))
		 (t (let ((first (first list))
			  (rest (rest list)))
		      (if (funcall compare value-key (funcall key first))
			  ;; (> value first)
			  (cons value list)
			  (cons first (iter rest))))))))
      (iter list))))

;;; Queue interface:
(defun make-priority-queue (get-priority)
  "enqueue! is O(n) dequeue! is O(1). (get-priority element) returns an integer priority."
  (let ((values ()))
    (labels ((enqueue! (value)
	       (setq values (insert-sorted values value #'> get-priority)))
	     (dequeue! (k-value k-empty)
	       (cond
		 ((null values) (funcall k-empty))
		 (t (funcall k-value (pop values))))))
      (cons #'enqueue! #'dequeue!))))
(defun enqueue! (queue value)
  "Adds value to queue."
  (funcall (car queue) value))
(defun dequeue! (queue k-value k-empty)
  "Removes next element from queue and returns (k-value value) or (k-empty) if the queue is empty."
  (funcall (cdr queue) k-value k-empty))

;;; Function composition
(defun compose2 (f g)
  (lambda (&rest args) (multiple-value-call f (apply g args))))
(defun compose (&rest fs)
  (cond
    ((null fs) #'values)
    ((null (rest fs)) (first fs))
    (t (reduce #'compose2 fs))))

;;; 2D points. Positive x is east, Positive y is south.
(defun p (x y) (cons x y))
(defun x (p) (car p))
(defun y (p) (cdr p))
(defun p= (a b) (and (= (x a) (x b))
		     (= (y a) (y b))))
(defun p+ (a b) (p (+ (x a) (x b)) (+ (y a) (y b))))

;;; Directions
;; Directions are one of '(:north :south :east :west)
(defun rotate-cw (dir)
  (ecase dir
    (:east :south) (:south :west)
    (:west :north) (:north :east)))
(defun rotate-ccw (dir) (rotate-cw (rotate-cw (rotate-cw dir))))
(defun direction->p (direction)
  (ecase direction
    (:east (p 1 0)) (:south (p 0 1))
    (:west (p -1 0)) (:north (p 0 -1))))

(defun pos-moved (p direction)
  (p+ p (direction->p direction)))


;;; Best-cost path Nodes
;;; Node includes both position and direction and the cost to get there.
(defun node (pos direction cost history) (vector pos direction cost history))
(defun node-pos (node) (aref node 0))
(defun node-direction (node) (aref node 1))
(defun node-cost (node) (aref node 2))
(defun node-history (node) (aref node 3))
(defun node= (n1 n2)
  "Compare node-pos and node-direction. Cost is ignored."
  (and (p= (node-pos n1) (node-pos n2)) 
       (eq (node-direction n1) (node-direction n2))))


(defun each-neighbor (node proc)
  "Apply proc to each neighbor of node."
  (let ((pos (node-pos node))
	(direction (node-direction node))
	(cost (node-cost node))
	(history (cons (list (node-pos node) (node-direction node)) (node-history node))))
    ;; Move forward in the same direction: cost 1
    (funcall proc (node (pos-moved pos direction) direction (+ cost 1) history))
    ;; Rotate 90 degrees: cost 1000
    (funcall proc (node pos (rotate-cw direction) (+ cost 1000) history))
    (funcall proc (node pos (rotate-ccw direction) (+ cost 1000) history))))

(defun visited? (node visited)
  "True if the node is in the set of visited nodes. Node-cost is ignored."
  (member node visited :test #'node=))

(defun pos-valid? (pos grid width height)
  "True if the position is on the grid and not a wall."
  (let ((x (x pos))
	(y (y pos)))
    (and (and (<= 0 x (1- width))
	      (<= 0 y (1- height)))
	 (not (char= (aref grid y x) #\#)))))

(defun valid-and-unvisited? (node pos-valid? visited)
  "True if the node is both valid and unvisited."
  (and (funcall pos-valid? (node-pos node))
       (not (visited? node visited))))

(defun each-valid-and-unvisited-neighbor (node pos-valid? visited proc)
  "Apply proc to each neighbor of node that is both valid and unvisited."
  (each-neighbor node
		 (lambda (neighbor)
		   (when (valid-and-unvisited? neighbor pos-valid? visited)
		     (funcall proc neighbor)))))

(defun best-cost (pos-valid? start end)
  "(funcall pos-valid? p) returns true if the given position is on the grid and not a wall.
Start and end are the positions of the start and end of the maze.
Returns the lowest costing path."
  (let ((queue
	  ;; Queue prioritizes lower cost
	  (make-priority-queue (compose #'- #'node-cost)))
	;; set of nodes that have been visited.
	(visited ()))

    (labels ((queue-empty () (error "No path found."))
	     (found-path? (node) (p= (node-pos node) end))
	     (found-path (node) node)

	     (visit-node! (node)
	       (push node visited)
	       (enqueue! queue node))

	     (visit-neighbors! (node)
	       ;; visit each valid, unvisited neighbor
	       (each-valid-and-unvisited-neighbor node pos-valid? visited #'visit-node!))

	     ;; The best-cost search loop.
	     (iter ()
	       (dequeue!
		queue
		;; continuation: queue has a node
		(lambda (node)
		  ;; node is the lowest cost path in the search queue.
		  (cond
		    ((found-path? node) (found-path node))
		    (t
		     ;; visit neighbors and continue searching
		     (visit-neighbors! node)
		     (iter))))
		;; continuation: queue is empty
		#'queue-empty)))

      ;; Start out facing east
      (visit-node! (node start :east 0 ()))
      (iter))))


(multiple-value-bind (rows width height) (with-open-file (in "./day16.example") (read-grid! in))
  (multiple-value-bind (grid start end) (init-grid rows width height)
    (best-cost (lambda (pos) (pos-valid? pos grid width height)) start end)))
;; => 7036 (correct)

(multiple-value-bind (rows width height) (with-open-file (in "./day16.example2") (read-grid! in))
  (multiple-value-bind (grid start end) (init-grid rows width height)
    (best-cost (lambda (pos) (pos-valid? pos grid width height)) start end)))
;; => 11048 (correct)

#+nil
(multiple-value-bind (rows width height) (with-open-file (in "./day16.input") (read-grid! in))
  (multiple-value-bind (grid start end) (init-grid rows width height)
    (let* ((node (best-cost (lambda (pos) (pos-valid? pos grid width height)) start end))
	   (cost (node-cost node))
	   (history (node-history node)))
      (loop for e in history
	    do (destructuring-bind (pos direction) e
		 (unless (or (p= pos start) (p= pos end))
		   (setf (aref grid (y pos) (x pos)) (case direction
						       (:north #\^) (:south #\v)
						       (:east #\>) (:west #\<))))))
      (values
       cost
       (with-output-to-string (out)
	 (loop for y from 0 below height do
	   (loop for x from 0 below width do
	     (format out "~A" (aref grid y x)))
	   (format out "~%")))))))
;; => 79412 (incorrect!)
;; Sanity check: output of maze looks correct. Path is connected and starts at S and ends at E.