It has been several months since I spent any time on last year's Advent of Code. I spent some time this weekend puzzling over two more days of puzzles, bringing my progress up to four days.
This was an interesting puzzle after spending some time reading about array programming languages like Klong and J. My general approach was intially confounded by my lack of familiarity with matrix programming in a more "traditional" language like Common Lisp.
The first few bits of setup require a 2-dimensional matrix as described in the prompt, 1000x1000, initially zeroed out in my case. Further, I've defined a struct that mirrors the information available in each line of the data.
(defvar *FABRIC* (make-array '(1000 1000) :initial-element 0))
(defvar *CLAIMS*)
(defstruct claim id left top width height)
The first bit of work is to parse a single line of the puzzle data
into the shape of the above struct. As an exercise to myself, I wanted
to avoid relying on a library such as
cl-ppcre. There is some fun to
be had in discovering what a language does and doesn't support, in
this case, a simple parser is perhaps a little annoying, but not
problematic.
(defun lousy-parse (claim-string)
"parse string of the form \"#1 @ 808,550: 12x22\" into a claim struct"
(flet ((integer-at (n)
(parse-integer claim-string :start n :junk-allowed t))
(find-char (char from)
(position char claim-string :start from)))
(multiple-value-bind (id start-position) (integer-at 1)
(let* ((comma-position (find-char #\, start-position))
(colon-position (find-char #\: comma-position))
(x-position (find-char #\x colon-position))
(left (integer-at (+ 3 start-position)))
(top (integer-at (+ 1 comma-position)))
(width (integer-at (+ 1 colon-position)))
(height (integer-at (+ 1 x-position))))
(make-claim :id id
:left left
:top top
:width width
:height height)))))
I am given to understand that the loop macro can be devisive in the
LISP community, for the heavy-handedness of the DSL it provides. I
suppose I can understand that, but in this case, it isn't so different
from a list comprehension in Python. Here I'm collecting into a list
the results of "parsing" each line in the file.
(defun collect-claims (filename)
(with-open-file (stream filename)
(loop for line = (read-line stream nil)
while line
collect (lousy-parse line))))
In an effort to improve the readability of the loop, I've written a pretty deep let-binding to split out the rectangle that makes up a claim. With the bounding rectangle, it is possible to loop over each point within it on the two-dimensional array that is the "fabric" and increment a counter at that point.
I've used map along with nil only in order to avoid printing the
list of NIL from repeatedly calling stake-claim. I have a feeling
there is a better way to do this.
(defun stake-claim (claim)
(let* ((top (claim-top claim))
(left (claim-left claim))
(width (claim-width claim))
(height (claim-height claim))
(bottom (1- (+ top height)))
(right (1- (+ left width))))
(loop for i from top to bottom
do (loop for j from left to right
do (incf (aref *FABRIC* i j))))))
(defun tally-claims ()
(map nil #'stake-claim *CLAIMS*))
(setf *CLAIMS* (collect-claims "3.txt"))
(tally-claims)
In the example given for the puzzle, my tallying ends up with something like:
CL-USER> *FABRIC*
#2A((0 0 0 0 0 0 0 0 0 0)
(0 0 0 1 1 1 1 0 0 0)
(0 0 0 1 1 1 1 0 0 0)
(0 1 1 2 2 1 1 0 0 0)
(0 1 1 2 2 1 1 0 0 0)
(0 1 1 1 1 1 1 0 0 0)
(0 1 1 1 1 1 1 0 0 0)
(0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0)
(0 0 0 0 0 0 0 0 0 0))
Finally I get to use one interesting aspect of arrays in Common Lisp,
in order to count those points within the two-dimensional array that
are greater than one, I wanted to "flatten" the array. It turns out
that arrays support a :displaced-to keyword argument, that allows a
second array of a different rank to be declared that acts like a view
into the original array. In this way, an array of 5x5 can be made to
look like a one-dimensional array of 25, while updates are tracked
back to the original two-dimensional array as necessary.
(count-if (lambda (n) (> n 1))
(make-array (array-total-size *FABRIC*) :displaced-to *FABRIC*))
To find the single "claim" that did not overlap with another I loop back through each claim and instead of tallying it, check whether the tally for each point within its rectangle is equal to 1 on the "fabric" of all claims. This has some unfortunate duplication in the let-binding, but I'm willing to live with it.
(defun peel-back-claim (claim)
(let* ((top (claim-top claim))
(left (claim-left claim))
(width (claim-width claim))
(height (claim-height claim))
(bottom (1- (+ top height)))
(right (1- (+ left width)))
(tallies '()))
(loop for i from top to bottom
do (loop for j from left to right
do (push (= 1 (aref *FABRIC* i j)) tallies)))
(if (not (member NIL tallies)) claim)))
(remove-if #'null (mapcar #'peel-back-claim *CLAIMS*))
The approach I decided on for this problem was a series of nested data structures layed out like:
My thinking was, each shift is of a fixed size (60) but the number of shifts is not fixed. The aggregations across shifts are related by the ID of the guards and should be fast to look up.
The first step was to sort the input, which was thankfully orderable lexographically:
(defparameter sorted-entries
(sort (with-open-file (stream "4.txt")
(loop for line = (read-line stream nil)
while line
collect line)) #'string-lessp))
Instead of writing a single "parse" function like in day 3, I instead opted to write a number of smaller helper functions to improve readability without bothering to layout an entire struct for any one part.
(defun new-shift () (make-array '(60) :initial-element 0))
(defun minute (entry) (parse-integer entry :start (1+ (position #\: entry)) :junk-allowed t))
(defun waking? (entry) (search "wakes" entry))
(defun sleeping? (entry) (search "asleep" entry))
(defun shift-change? (entry)
"returns guard ID from string like: \"[1518-03-09 23:46] Guard #727 begins shift\""
(let ((id-position (position #\# entry)))
(if id-position
(parse-integer entry :start (+ 1 id-position) :junk-allowed t))))
The first piece that I was pleased to find worked without issue was
the time-tracking for each shift. Knowing that the shift-change?
function would trigger a termination of the current "shift" array, I
decided to sustain a bit of inefficiency to ease the implementation of
how each minute is tracked per-shift.
If you imagine an 8 minute shift like this:
| 0 | 0 | 0 | 0 | 0 | 0 | 0 | 0 |
Each waking or sleeping event takes only the present time and "paints"
or fills forward the appropriate value (0 for waking, 1 for
sleeping). If you imagine a "falls asleep at 2", the fill-forward
applies the "sleeping" value until the end of the array:
| 0 | 1 | 1 | 1 | 1 | 1 | 1 | 1 |
| → | → | → | → | → | → | → |
It is only with an entry for waking, example "wakes at 5", that the values are zeroed out (again):
| 0 | 0 | 1 | 1 | 1 | 0 | 0 | 0 |
| → | → | → |
(defun fill-forward (shift index value)
(loop for minute from index to (1- (length shift))
do (setf (aref shift minute) value)))
(defvar table
(let ((current-guard NIL)
(current-shift (new-shift))
(table (make-hash-table)))
(loop for entry in sorted-entries
for guard-id = (shift-change? entry)
do (cond (guard-id (progn
(push current-shift (gethash current-guard table '()))
(setf current-guard guard-id)
(setf current-shift (new-shift))))
((waking? entry) (fill-forward current-shift (minute entry) 0))
((sleeping? entry) (fill-forward current-shift (minute entry) 1))))
(remhash NIL table)
(push current-shift (gethash current-guard table '()))
table))
With a table of shift entries per-guard ID available, the remaining piece is to do the necessary aggregations.
(defun sum-of-shifts (shift-list)
(apply #'map-into (new-shift) #'+ shift-list))
The first bit that I found fun was, perhaps unsurprisingly, with
arrays again. In order to sum each minute of each shift independently
I found map-into to work a treat. I had to do a bit of
head-scratching before I found that by combining apply with
map-into (to designate where results go), I could repeatedly invoke
addition along the "columns" of the table (here a list of arrays):
| 0 | 1 | 1 | 0 | 0 | |
| 1 | 1 | 0 | 0 | 0 | |
| + | 0 | 1 | 0 | 0 | 1 |
| ━━━━━━━━━━ | |||||
| 1 | 3 | 1 | 0 | 1 | |
With the data laid out in an easy to use manner the puzzle answers ended up being pretty easy, if a little long winded. Both are basically a loop over the hash table with different reductions for the two parts:
(defun most-asleep (table)
(caar (sort (loop for k being the hash-keys in table
using (hash-value v)
collect (list k (reduce #'+ (sum-of-shifts v))))
#'> :key #'second)))
(let* ((guard-id (most-asleep table))
(sleepiest-shift (sum-of-shifts (gethash guard-id table)))
(maximum-sleep (reduce #'max sleepiest-shift))
(sleepiest-moment (position maximum-sleep sleepiest-shift)))
(* guard-id sleepiest-moment))
(first (sort (loop for k being the hash-keys in table
using (hash-value v)
collect (let* ((shift-sums (sum-of-shifts v))
(local-max (reduce #'max shift-sums))
(minute (position local-max shift-sums)))
(list k minute local-max)))
#'> :key #'third))
At this rate I should be finished with Advent of Code 2018 in … three years? I don't know though, seems a bit optimistic. I did manage to avoid doing anything blindingly stupid with regard to performance like on day one so I guess that is the real progress.