As usual this time of a year I'm attending Advent of Code. Since I'm learning CL this time I will try to solve all tasks in CL. In this post I will document my findings and failures and you can always check code here.

Day 1 - Chronal Calibration

First part of day one essentially asks us to sum list of integers. If we know how to parse input (you will see in a moment that I failed to do that correctly) it's just a matter of applying + to that list:

(defun solve-day1-part1 (input)
  (apply #'+ input))

So that's first part solved. In the second part we need to find first frequency that is repeated. To solve that I maintain current frequency and set of seen frequencies:

(defun solve-day1-part2 (input)
  (let ((seen (make-hash-table))
    (current 0))
    (setf (gethash current seen) t)
    (loop do
     (loop for e in input do
          (setf current (+ current e))
          (if (gethash current seen)
          (return-from solve-day1-part2 current))
          (setf (gethash current seen) t)))))

It seem correct but result was incorrect. What did I wrong? I incorrectly parsed input - my input reading function returned frequency changes in inverted order:

(defun read-lines (path)
  (let ((ret nil))
    (with-open-file (stream path)
      (do ((line (read-line stream nil)
                 (read-line stream nil)))
          ((null line))
        (setf ret (cons line ret))))

(defun read-day1-input (path)
  (mapcar #'parse-integer (read-lines path)))

The problem is in read-lines and solution is as simple as adding reverse:

(defun read-lines (path)
  (let ((ret nil))
    (with-open-file (stream path)
      (do ((line (read-line stream nil)
                 (read-line stream nil)))
          ((null line))
        (setf ret (cons line ret))))
    (reverse ret)))

This didn't broke part 1 since addition is commutative. Fixing that gave correct solution for part 2.

One interesting thing is that initially I tried to use cl-containers:set-container. It works, but is very slow. With hash-table from frequency to t solution runs under 0.1s:

AOC18> (time (solve-day1-part2 *input*))
Evaluation took:                                                                                                                                 
  0.018 seconds of real time                                                                                                                     
  0.018372 seconds of total run time (0.018372 user, 0.000000 system)                                                                            
  100.00% CPU                                                                                                                                    
  62,442,578 processor cycles                                                                                                                    
  20,937,616 bytes consed                                                                                                                        

Full solution for day 1

Part 1 time: 0.000 seconds of real time

Part 2 time: 0.016 seconds of real time


As a bonus here are my day 1 solutions in awk:

awk '{sum+=int($1)} END {print sum}' day1.input # part1
awk '{c+=int($1); if (c in seen) { print c; exit 0} else seen[c]=1}' <(while cat day1.input; do :; done) # part2

Day 2 - Inventory Management System

In the first part we basically need to find out how many words contain same letter 2 or 3 times. First we will map word to hash-table from letters to the number of times they appear in a word:

(defun letter-frequencies (word)
  (let ((f (make-hash-table)))
    (loop for l across word do
     (incf (gethash l f 0)))

Now that we have a way to calculate letter frequencies we need a way to detect hash tables with values of 2 or 3:

(defun has-duplicate (hash &optional (count 2))
  (loop for v being the hash-values of hash do
       (if (= count v) (return t))))

Having those building blocks we can make final solution for part 1:

(defun solve-day2-part1 (words)
     for w in words
     for f = (letter-frequencies w)
     counting (has-duplicate f) into two
     counting (has-duplicate f 3) into three
     finally (return (* two three))))

In the second part we need to find pair of words that differ only in one place and find common substring of those words. There might be smarter ways to do this, but my solution is brute force one with O(n^2) complexity - due to size of input it is still fast enough.

First we need a way to check if two words differ only in one place - we iterate over letters and count how many differ:

(defun correct-words (w1 w2)
     for c1 across w1
     for c2 across w2
     counting (not (eql c1 c2)) into diff
     finally (return (= 1 diff))))

Next we need a way to find substring of letters that are the same for two words:

(defun common-letters (w1 w2)
      for c1 across w1
      for c2 across w2
      when (eql c1 c2)
      collecting c1)

Finally we check every possible pair of words and for the one which differ only in one place we calculate common substring:

(defun solve-day2-part2 (words)
  (dolist (w1 words)
    (dolist (w2 words)
      (when (and
         (string-not-equal w1 w2)
         (correct-words w1 w2)) (return-from solve-day2-part2 (common-letters w1 w2))))))

One thing that surprised me was that it seems it's not possible to iterate over same sequence twice using one loop form. That's why I used nested dolist. I've also learned that CL has some hard-coded conversions available via coerce - it seems you can't extend this mechanism to your own types.

Full solution for day 2

Part 1 time: 0.002 seconds of real time

Part 2 time: 0.004 seconds of real time

Day 3 - No Matter How You Slice It

In part 1 we are given set of rectangles and are asked to find field with maximum number of covering it rectangles. Each rectangle is called claim in that task and we can model it as a struct:

(defstruct claim
  (id 0 :type fixnum)
  (x 0 :type fixnum)
  (y 0 :type fixnum)
  (w 0 :type fixnum)
  (h 0 :type fixnum))

We are going to model surface (called fabric in the task) on which claims are made with 2d array of fixnums. Value in array will indicate number of claims made for given position:

(defun make-fabric (w h)
  (make-array (list w h) :initial-element 0 :element-type 'fixnum))

Given those building blocks we can write function to claim parts of fabric - we will increment each field under claim:

(defun claim-fabric (f c)
  (loop for y from (claim-y c) below (+ (claim-y c) (claim-h c)) do
       (loop for x from (claim-x c) below (+ (claim-x c) (claim-w c)) do
        (incf (aref f x y)))))

Finally we need to find field that was claimed the most and return number of those claims:

(defun count-overclaims (f)
  (let* ((d (array-dimensions f))
     (w (car d))
     (h (cadr d))
     (ret 0))
    (loop for y from 0 below h do
     (loop for x from 0 below w do
          (when (> (aref f x y) 1)
        (incf ret))))

This lets us write solution for part 1 in which we apply each claim and find most claimed field:

(defun solve-day3-part1 (input)
  (let ((fabric (make-fabric 2000 2000)))
    (loop for claim in input do
     (claim-fabric fabric claim))
    (values (count-overclaims fabric) fabric)))

Next in part 2 we need to find claim that does not overlap with other claims. To do that we need to observe that claim overlaps when parts of fabric under it have values greater than 1. So lets first write predicate that will detect if claim overlaps:

(defun claim-overlap-p (f c)
  (loop for y from (claim-y c) below (+ (claim-y c) (claim-h c)) do
       (loop for x from (claim-x c) below (+ (claim-x c) (claim-w c)) do
        (when (> (aref f x y) 1)
          (return-from claim-overlap-p t)))))

This together with part 1 is enough to solve part 2. We will execute part 1 solution and then check each claim against 2d array with all claims applied:

(defun solve-day3-part2 (input)
  (multiple-value-bind (ignore f) (solve-day3-part1 input)
    (loop for claim in input do
     (when (not (claim-overlap-p f claim))
       (return-from solve-day3-part2 (claim-id claim))))))

Full solution for day 3

Part 1 time: 0.091 seconds of real time

Part 2 time: 0.079 seconds of real time

Day 4 - Repose Record

In part one we need to find guard that sleeps the most. First problem is parsing input. We will represent each entry as pair of date and message:

(defstruct log-entry
  (date nil)
  (event nil))

Date will be represented as number of seconds:

(defun parse-date (in)
  (cl-ppcre:register-groups-bind ((#'parse-integer year month day hour minute)) ("(.*)-0*(.*)-0*(.*) 0?(.*):0?(.*)" in)
    (+ (* year (* 366 31 1440)) (* month (* 31 1440)) (* day 1440) (* hour 60) minute)))
(defun parse-log-entry (in)
  (cl-ppcre:register-groups-bind ((#'parse-date date) event) ("\\[(.*)\\] (.*)" in)
    (make-log-entry :date date :event event)))

I really like how we can bind regex groups to variables and even map some function before storing values to those variables.

Now we can convert input to hashmap from guard id to list of intervals representing start and end of a nap width interval length as a head:

(defun new-guard-p (log)
  (cl-ppcre:register-groups-bind ((#'parse-integer id)) ("Guard #(.*) begins shift" (log-entry-event log))

(defun collect-guards-times (input)
  (let ((gtimes (make-hash-table))
    (current-guard nil)
    (current-start nil))
    (loop for log in input do
       ((new-guard-p log) (setf current-guard (new-guard-p log)
                    current-start nil))
       ((not current-start) (setf current-start (log-entry-date log)))
       (t (let ((diff (- (log-entry-date log) current-start))
            (l (gethash current-guard gtimes '())))
        (setf (gethash current-guard gtimes) (cons (list diff current-start (log-entry-date log)) l)
              current-start nil)))))

Having this structure we can compute total nap time for each guard given value from hashmap and find longest napping guard:

(defun total-guard-time (intervals)
  (apply #'+ (mapcar #'car intervals)))
(defun find-best-guard (h)
  (let ((best-id 0)
    (best-total 0)
    (best-intervals 0))
    (loop for id being the hash-keys of h using (hash-value interval) do
     (when (> (total-guard-time interval) best-total)
       (setf best-total (total-guard-time interval)
         best-id id
         best-intervals interval)))
    (list best-id (mapcar #'cdr best-intervals))))

Finally we need to find minute at which that guard most often slept:

(defun sleep-minutes (intervals)
    (let ((table (make-array 60 :initial-element 0 :element-type 'fixnum)))
      (loop for interval in intervals do
       (loop for i from (nth 0 interval) below (nth 1 interval) do
        (incf (aref table (mod i 60)))))

(defun most-asleep-minute-from-table (table)
    (let ((best-min 0)
      (loop for i from 0 below 60 do
       (when (> (aref table i) (aref table best-min))
         (setf best-min i
           best-min-val (aref table i))))

(defun most-asleep-minute (intervals)
  (most-asleep-minute-from-table (sleep-minutes intervals)))

This lets us find answer:

(defun solve-day4-part1 (input)
  (let* ((times (collect-guards-times input))
     (best (find-best-guard times))
     (best-intervals (nth 1 best))
     (best-min (most-asleep-minute best-intervals)))
    (* (car best) best-min)))

In part 2 we need to find guard which is most frequently asleep on the same minute. We have all the needed building blocks:

(defun solve-day4-part2 (input)
  (let ((best-min 0)
    (best-id 0)
    (best-val 0))
    (loop for id being the hash-key of (collect-guards-times input) using (hash-value int) do
     (let* ((intervals (mapcar #'cdr int))
        (table (sleep-minutes intervals))
        (min (most-asleep-minute-from-table table))
        (val (aref table min)))
       (when (> val best-val)
         (setf best-min min
           best-id id
           best-val val))))
    (* best-min best-id)))

Full solution for day 4

Part 1 time: 0.004 seconds of real time

Part 2 time: 0.010 seconds of real time

Day 5 - Alchemical Reduction

I really like this day even if my solution is not that fast. In first part we need to find string which is a result of applying mutation rules until it can't be mutated further - this is essentially the problem of finding fix point. The mutation rules are simple - if two neighbouring characters have different case but otherwise are the same they should be removed.

We can express one mutation this way:

(defun unit-react-p (a b)
  (and (not (eql a b))
       (eql (char-upcase a) (char-upcase b))))

(defun polymer-react-once (in)
  (loop for i from 0 below (- (length in) 1) do
       (when (unit-react-p (aref in i) (aref in (+ 1 i)))
     (return-from polymer-react-once (cl-strings:replace-all in (format nil "~a~a" (aref in i) (aref in (+ 1 i))) ""))))

Now we need to find fix point. This meant that we have to find such input x such that (= x (polymer-react-once x)). So lets write function that will be able to find such fix point for given function and starting point:

(defun find-fix-point (f start &optional (eq #'equal))
  (let ((result (funcall f start)))
    (if (funcall eq start result)
    (find-fix-point f result eq))))

So the solution is to find fix point and return its length:

(defun solve-day5-part1 (in)
  (let ((poly (find-fix-point #'polymer-react-once in)))
    (values (length poly) poly)))

In part 2 we need to find shortest fix point given starting input with one kind of letter removed. We can work on result of solution for part 1 since pairs of letters removed there would be also removed after removing one kind of letter:

(defun remove-unit (p u)
  (remove (char-upcase u) (remove u p)))

(defun solve-day5-part2 (p)
  (let ((preprocessed (nth-value 1 (solve-day5-part1 p))))
    (apply #'min (lparallel:pmapcar (lambda (u) (solve-day5-part1 (remove-unit preprocessed u))) *alphabet*))))

Full solution for day 5

Part 1 time: 0.359 seconds of real time

Part 2 time: 0.865 seconds of real time

Day 6 - Chronal Coordinates

During this day we will be working with 2d regions. We will parse input and convert it to map from region name to its starting point:

(defun read-day6-input (path &optional (offset 0))
  (mapcar #'(lambda (l) (mapcar #'(lambda (p) (+ p offset))
                (mapcar #'parse-integer (cl-ppcre:split ", " l ))))
      (read-lines path)))

(defstruct cord
  (x 0 :type fixnum)
  (y 0 :type fixnum))

(defun give-names (points)
  (let ((mapping (make-hash-table)))
    (loop for x from 0 below (length points) do
     (setf (gethash x mapping nil) (nth x points)))

(defun read-input-as-named-cords (path)
  (give-names (loop for p in (read-day6-input path) collecting (make-cord :x (car p) :y (cadr p)))))

In first part we need to find size of largest finite area. But before we can do that we need to get rid of infinite regions. In case of this task, an infinite region is one which is closest to one of the points on bounding box encompassing all starting points. So lets first find points on the border of our bounding box:

(defun border-cords (named)
  (let* ((x-cords (loop for c being the hash-value of named collecting (cord-x c)))
     (y-cords (loop for c being the hash-value of named collecting (cord-y c)))
     (min-x (1- (apply #'min x-cords)))
     (min-y (1- (apply #'min y-cords)))
     (max-x (1+ (apply #'max x-cords)))
     (max-y (1+ (apply #'max y-cords)))
     (cords nil))
    (loop for x from min-x to max-x do
     (loop for y from min-y to max-y do
          (when (or (= x min-x) (= x max-x) (= y min-y) (= y max-y))
        (push (make-cord :x x :y y) cords))))

We will be using Manhattan distance to measure distance between points:

(defun cord-m-dist (c1 c2)
  (+ (abs (- (cord-x c1) (cord-x c2)))
     (abs (- (cord-y c1) (cord-y c2)))))

We can now find closest region for given coordinate:

(defun closest-cord-name (named c)
  (let ((best-name nil)
        (best-dist most-positive-fixnum))
    (loop for name being the hash-key of named using (hash-value cord) do
         (let ((dist (cord-m-dist cord c)))
             ((< dist best-dist)
              (setf best-name name
                    best-dist dist))
             ((= dist best-dist)
              (setf best-name nil)))))

(defun closest-to-p (named c expected)
  (equal expected (closest-cord-name named c)))

Having this we can find all infinite regions:

(defun find-infinite-cords (named)
   (remove nil
       (mapcar #'(lambda (x) (closest-cord-name named x)) (border-cords named)))))

What is left is function to calculate size of finite region. This can be done by either dfs or bfs:

(defun move-coord (pos dir)
  (make-cord :x (+ (cord-x pos) (cord-x dir))
             :y (+ (cord-y pos) (cord-y dir))))

(defparameter *dirs* (mapcar #'(lambda (p) (make-cord :x (car p) :y (cadr p)))
              '((0 1) (0 -1) (1 0) (-1 0) (1 1) (1 -1) (-1 -1) (-1 1))))

(defun neighbours (pos)
  (mapcar #'(lambda (p) (move-coord pos p)) *dirs*))

(defun region-starting-from (start pred)
  (assert (funcall pred start))
  (let ((to-visit (list start))
        (seen (make-hash-table :test #'equalp))
        (region 0))
    (loop while (not (empty-p to-visit)) do
         (let* ((next (pop to-visit))
                (candidates (neighbours next)))
           (incf region)
           (setf (gethash next seen) t)
           (loop for cand in candidates do
                (when (and (funcall pred cand) (null (gethash cand seen)))
                  (setf (gethash cand seen) t)
                  (push cand to-visit)))))

And now we have a solution:

(defun solve-day6-part1 (named)
  (let* ((infinite (find-infinite-cords named))
         (finite (set-difference (loop for n being the hash-key of named collecting n) infinite)))
    (apply #'max
       (mapcar #'(lambda (c) (region-starting-from (gethash c named)
                                                   #'(lambda (cand) (closest-to-p named cand c))))

In part 2 we need to find size of a new region which contains points close enough to all starting points. Since we wrote our finding region function generically we can just change the predicate and be done with it:

(defun is-safe-cord-p (named cord &optional (max 10000))
  (< (loop for p being the hash-value of named summing (cord-m-dist cord p)) max))

(defun solve-day6-part2 (named)
  (region-starting-from (middle-cord named) #'(lambda (cand) (is-safe-cord-p named cand))))

Full solution for day 6

Part 1 time: 0.275 seconds of real time

Part 2 time: 0.236 seconds of real time

Day 7 - The Sum of Its Parts

This day is a directed graph problem. We are given list of edges describing that one node is requirement of another node. The task is to find order in which nodes will be completed, assuming that node becomes completed right after all of its dependencies are completed (and nodes that become completed at the same time are saved in lexicographic order).

We will use hash table from node to list of nodes to represent our input:

(defstruct edge
  (from nil)
  (to nil))

(defun parse-edge (line)
  (cl-ppcre:register-groups-bind (from to)
      ("Step (.*) must be finished before step (.*) can begin." line)
    (make-edge :from from :to to)))

(defun parse-day7-input (path)
  (let ((map (make-hash-table :test #'equal))
    (starts nil)
    (edges (mapcar #'parse-edge (read-lines path))))
    (loop for edge in edges do
     (push (edge-to edge) (gethash (edge-from edge) map nil)))
    (setf starts (set-difference
          (remove-duplicates (mapcar #'edge-from edges) :test #'equal)
          (remove-duplicates (mapcar #'edge-to edges) :test #'equal)
          :test #'equal))
    (values map (sort starts #'string-lessp))))

Actually it will be useful to have map from node to its requirement:

(defun invert-rels (g)
  (let ((map (make-hash-table :test #'equal)))
    (loop for from being the hash-key of g using (hash-value tos) do
     (loop for to in tos do
          (push from (gethash to map))))

The core issue will be to get next ready node given currently waiting list. Given list of currently waiting nodes we can solve it this way:

(defun next-ready (cand reqs done)
   #'(lambda (c) (empty-p (set-difference (gethash c reqs) done :test #'equal)))

Finally we can solve part 1. We will maintain list of nodes waiting for completion (initially filled with nodes without any requirements). Each time we remove one element from that list that has no unfinished requirement and add nodes for each it was a requirement to waiting list:

(defun solve-day7-part1 (g starts)
  (let ((visited nil)
    (reqs (invert-rels g)))
    (loop while (not (empty-p starts)) do
     (let* ((next (next-ready starts reqs visited))
        (cand (sort (gethash next g) #'string-lessp)))
       (setf starts (remove next starts :test #'equal))
       (push next visited)
       (when cand
         (setf starts (sort (append starts cand) #'string-lessp)))))
    (apply #'concatenate 'string (reverse  visited))))

In the second part we get to simulate multithreaded system. Each task has a cost associated with it and in represents how much time it takes to complete said task. Additionally we are to simulate a pool of threads executing those tasks. Eventually we need (like in part 1) to find out in what order will those task finish.

We start with calculation of tasks cost:

(defun time-needed (task)
  (apply #'+ (mapcar #'(lambda (c) (- c 4))
             (mapcar #'char-code (coerce task 'list)))))

(defun timed-task (current-time task)
  (cons (+ current-time (time-needed task)) task))

Next we need a way to get list of tasks that can fill up free slots in thread pool:

(defun next-ready-many (cand reqs done max)
  (let ((ret nil))
    (loop for c in cand do
     (let ((req (gethash c reqs)))
       (when (null (set-difference req done :test #'equal))
         (push c ret))))
    (let* ((sorted (sort ret #'string-lessp))
       (end (min (length sorted) max)))
      (subseq sorted 0 end))))

And a way to put those tasks into the pool:

(defun insert-timed-tasks (tasks pool current-time)
  (let ((timed (mapcar #'(lambda (x) (timed-task current-time x)) tasks)))
    (loop for i from 0 below (length pool) do
     (when (not (aref pool i))
       (setf (aref pool i) (pop timed))))))

Our pool should be viewed as a priority queue with task ordered by age, so lets write a function that will find out earliest time our pool would produce completed task:

(defun find-next-time (pool)
  (let* ((best most-positive-fixnum))
    (loop for timed-task across pool do
     (when timed-task
       (setf best (min best (car timed-task)))))
    (if (= most-positive-fixnum best) 0 best)))

If we know next maturation task time from pool we can remove all tasks that would mature at that time:

(defun remove-matured (pool time)
  (let ((matured '()))
    (loop for i from 0 below (length pool) do
     (let ((element (elt pool i)))
       (when (and element (= time (car element)))
         (push (cdr element) matured)
         (setf (elt pool i) nil))))

Now we are ready to solve part 2. We will make a loop in which we will extract already matured tasks and replace them with next set of tasks (observing dependency graph from input) until all tasks are done:

(defun empty-pool-p (pool)
  (= (loop for task across pool when task counting t) 0))

(defun solve-day7-part2 (g starts &optional (workers 2))
  (let* ((pool (make-array workers :initial-element nil))
     (possible starts)
     (current-time 0)
     (visited nil)
     (reqs (invert-rels g)))
    (loop while (or (not (empty-p possible)) (not (empty-pool-p pool))) do
     (let* ((next-time (find-next-time pool))
        (matured (remove-matured pool next-time)))
       (setf visited (append visited matured)
         current-time next-time)
       (loop for m in matured do
        (setf possible
              (sort (remove-duplicates
                 (append possible (gethash m g)) :test #'equal)
       (let* ((free-slots (count nil pool))
          (cands (next-ready-many possible reqs visited free-slots)))
         (insert-timed-tasks cands pool current-time)
         (loop for c in cands do
          (setf possible (remove c possible :test #'equal))))))

Full solution for day 8

Part 1 time: 0.002 seconds of real time

Part 2 time: 0.002 seconds of real time

Day 8 - Memory Maneuver

In the first part we are given list of integers that encode a tree. This is somewhat like parsing s-exps but each exp is preceded with information how many subexpressions it will contain. Let's first parse that tree. Our parsing function will take number of nodes to be parsed and input and return list of parsed nodes and rest of input that wasn't consumed by parsing:

(defstruct node
  (children nil)
  (meta nil))

(defun read-header (in) (list (car in) (cadr in)))

(defun parse-nodes (in nodes)
  (let ((current in)
    (children nil))
    (loop for x from 0 below nodes do
     (let* ((h (read-header current))
        (n (car h))
        (m (cadr h))
        (rest (cddr current))
        (subchildren nil))
       (when (> n 0)
         (multiple-value-bind (c r) (parse-nodes rest n)
           (setf subchildren c rest r)))
       (push (make-node :children subchildren :meta (subseq rest 0 m)) children)
       (setf current (subseq rest m))))
    (values (reverse children) current)))

We need to evaluate this tree. A value of a node in that tree is sum of its metadata added to sum of values of it subnodes:

(defun sum-metadata (root)
  (+ (apply #'+ (node-meta root))
     (loop for n in (node-children root) summing (sum-metadata n))))

(defun solve-day8-part1 (input)
  (sum-metadata (car (parse-nodes input 1))))

Part 2 also asks us to evaluate this tree, but this time metadata elements are indexes into subnodes list of each node:

(defun sum-node (root)
    ((null root) 0)
    ((empty-p (node-children root)) (apply #'+ (node-meta root)))
    (t (sum-nodes (mapcar #'1- (node-meta root)) (node-children root)))))

(defun sum-nodes (indexes nodes)
  (loop for i in indexes summing (sum-node (nth i nodes))))

(defun solve-day8-part2 (input)
  (sum-node (car (parse-nodes input 1))))

Full solution for day 8

Part 1 time: 0.085 seconds of real time

Part 2 time: 0.081 seconds of real time