Day 23 is one where the the obvious approach works fine for the small problem in part 1, but doesn't scale to the larger problem in part 2. But I think it's interesting to cover both, so this is a post of two parts.
This uses an obvious representation for the circle of cups, a circular pointed list. This is an example of a zipper, a data structure with one element picked out as a focus. In this case, the focus of the pointed list is the current element. Functions like
next move the focus, and you can insert and delete elements from the list. This is a natural fit to the "circle of labelled things" in the problem.
I needed to remove and re-insert three items, so I quickly whipped up
dropRight functions to help that.
takeRight :: Int -> P.PointedList a -> [a] takeRight 0 _ =  takeRight n xs = (xs ^. P.focus):(takeRight (n - 1) $ P.next xs) dropRight :: Int -> P.PointedList a -> Maybe (P.PointedList a) dropRight 0 xs = Just xs dropRight n xxs = case (P.deleteRight xxs) of Just xs -> dropRight (n - 1) xs Nothing -> Nothing
I also needed something to find valid destinations
validDestination 0 max missing = validDestination max max missing validDestination n max missing | n `elem` missing = validDestination (n - 1) max missing | otherwise = n
The main "play one step of the game" function is a fairly direct translation of the steps into code, inserting deleting and shifting as needed.
playOne cups = P.next replacedAtCurrent where current = cups ^. P.focus held = takeRight 3 $ P.next cups shorter = fromJust $ dropRight 3 $ P.next cups destination = validDestination (current - 1) 9 held shorterAtDestination = fromJust $ P.find destination shorter replaced = foldr P.insertRight shorterAtDestination $ reverse held replacedAtCurrent = fromJust $ P.find current replaced
Finally, a bit of plumbing to connect the input to the solution
part1 nums = label $ playN cups 100 where cups = fromJust $ P.fromList nums label cups = concatMap show $ tail $ takeRight (P.length cups) atOne where atOne = fromJust $ P.find 1 cups playN cups n = (iterate playOne cups) !! n
This scaled up from ten cups and one hundred rounds to one million cups and ten million rounds. A pointed list wasn't going to cope. But as all the moves were "what's the next cup around the circle", a circular linked list would be enough, if I could make the pointer updates happen in a mutable structure (much like day 15). It's easier to work through the updates, and the intermediate pointers needed, with an example.
I start with the cups after the first move of the example. Given the current cup, I can pick the first held cup and the first cup after the held ones.
I can then splice out the held cups by making current point to after held. I then identify the destination cup (and the cup after the destination).
Then I do the other pointer updates. Destination now points to held, and the last held cup points to the cup after the destination.
If I neaten that up a bit, I show the result after the move, ready for current to move on one cup.
Now I know what I'm doing, I just need to implement it. First, I need to decide on a data structure. Each cup has an index and a pointer to the next cup, and that's all. That suggests using a
Vector, where the contents of
cups[i] is the next cup from cup i. The state at in the last diagram above would be like this:
After cup 1 comes cup 3; after cup 2 comes cup 5; and so on.
I also saw a suggestion (from somewhere) that keeps things a bit neater. Vectors have zero-based indexing, but I want to use one-based indexing for the pointers. I can repurpose
cups to be a pointer to the current cup.
After all of that, the code for each game step update follows from the description.
gameStep :: Int -> V.MVector s Int -> ST s () gameStep maxCups cups = do current <- V.read cups 0 held1 <- V.read cups current held2 <- V.read cups held1 held3 <- V.read cups held2 afterHeld <- V.read cups held3 -- close the loop, removing the held cups V.write cups current afterHeld let destination = validDestination (current - 1) maxCups [held1, held2, held3] afterDestination <- V.read cups destination -- make the held come after the destination V.write cups destination held1 -- make the end of the held point into the rest of the loop V.write cups held3 afterDestination -- advance current nextCup <- V.read cups current -- and store it V.write cups 0 nextCup return ()
There's also a bit of setup to create the initial vector then run the game.
runGame :: [Int] -> Int -> Int -> [Int] runGame seed cupsNeeded roundsNeeded = runST $ do cups <- seedGame seed cupsNeeded gameLoop roundsNeeded cupsNeeded cups mapM (V.read cups) [0..cupsNeeded] seedGame :: [Int] -> Int -> ST s (V.MVector s Int) seedGame seed cupsNeeded = do cups <- V.new (cupsNeeded + 1) let extended = seed ++ [10, 11..] forM_ [0..cupsNeeded] $ \i -> V.write cups i (i + 1) forM_ (zip seed $ tail extended) $ \(i, j) -> V.write cups i j V.write cups 0 (head seed) let end = if cupsNeeded > (length seed) then cupsNeeded else last seed V.write cups end (head seed) return cups gameLoop targetRound maxCups cups = do forM_ [1..targetRound] (\_ -> gameStep maxCups cups) return ()
It takes about 1.8 seconds to run both parts.