Advent of Code 2020 day 23

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.

Part 1

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 previous and 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 takeRight and 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

(Note the use of a lens ^. to get the focused element; see AoC 2019 day 23 for more use of lenses.)

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

Part 2

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[0] 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.

Code

You can find the code here or on GitLab.