Advent Of Code 2018
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))))
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
312
Part 1 time: 0.000 seconds of real time
Part 2 time: 0.016 seconds of real time Awk?
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)))
f))
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)
(loop
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)
(loop
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)
(coerce
(loop
for c1 across w1
for c2 across w2
when (eql c1 c2)
collecting c1)
'string))
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.
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))))
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))))))
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))
id))
(defun collect-guards-times (input)
(let ((gtimes (make-hash-table))
(current-guard nil)
(current-start nil))
(loop for log in input do
(cond
((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)))))
gtimes))
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)))))
table))
(defun most-asleep-minute-from-table (table)
(let ((best-min 0)
(best-min-val))
(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))))
best-min))
(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)))
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))) ""))))
in)
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)
start
(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*))))
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)))
mapping))
(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))))
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)))
(cond
((< dist best-dist)
(setf best-name name
best-dist dist))
((= dist best-dist)
(setf best-name nil)))))
best-name))
(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-duplicates
(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)))))
region))
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))))
finite))))
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))))
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))))
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)
(find-if
#'(lambda (c) (empty-p (set-difference (gethash c reqs) done :test #'equal)))
cand))
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))))
matured))
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)
#'string-lessp)))
(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))))))
current-time))
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)
(cond
((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))))
Part 1 time: 0.085 seconds of real time
Part 2 time: 0.081 seconds of real time
Day 9 - Marble Mania
This was a fun day, mostly thanks to my stubbornness to keep using solution that could barely solve part 1. Instead of improving it I should have immediately rewrite it. So lets first see that final solution.
In both parts of day 9 we are asked to simulate a game. Each turn marble is added to the circle but each 23rd turn marble 7 positions before current one is removed (as usual see task description for details).
Best way to approach this is to use doubly linked list since we have to move both backward and forward and erase elements from visited positions. To avoid doing bounds checking we will use circular buffer based on doubly linked list. As far as I know there is no such data structure in CL standard. The standard lists are singly linked lists so it will be very costly to move back - you would need to essentially move from beginning. So let's write our doubly linked list:
(defstruct dlnode
(prev nil)
(next nil)
(value 0))
(defun add-dlnode (after value)
(let ((node (make-dlnode :prev after :value value :next (dlnode-next after)))
(next (dlnode-next after)))
(setf (dlnode-next after) node)
(setf (dlnode-prev next) node)
node))
(defun remove-dlnode (node)
(let ((prev (dlnode-prev node))
(next (dlnode-next node)))
(setf (dlnode-next prev) next
(dlnode-prev next) prev)
prev))
(defun go-back-dlnode (start steps)
(let ((current start))
(loop for i fixnum from 0 below steps do
(setf current (dlnode-prev current)))
current))
That is the list, lets now make it a loop by joining next field of last dlnode with first dlnode (and prev of first with last):
(defun dlnode-from-list (init)
(let* ((root (make-dlnode :value (car init)))
(current root))
(loop for e in (cdr init) do
(let ((next (make-dlnode :prev current :value e)))
(setf (dlnode-next current) next)
(setf current next)))
(setf (dlnode-next current) root)
(setf (dlnode-prev root) current)
root))
Having those, we can easily encode rules of the game:
(defun day9 (start marbles players)
(let ((player 1)
(circle (dlnode-from-list start))
(scores (make-hash-table)))
(loop for marble fixnum from 1 to marbles do
(if (= 0 (mod marble 23))
(progn
(setf circle (go-back-dlnode circle 8))
(let ((points (gethash player scores 0)))
(setf (gethash player scores) (+ points marble (dlnode-value circle))))
(setf circle (dlnode-next (dlnode-next (remove-dlnode circle)))))
(setf circle (dlnode-next (add-dlnode circle marble))))
(setf player (1+ (mod player players))))
scores))
(defun best-marble-score (h)
(loop for score being the hash-value of h maximizing score))
Part 1 time: 0.004 seconds of real time
Part 2 time: 0.839 seconds of real time
Quadratic solution
Instead of doing that from the start, I've implemented solution based on simple list. I was hoping that it would be fast enough and was worried that I wouldn't know how to write doubly linked list in CL. Here is the first version:
(defun play (list steps players)
(declare (optimize (speed 3) (safety 1))
(type fixnum players))
(setf players (1+ players))
(let ((len (length list))
(current 0)
(player 0)
(scores (make-hash-table)))
(loop for step fixnum from 0 below steps do
(if (and (= 0 (mod (1+ step) 23)) (> step 0))
(let* ((to-remove (mod (+ len (- current 7)) len))
(removed (nth to-remove list))
(pscore (gethash player scores 0)))
(declare (type fixnum len pscore removed))
(setf (gethash player scores 0) (+ pscore (1+ step) removed))
(setf current to-remove
list (delete removed list :count 1 :start to-remove)
len (1- len)) )
(let* ((one (mod (1+ current) len))
(left (subseq list 0 (1+ one)))
(right (subseq list (1+ one)))
(marble (1+ step)))
(declare (type fixnum len one))
(setf list (append left (cons marble right))
current (mod (1+ one) (1+ len))
len (1+ len))))
(setf player (mod (1+ player) players))
(when (= player 0) (incf player)))
scores))
It works but is very slow - it took 23.406 seconds of real time to solve part 1 and was clearly not capable of solving problem 100 larger. So i tried to improve it by avoiding coping lists as much as I could:
(defun play2 (list steps players)
(declare (optimize (speed 3) (safety 1))
(type fixnum players)
(type list list))
(setf players (1+ players))
(let ((len (length list))
(current 0)
(player 0)
(scores (make-hash-table)))
(declare (type fixnum len current player))
(loop for step fixnum from 0 below steps do
(if (and (= 0 (mod (1+ step) 23)) (> step 0))
(let* ((to-remove (mod (+ len (- current 7)) len))
(removed (nth to-remove list))
(pscore (gethash player scores 0)) )
(declare (type fixnum len pscore removed))
(setf (gethash player scores 0) (+ pscore (1+ step) removed))
(setf current to-remove
list (delete removed list :count 1 :start to-remove)
len (1- len)) )
(let* ((one (mod (1+ current) len))
(two (1+ one))
(next-len (1+ len))
(marble (1+ step)))
(declare (type fixnum len one two marble))
(setf list (destructive-insert list two marble)
current (mod two next-len)
len next-len)))
(setf player (mod (1+ player) players))
(when (= player 0) (incf player)))
scores))
(declaim (inline destructive-insert))
(defun destructive-insert (list index element)
(declare (optimize (speed 3) (safety 1))
(type fixnum index))
(decf index)
(when (= -1 index)
(return-from destructive-insert (cons element list)))
(let ((cell list))
(loop for p fixnum from 0 below index do
(setf cell (cdr cell)))
(setf (cdr cell) (cons element (cdr cell))))
list)
That was 10 times faster - 2.739 seconds of real time but still to slow. So I tried to avoid coping even more by tracking current cons cell and mutating it in place wherever I could:
(defun play3 (list steps players)
(declare (optimize (speed 3) (safety 1))
(type fixnum players)
(type list list))
(setf players (1+ players))
(let ((len (length list))
(current 0)
(player 0)
(scores (make-hash-table))
(current-cons list))
(declare (type fixnum len current player))
(loop for step fixnum from 0 below steps do
(if (and (= 0 (mod (1+ step) 23)) (> step 0))
(let* ((to-remove (mod (+ len (- current 7)) len))
(removed (nth to-remove list))
(pscore (gethash player scores 0)) )
(declare (type fixnum len pscore removed))
(setf (gethash player scores 0) (+ pscore (1+ step) removed))
(setf current-cons (last list (1+ (- len to-remove ))))
(setf current to-remove
list (delete removed list :count 1 :start to-remove)
len (1- len))
(setf current-cons (last list (1- (- len to-remove))))
(when (null current-cons)
(setf current-cons list)))
(let* ((one (mod (1+ current) len))
(two (1+ one))
(next-len (1+ len))
(marble (1+ step)))
(declare (type fixnum len one two marble))
(setf (cdr current-cons) (cons marble (cdr current-cons)))
(setf current-cons (if (< one current)
(last list (- len one 1))
(cdr (cdr current-cons))))
(when (null current-cons) (setf current-cons list))
(setf current (mod two next-len)
len next-len)))
(setf player (mod (1+ player) players))
(when (= player 0) (incf player)))
scores))
That was once again order of magnitude times faster for part 1 input - 0.721 seconds of real time but it was still quadratic. So full solution would take at least 10000 times longer - 7000s. By that time I knew I need to rewrite with doubly linked list, but just out of curiosity I left it running in the background. It took 7596.982 seconds of real time so almost exactly as predicted.