Advent of Common Lisp, Day 5-9
We continue our Common Lisp adventure!
Day 5
Part 1
It feels natural to first figure out how to find an reduce a pair of chars. A solution based on arrays might be easier to implement without having to loop through the input line multiple times, since we risk the situation that removing one pair of chars may make the new neighbors be reducable, like so:
abcdDCBA
abcCBA
abBA
aA
With the array based solution we can just decrement the current index after reducing a char pair. This makes for plenty of problems: we first want to destructively remove a part of a string given two indices, and we also want a loop in which we can alter the iterating value; neither of which seems straight forward to do in CL. My first, non-working attempt looked like this:
(defun reducable (a b)
(and (eq (char-downcase a) (char-downcase b))
(not (eq a b))))
(defun reduce-chars (chars)
(let ((end (- (length chars) 1)))
(loop for i from 0 below (- (length chars) 1)
when (or (> 0 i) (< end i) return ""
when (reducable (char chars i) (char chars (+ i 1)))
do (progn
(setf chars (remove-if #'(lambda (_x) t) chars :start i :end (+ i 2)))
(setf i (- i 2)))
finally (return chars)))))
Having #'(lambda (_x) t) as the removal predicate is... not great. This was
the first attempt in which I figured "OK, this might just work". However, it
turns out that the termination check is not ran on each iteration in loop: it
seems to be the case that (- (length chars) 1) is only evaluated once before
the first iteration of the loop, as opposed to how for (int i = 0; i < length(foo); i++) works in eg. C. This makes for out-of-bounds indexing in the
body.
As a note, there is a destructive version of remove called delete, which
would seemingly allow me to skip the (setf stuff. This did not work, since
delete for some reason would not update the length of the string, and I would
end up with repeating the last two chars. That is, this happend:
abcCBA
abBABA
aABABA
BABABA
I eventually figured out a solution, and ended up with this:
(defun reduce-chars (chars)
(loop for i from 0
for end = (- (length chars) 2)
when (or (> 0 i) (< end i)) return chars
when (reducable (char chars i) (char chars (+ i 1)))
do (progn
(setf chars (remove-if #'(lambda (_x) t) chars :start i :end (+ i 2)))
(setf i (- i 2)))
finally (return chars)))
We run it on the input and ... we get 49998. Strange. After printing out i in
the progn we see that the first index matches, and so i gets subtracted to
-2, causing the loop to terminate on the next iteration. Ok, we fix this by
adding a (max 0 ..) after subtracting 2. We run again, aaand .... wrong
answer. The resulting string is slightly above 10000 chars, so looking at the
output manually will probably take too much time. We try to run it twice on
the same input, which should not change anything, and yet we get
* (length (reduce-chars (reduce-chars *input-5*)))
10768
* (length (reduce-chars (reduce-chars *input-5*)))
10766
A little thinking reveals the bug: since i is incremented after the loop body
we should not max it to 0, but to -1. This fixes the bug, and solves
part 1.
Part 2
The second part asks us to remove all occurences of one letter such that the reduced string is as short as possible. The simplest way to do this is just to try out all possible letter choices:
(defun day-5/2 (input)
(let ((all-chars (remove-duplicates input :key #'char-downcase )))
(loop for c across all-chars
for inp = (remove-if #'(lambda (ch) (or (eq c ch) (eq (char-upcase c) ch))) input)
minimizing (length (reduce-chars inp)) into l
finally (return l))))
There's definitely room for optimization here:
* (time (day-5/2 *input-5*))
Evaluation took:
104.868 seconds of real time
104.697084 seconds of total run time (104.137960 user, 0.559124 system)
[ Run times consist of 2.633 seconds GC time, and 102.065 seconds non-GC time. ]
99.84% CPU
304,535,002,262 processor cycles
57,568,946,208 bytes consed
6538
By using a list instead of an array, and swinging cdr to cdddr when we want
to remove a pair of chars we significantly cut down on running time (this is
part 1 again):
* (time (length (reduce-chars *input-5*)))
Evaluation took:
4.307 seconds of real time
4.305834 seconds of total run time (4.289201 user, 0.016633 system)
[ Run times consist of 0.112 seconds GC time, and 4.194 seconds non-GC time. ]
99.98% CPU
12,506,949,589 processor cycles
2,383,071,584 bytes consed
10766
* (time (day-5/1-list *input-5*))
Evaluation took:
0.106 seconds of real time
0.106221 seconds of total run time (0.106221 user, 0.000000 system)
100.00% CPU
309,274,661 processor cycles
819,200 bytes consed
10766
If we now use this solution for the second part, we get the following running time:
* (time (day-5/2-list *input-5*))
Evaluation took:
2.496 seconds of real time
2.494232 seconds of total run time (2.494232 user, 0.000000 system)
99.92% CPU
7,248,068,477 processor cycles
28,657,200 bytes consed
6538
Not bad!
Day 6
There might be fancy tricks to this task, but we'll try out the simplest approach first: we make the grid (and hope that the input isn't too big!), loop over each cell, find the closest point, and stores that in the cell. Afterwards we go through the borders and find all of the areas that touch it, because these areas will have inifinite area. At last we just sum up the number of cells for each area, and choose the maximum, excluding the infinite ones.
This time I would like to try out propper top-down programming. This will be our final function:
(defun day-6/1 (input)
(let* ((points (parse-points input))
(grid (make-grid points)))
(mark-closest grid points)
(let* ((infinites (get-border-areas grid))
(area-sizes (count-area-sizes grid))
(valids (exclude-infinites area-sizes infinites))
(second (car (sort valids #'second)))))))
Now it's just a matter of filling in the blanks.
First with input parsing. The lines are in the format "split-sequence. I could,
however, not get it to install, so instead I went with the simpler solution:
(defstruct point x y id)
(defparameter *point-count* 0)
(defun pt (x y) (make-point :x x :y y :id (incf *point-count*)))
(defun parse-points (lines)
(loop for line in lines
for i = (search ", " line)
collect (make-point :x (parse-integer (subseq line 0 i))
:y (parse-integer (subseq line (+ 2))))))
With a flash of clairvoyance we realize that we could use an id for all
areas, in addition to their coordinates.
Creating the grid was slightly worse, since make-array didn't want to take my
dynamic sizes as dimension arguments.
Quick sidenote, after entering a function name wrong, Slime prompted me to
enter another expression as the function. I tried this, and Emacs froze.
Having spent 6 years in Vim, I can not recall any specific time it has crashed
(I know it has, but I can't remember it). After restarting I had to install
Slime again (I am yet to find out how to properly install stuff with Emacs),
and after installing it again, I run into problems with No Lisp subprocess; see variable 'inferior-lisp-buffer', despite Slime and Swank and whatever
running just fine. Restarting Emacs, yet again, and installing Slime again,
seems to fix it.
After not figuring out how to make arrays without a fixed size, since I
couldn't make a 2d array of a dynamic size, I realized I could make it work
using make-array and loop:
(defun make-grid (points)
(let* ((max-x (+ 1 (reduce #'max (mapcar #'point-x points))))
(max-y (+ 1 (reduce #'max (mapcar #'point-y points))))
(grid (make-array max-y)))
(loop for y from 0 below max-y do
(setf (aref grid y) (make-array max-x)))
grid))
We're adding 1 to max-{x,y} so that we can index with all coordinates in
the input list.
Calculating the closest point for each cell in the grid is done with nested
loops. The logic for finding the best got somewhat messy, but it should work.
(defun manhattan (a b)
(+ (abs (- (point-x a) (point-x b)))
(abs (- (point-y a) (point-y b)))))
(defun mark-closest (grid points)
(let ((mx (length (aref grid 0)))
(my (length grid)))
(loop for y from 0 below my do
(loop for x from 0 below mx
for c = (make-point :x x :y y)
do (let* ((dists (loop for p in points collect (list (manhattan c p) p)))
(sorted (sort dists #'< :key #'car ))
(best (car sorted))
(tie (eq (first (first sorted)) (first (second sorted)))))
(setf (aref (aref grid y) x)
(if tie 0 (point-id (second best)))))))
grid))
In order to get the areas touching the border, we just loop through the four borders, collect the numbers we see, and dedup at the end.
(defun get-border-areas (grid)
(let ((mx (length (aref grid 0)))
(my (length grid)))
(remove-duplicates (append
(loop for y from 0 below my collect (aref (aref grid y) 0))
(loop for y from 0 below my collect (aref (aref grid y) (- mx 1)))
(loop for x from 0 below mx collect (aref (aref grid 0) x))
(loop for x from 0 below mx collect (aref (aref grid (- my 1)) x))))))
For counting the sizes of the areas we could have used a hashmap, but we might
as well use the fact that all areas are numbered between 0 and the number of
areas. Then we can make an array of counts, loop over the grid, and count up.
When done we return (id, count) pairs for all areas that were non-null.
(defun count-area-sizes (grid num-areas)
(let ((arr (make-array num-areas))
(mx (length (aref grid 0)))
(my (length grid)))
(loop for y from 0 below my do
(loop for x from 0 below mx
for area = (aref (aref grid y) x)
do (incf (aref arr area))))
(loop for i from 0 below num-areas
when (< 0 (aref arr i)) collect (list i (aref arr i)))))
Removing the infinite area areas from the list of (id, area) tuples didn't
have to be its own function, but we've come so far with the top-down mindset,
so let's overuse it a little.
(defun exclude-infinities (area-sizes infinities)
(remove-if #'(lambda (l) (find (car l) infinities)) area-sizes))
This is the last function we needed to implement day-6/1. Having all the
helper functions, we just need to make some small adjustments to the function,
and we're good to go.
(defun day-6/1 (input)
(setf *point-count* 0)
(let* ((points (parse-points input))
(num-areas (1+ (length points)))
(grid (make-grid points)))
(mark-closest grid points)
(let* ((infinites (get-border-areas grid))
(area-sizes (count-area-sizes grid num-areas))
(valids (exclude-infinities area-sizes infinites))
(max-area (car (sort valids #'> :key #'second))))
(second max-area))))
Part 2
The second part in comparison require very little code. We simply do the same thing: find the size of the grid, loop over the grid, measure the sum of the distances to all points, and count the number of cells with a suficciently low distance.
(defun day-6/2 (input)
(setf *point-count* 0)
(let* ((points (parse-points input))
(max-x (+ 1 (reduce #'max (mapcar #'point-x points))))
(max-y (+ 1 (reduce #'max (mapcar #'point-y points))))
(count 0))
(loop for y from 0 below max-y do
(loop for x from 0 below max-x
for point = (pt x y)
when (< (reduce #'+ (mapcar #'(lambda (p) (manhattan p point)) points)) 10000)
do (incf count)))
count))
and that's it!
Day 7
Part 1
We start out by parsin each input line to a pair, so that we can easier handle the dependency edges.
(defun line-to-pair (line)
(let ((a (subseq line 5 6))
(b (subseq line 36 37)))
(list a b)))
One approach we can take is to try to continuously find all nodes that does not depend on any other node, and select the first alphabetically. The most straight forward way of doing this is to look through the list of edges, and count the number any node is the second element of the list. Then we look throught the counts and chose the first node with a count of 0.
(defun get-next (nodes edges)
(defun zero-keys (hm)
(loop for k being the hash-keys of hm
when (eq 0 (gethash k hm)) collect k))
(let ((hm (make-hash-table :test #'equalp)))
(loop for node in nodes do (setf (gethash node hm) 0))
(let ((available (loop for e in edges
do (print (second e))
do (incf (gethash (second e) hm))
finally (return (zero-keys hm)))))
(reduce #'(lambda (a e) (if (string< a e) a e)) available))))
The outer loop is mostly keeping track of the nodes and edges we have left, and removing the elements that we no longer use after outputting a node.
(defun day-7/1 (input)
(let* ((output)
(edges (mapcar #'line-to-pair input))
(nodes (remove-duplicates (flatten edges) :test #'string=)))
(loop when (not (car nodes)) return output
do (let ((next (get-next nodes edges)))
(setf edges (delete-if #'(lambda (edge) (string= (first edge) next)) edges))
(setf nodes (delete next nodes))
(setf output (cons next output))))
(reduce #'(lambda (a b) (concatenate 'string a b)) (reverse output))))
We also used a flatten function stolen from [rosettacode].
Part 2
Todays second part seems very different from the first. We are asked to schedule variable length tasks with 5 workers.
First off, it does not matter which worker does which task. Second off, we probably want to prioritize starting with longer tasks, if possible. We still have task dependencies, which we need to remember.
One approach to solving this is to have a queue of all tasks that is currently processed. Then at each step we would find the next task, assign a worker to it, and find the time for when the task is done. If there are multiple nodes without any dependencies we would chose as many as we have workers. In addition, we probably want to chose the longest tasks first; that is, the largest lexiograhpically, as opposed to the smallest, as in part 1.
This is the task data that we work with: id is the task name, done is the
time at which the task is done, and worker is a worker id.
(defstruct task id done worker)
(defun task-cost (id)
(+ 60 (- (char-int (char id 0)) 64)))
get-next/2 is just like get-next, except that we chose the largest instead
of the smallest alphabetically, since this has the largest cost.
Now our main function looks like this:
(defun day-7/2 (input)
(let* ((edges (mapcar #'line-to-pair input))
(nodes (remove-duplicates (flatten edges) :test #'string=))
(available-workers (loop for i from 1 to 5 collect i))
(in-flight-tasks))
(loop for time from 0
when available-workers do
(let ((next (get-next/2 nodes edges)))
(when next
(setf nodes (delete next nodes))
(push (make-task :id next
:done (+ time 1 (task-cost next))
:worker (pop available-workers))
in-flight-tasks)
(setf in-flight-tasks (sort in-flight-tasks #'< :key #'task-done))))
when in-flight-tasks do
(loop while in-flight-tasks
when (< time (task-done (car in-flight-tasks))) return nil
do (let ((task (pop in-flight-tasks)))
(setf edges (delete-if #'(lambda (edge) (string= (first edge) (task-id task))) edges))
(push (task-worker task) available-workers)))
when (not nodes) return time)))
Using this we pass the test input, but on the real input our output is wrong.
A little format debugging shows us two things: 1. we should not add 1 to
the task cost when constructing new tasks, and 2. we need to remove tasks that
are done before trying to add new tasks this round. Without this a task that
takes only one cycle would spend two: the one in which it gets dispatched, and
the one in which it completes. In addition, we're not dispatching multiple
tasks at a time, which we should. The end condition was also wrong, as it terminated
as soon as the last task was dispatched, but not completed. Somehow all these errors
canceled out when ran on the test input.
(defun day-7/2 (input num-workers)
(let* ((edges (mapcar #'line-to-pair input))
(nodes (remove-duplicates (flatten edges) :test #'string=))
(available-workers (loop for i from 1 to num-workers collect i))
(in-flight-tasks))
(loop for time from 0
when in-flight-tasks do
(loop while in-flight-tasks
when (< time (task-done (car in-flight-tasks))) return nil
do (let ((task (pop in-flight-tasks)))
(setf edges (delete-if #'(lambda (edge) (string= (first edge) (task-id task))) edges))
(push (task-worker task) available-workers)))
when available-workers do
(loop for next = (get-next nodes edges)
when (not available-workers) return nil
if next do (progn
(setf nodes (delete next nodes))
(push (make-task :id next
:done (+ time (task-cost next))
:worker (pop available-workers))
in-flight-tasks)
(setf in-flight-tasks (sort in-flight-tasks #'< :key #'task-done)))
else return nil)
when (and (not nodes) (not in-flight-tasks)) return time)))
After about 90 minutes of debugging, formating, and asking around how people
did resolve ties, I ended up with this, which gives me the correct answer.
Regarding ties, I was confused since the task did not explicitly say that ties should still be resolved alphabetically, and I suspect it does matter (although I haven't come up with an example). In order to see whether this actually was the error in my code, I resolved ties randomly, and ran the function on the input 100 times; they all gave me the same answer.
I'm still not sure what was the bug, since I ended up not doing anything meaningful edits in the last hour of debugging. There might have been stale function implementations or something as well, or just that I forgot to turn back the cost function or the number of workers, between testing the function on the test input vs. the real input.
In any case, day 7 is complete.
Day 8
Today we have good news and bad news. The good news is that todays data
structure is the tree! The bad news is that the input is a single line of
space separated digits, so we'll have to make split-sequence work.
split-sequence is not in the standard library, so we cannot just use it.
It is apparently a part of the Common Lisp Utilities, although that tells me nothing;
browsing through the homepage of the utilities doesn't give me much information about
how to actually use this.
The examples given for split-sequence seem to have already loaded a package called
split-sequence. I guess that it is installable using quicklisp:
* (ql:quickload "split-sequence")
To load "split-sequence":
Load 1 ASDF system:
asdf
Install 1 Quicklisp release:
split-sequence
(rant warning)
... but nothing happens after this is ran, and I need to abort it with C-C C-C. Trying "cl-utilities" and "utilities" instead did not help out: I
got ETIMEDOUT from the former in the debugger, and the latter did apparently
not do anything. I figured that the ETIMEDOUT might be due to me having
outdated stuff in my quicklisp installation, so I ran (ql:update-dist "quicklisp"), which I found at the quicklisp website. After (I'm guessing) 30
seconds without any feedback to whether something actually happend when typing
that in the repl, I get yet another ETIMEDOUT. Maybe the quicklisp client is
outdated? (this seems very unlikely, since I installed it about eight days
ago, but at this point I have no idea what's going on) Running (ql:update-client)
gets me nowhere: yet another ETIMEDOUT. I suppose the quicklisp site could be down?
Folloing the install instructions I followed about a week ago I run
curl -O https://beta.quicklisp.org/quicklisp.lisp.asc
and... nothing happens! Great! .. or is it? Investigating further I tried to
check isitdownrightnow.com to confirm that the site was indeed down, but I
failed to connect to isitdownrightnow.com! It seemes unlikely that both of
these sites are down, so I check downforeveryoneorjustme.com, which claims
that both beta.quicklisp.org and isitdownrightnow.com` are in fact down for
just me. QuickLisp just times out, but isitdownrightnow gives me a cloudflare
page, so presumably the problem is not in my house, which means that there's
probably not much I can do.
(Update the 10th: the network is more or less back to normal, and installing
sequence-split was as simple as (ql:quickload "split-sequence"); so much
for getting annoyed :)
(rant warning end)
Luckily, cl-ppcre offers the samf functionality with (ppcre:split delim string).
(defun line-to-numbers (line)
(mapcar #'parse-integer (ppcre:split " " line)))
Then we make a function to parse the line into a tree. We first find the number
of children an number of metadata entries, then for each child we recursively
call the parse function on the list without the two numbers we've already read.
This is slightly awkward since we have to both collect the child nodes, as well
as keep track of where in the input list we are. For this we use
multiple-value-bind, and have the function return a pair node, remaining-input.
(defun parse-tree (items)
(let* ((num-children (first items))
(num-metadata (second items))
(rest (cddr items))
(children
(loop for i from 0 below num-children
collect
(multiple-value-bind (node new-rest) (parse-tree rest)
(setf rest new-rest)
node)))
(metadata (subseq rest 0 num-metadata)))
(values (list children metadata) (subseq rest num-metadata))))
Running this on the test input gives us this:
(((NIL (10 11 12)) (((NIL (99))) (2))) (1 1 2))
; formatted, and with labels:
node: (
children: (
node: (children: NIL metadata: (10 11 12))
node: (
children: (
node: (children: NIL metadata: (99))
metadata: (2)))
metadata: (1 1 2))
So the tree looks like this:
(1 1 2)
/ \
/ \
/ \
(10 11 12) (2)
|
|
(99)
Which looks right, compared to the description on the task page.
Now we just need to sum up all metadata entries. We will again go for a recursive solution:
(defun metadata-sum (tree)
(+ (reduce #'+ (second tree))
(reduce #'+ (mapcar #'metadata-sum (first tree)))))
* (metadata-sum (parse-tree (line-to-numbers *test-input-8*)))
138
Yay! This completes the first part.
Part 2
Now we're asked to sum up the values of the children if the childs index is in the nodes metadata, with a note that if a number is multiple times in the list, it should be counted multiple times. This makes it possible to make inputs so that the running time becomes exponential, but we'll try to do the naive thing still.
The function is almost a straight mapping from the description of the value scoring. If the node has children, the metadata is the indices (ops: 1 indexed) for the children we count. If not, the sum of the metadata is the value.
(defun node-value (node)
(if (first node)
(loop for data in (second node)
summing (node-value (nth (- data 1) (first node))) into sum
finally (return sum))
(reduce #'+ (second node))))
Tada! The running time is also pretty good!
* (time (day-8/2 *input-8*))
Evaluation took:
0.113 seconds of real time
0.113493 seconds of total run time (0.113443 user, 0.000050 system)
[ Run times consist of 0.025 seconds GC time, and 0.089 seconds non-GC time. ]
100.00% CPU
328,615,301 processor cycles
302,886,128 bytes consed
30063
Day 9
Today I want to try out something a little different. The marbles in the task are in a circle, so I want to try out having a circular list.
(defun make-circular (e)
(let* ((l (list e)))
(setf (cdr l) l)
l))
Trying to print this out results in looping, so this seems to work. One
downside of this is that we should be able to move in both directions around
the circle; if we want to go in the other direction we would have to first find
the length of the list, and then go n-k steps in the opposite direction.
This might take some time, but we can try to do it this way first, in case it
works out.
Next up is doing stuff with the list. Naturally we cannot just mapcar over
our circular list (we cannot even subseq it - I exhausted my heap attempting
to do so), so we need to write our own map:
(defun map-circular (f circ)
(let* ((head (first circ))
(result (list (funcall f head))))
(loop for e in (cdr circ)
when (eq e head) return (reverse result)
do (push (funcall f e) result))))
Now (map-circular #'print (make-circular 1)) prints 1 and gives me back
(1). Next we want to insert things, so we'll write a function for that.
We return t here so that the REPL doesn't try to print out the entire list
every time we add something
(defun insert-circular (e circ)
(setf (cdr circ) (cons e (cdr circ)))
t)
* (defparameter nums (make-circular 1))
NUMS
* (insert-circular 2 nums)
T
* (insert-circular 3 nums)
T
* (insert-circular 4 nums)
T
* (map-circular #'print nums)
1
4
3
2
(1 4 3 2)
Good.
Now implementing the game is not too difficult. We keep track of the current
node, the player, and the player scores. For each round of the game we
increment the current player, and check if the marble is special or not. If it
is, we count the list, and go forward n-8 steps (backwards 8) steps, so we
end up with the node before the one we want to remove. Then we remove in and
increment the score for the current player. If the marble is not special we
just insert it after the next marble in the circle. Lastly, we get the maximum
of the scores.
(defun play-game (num-marbles players)
(let* ((circle (make-circular 0))
(current circle)
(player 0)
(scores (make-array players)))
(insert-circular 1 circle)
(setf current (cdr circle))
(loop for marble from 2 to num-marbles do
(progn
(setf player (mod (1+ player) players))
(if (eq (mod marble 23) 0)
(let* ((len (length-circular circle))
(to-remove (nthcdr (- len 8) current)))
(incf (aref scores player) (+ marble (second to-remove)))
(remove-circular to-remove)
(setf current (cdr to-remove)))
(progn
(insert-circular marble (cdr current))
(setf current (cddr current))))))
(loop for s across scores maximizing s into m finally (return m))))
This is a very wasteful implementation, since we need to go through almost the entire list twice when removing marbles, since we have to go backwards. Still, for the input we were given, it doesn't perform too bad:
* (time (play-game 70848 425))
Evaluation took:
1.323 seconds of real time
1.322374 seconds of total run time (1.252015 user, 0.070359 system)
[ Run times consist of 0.207 seconds GC time, and 1.116 seconds non-GC time. ]
99.92% CPU
3,842,548,402 processor cycles
3,189,760,080 bytes consed
413188
Part 2
This, of course, was foreseen by the creator of the task: part 2 asks for the same game, but for 100 times the number of marbles. Since the current implementation is roughly quadratic, this means that we'll use 10.000X the time: 10.000 seconds is roughly three hours, which means back to the drawing board.
The natural approach is to add support for both-way traversal of the list. We can do this by not using lists, but make our own list:
(defstruct node b e f)
(defun make-circular (e)
(let ((n (make-node :f nil :e e :b nil)))
(setf (node-f n) n)
(setf (node-b n) n)
n))
Inserts and removals are similar to as before, except that we must swing two pointers instead of one.
(defun insert-circular (e node)
(let ((n (make-node :b node :e e :f (node-f node))))
(setf (node-b (node-f node)) n)
(setf (node-f node) n)
t))
(defun remove-circular (node)
(setf (node-f node) (node-f (node-f node)))
(setf (node-b (node-f node)) node)
t)
Having this it is very easy to go n steps backwards:
(defun n-back (n node)
(if (eq n 0) node
(n-back (- n 1) (node-b node))))
The main function is almost not changed at all, with the exception
of swapping cars with node-e and cdrs with node-f, in addition
to, of course, using n-back instead of nthcdr.
(defun play-game (num-marbles players)
(let* ((circle (make-circular 0))
(current circle)
(player 0)
(scores (make-array players)))
(insert-circular 1 circle)
(setf current (node-f circle))
(loop for marble from 2 to num-marbles do
(progn
(setf player (mod (1+ player) players))
(if (eq (mod marble 23) 0)
(let* ((to-remove (n-back 8 current)))
(incf (aref scores player) (+ marble (node-e (node-f to-remove))))
(remove-circular to-remove)
(setf current (node-f to-remove)))
(progn
(insert-circular marble (node-f current))
(setf current (node-f (node-f current)))))))
(loop for s across scores maximizing s into m finally (return m))))
Here's the running times for both input:
* (time (day-9/1))
Evaluation took:
0.008 seconds of real time
0.007581 seconds of total run time (0.007487 user, 0.000094 system)
100.00% CPU
22,124,513 processor cycles
2,162,688 bytes consed
413188
* (time (day-9/2))
Evaluation took:
1.169 seconds of real time
1.167412 seconds of total run time (1.080873 user, 0.086539 system)
[ Run times consist of 0.748 seconds GC time, and 0.420 seconds non-GC time. ]
99.83% CPU
3,394,813,588 processor cycles
216,923,648 bytes consed
3377272893
This work is licensed under a Creative Commons Attribution-ShareAlike 4.0 International License