[nolan@nprescott.com] $  cat weblog archive feed

Christmas in July

2019-07-21

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.

Day Three

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.

Setup

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*))

Day Four

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:

00000000

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:

01111111

It is only with an entry for waking, example "wakes at 5", that the values are zeroed out (again):

00111000
(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):

01100
11000
01001
13101

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))

Thoughts

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.