Day 13 - Sorting Nested Packets

Dec 13

All 2022 Problems

Problem Overview

For today's problem, we're parsing and comparing packets, which appear as integers in lists with potentially several levels of nesting. In part 1, we'll consider the packets 2-by-2 and determine how many pairs are already ordered correctly. Then in part 2, we'll sort all the packets and determine the right place to insert a couple new packets.

Solution Approach and Insights

Haskell works very well for this problem! The ability to use a sum type, simple recursive parsing, and easy ordering mechanism make this a smooth solution.

Parsing the Input

Here's a sample input:

[1,1,3,1,1]
[1,1,5,1,1]

[[1],[2,3,4]]
[[1],4]

[9]
[[8,7,6]]

[[4,4],4,4]
[[4,4],4,4,4]

[7,7,7,7]
[7,7,7]

[]
[3]

[[[]]]
[[]]

[1,[2,[3,[4,[5,6,7]]]],8,9]
[1,[2,[3,[4,[5,6,0]]]],8,9]

Once again, we have blank line separation. Another noteworthy factor is that the empty list [] is a valid packet.

So let's start with a simple sum type to represent a single packet:

data Packet =
  IntPacket Int |
  ListPacket [Packet]
  deriving (Show, Eq)

To parse an individual packet, we have two cases. The IntPacket case is easy:

parsePacket :: (MonadLogger m) => ParsecT Void Text m Packet
parsePacket = parseInt <|> parseList
  where
    parseInt = parsePositiveNumber <&> IntPacket
    parseList = ...

To parse a list, we'll of course need to account for the bracket characters. But we'll also want to use sepBy (not sepBy1 since an empty list is valid!) in order to recursively parse the subpackets of a list.

parsePacket :: (MonadLogger m) => ParsecT Void Text m Packet
parsePacket = parseInt <|> parseList
  where
    parseInt = parsePositiveNumber <&> IntPacket
    parseList = do
      char '['
      packets <- sepBy parsePacket (char ',')
      char ']'
      return $ ListPacket packets

And now to complete the parsing, we'll parse two packets together in a pair:

parsePacketPair :: (MonadLogger m) => ParsecT Void Text m (Packet, Packet)
parsePacketPair = do
  p1 <- parsePacket
  eol
  p2 <- parsePacket
  eol
  return (p1, p2)

And then return a whole list of these pairs:

type InputType = [(Packet, Packet)]

parseInput :: (MonadLogger m) => ParsecT Void Text m InputType
parseInput = sepEndBy1 parsePacketPair eol

Getting the Solution

The core of the solution is writing a proper ordering on the packets. By using an Ordering instead of simply a Bool when comparing two packets, it will be easier to use this function recursively. We'll need to do this when comparing packet lists! So let's start with the type signature:

evalPackets :: Packet -> Packet -> Ordering

There are several cases that we can handle 1-by-1. First, to compare two IntPacket values, we just compare the underlying numbers.

evalPackets :: Packet -> Packet -> Ordering
evalPackets (IntPacket a) (IntPacket b) = compare a b
...

Now we have two cases where one value is an IntPacket and the other is a ListPacket. In these cases, we promote the IntPacket to a ListPacket with a singleton. Then we can recursively evaluate them.

evalPackets :: Packet -> Packet -> Ordering
evalPackets (IntPacket a) (IntPacket b) = compare a b
evalPackets (IntPacket a) b@(ListPacket _) = evalPackets (ListPacket [IntPacket a])  b
evalPackets a@(ListPacket _) (IntPacket b) = evalPackets a (ListPacket [IntPacket b])
...

Now for the case of two ListPacket inputs. Once again, we have to do some case analysis depending on if the lists are empty or not. If both are empty, the packets are equal (EQ).

evalPackets :: Packet -> Packet -> Ordering
...
evalPackets (ListPacket packets1) (ListPacket packets2) = case (packets1, packets2) of
  ([], []) -> EQ
  ...

If only the first packet is empty, we return LT. Conversely, if the second list is empty but the first is non-empty, we return GT.

evalPackets :: Packet -> Packet -> Ordering
...
evalPackets (ListPacket packets1) (ListPacket packets2) = case (packets1, packets2) of
  ([], []) -> EQ
  ([], _) -> LT
  (_, []) -> GT
  ...

Finally, we think about the case where both have at least one element. We start by comparing these two front packets. If they are equal, we must recurse on the remainder lists. If not, we can return that result.

evalPackets :: Packet -> Packet -> Ordering
evalPackets (IntPacket a) (IntPacket b) = compare a b
evalPackets (IntPacket a) b@(ListPacket _) = evalPackets (ListPacket [IntPacket a])  b
evalPackets a@(ListPacket _) (IntPacket b) = evalPackets a (ListPacket [IntPacket b])
evalPackets (ListPacket packets1) (ListPacket packets2) = case (packets1, packets2) of
  ([], []) -> EQ
  ([], _) -> LT
  (_, []) -> GT
  (a : rest1, b : rest2) ->
    let compareFirst = evalPackets a b
    in  if compareFirst == EQ
          then evalPackets (ListPacket rest1) (ListPacket rest2)
          else compareFirst

With this function in place, the first part is quite easy. We loop through the list of packet pairs with a fold. We'll zip with [1,2..] in order to match each pair to its index.

processInputEasy :: (MonadLogger m) => InputType -> m EasySolutionType
processInputEasy inputs = foldM foldLine initialFoldV (zip [1,2..] inputs)

type FoldType = Int

initialFoldV :: FoldType

foldLine :: (MonadLogger m) => FoldType -> (Int, (Packet, Packet)) -> m FoldType

The FoldType value is just our accumulated score. Each time the packets match, we add the index to the score.

initialFoldV :: FoldType
initialFoldV = 0

foldLine :: (MonadLogger m) => FoldType -> (Int, (Packet, Packet)) -> m FoldType
foldLine prev (index, (p1, p2)) = do
  let rightOrder = evalPackets p1 p2
  return $ if rightOrder == LT then prev + index else prev

And that gets us our solution to part 1!

solveEasy :: FilePath -> IO (Maybe Int)
solveEasy fp = runStdoutLoggingT $ do
  input <- parseFile parseInput fp
  Just <$> processInputEasy input

Part 2

Part 2 isn't much harder. We want to sort the packets using our ordering. But first we should append the two divider packets [[2]] and [[6]] to that list.

processInputHard :: (MonadLogger m) => InputType -> m HardSolutionType
processInputHard inputs = do
  let divider1 = ListPacket [ListPacket [IntPacket 2]]
      divider2 = ListPacket [ListPacket [IntPacket 6]]
      newInputs = (divider1, divider2) : inputs
      ...

Now we concatenate the pairs together, sort the list with the ordering, and find the locations of our two divider packets in the resulting list!

processInputHard :: (MonadLogger m) => InputType -> m HardSolutionType
processInputHard inputs = do
  let divider1 = ListPacket [ListPacket [IntPacket 2]]
      divider2 = ListPacket [ListPacket [IntPacket 6]]
      newInputs = (divider1, divider2) : inputs
      sortedPackets = sortBy evalPackets $ concat (pairToList <$> newInputs)
      i1 = elemIndex divider1 sortedPackets
      i2 = elemIndex divider2 sortedPackets
      ...

As long as we get two Just values, we'll multiply them together (except we need to add 1 to each index). This gives us our answer!

processInputHard :: (MonadLogger m) => InputType -> m HardSolutionType
processInputHard inputs = do
  let divider1 = ListPacket [ListPacket [IntPacket 2]]
  let divider2 = ListPacket [ListPacket [IntPacket 6]]
      newInputs = (divider1, divider2) : inputs
      sortedPackets = sortBy evalPackets $ concat (pairToList <$> newInputs)
      i1 = elemIndex divider1 sortedPackets
      i2 = elemIndex divider2 sortedPackets
  case (i1, i2) of
    (Just index1, Just index2) -> return $ (index1 + 1) * (index2 + 1)
    _ -> return (-1)
  where
    pairToList (a, b) = [a, b]

solveHard :: FilePath -> IO (Maybe Int)
solveHard fp = runStdoutLoggingT $ do
  input <- parseFile parseInput fp
  Just <$> processInputHard input

And now we're done with Day 13, and have just passed the halfway mark!

Video

YouTube Link!

Advent of Code

James Bowen