Permalink
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
2222 lines (1717 sloc) 67.1 KB

Reflections

Table of Contents

Day 1

(code)

We can generate a list of consecutive items (while looping around) very crudely using:

conseqs :: [a] -> [(a,a)]
conseqs (x:xs) = zip (x:xs) (xs ++ [x])

For part 2, we can generate a list of "opposite" items by zipping a bisected list:

bisect :: [a] -> ([a], [a])
bisect xs = splitAt (length xs `div` 2) xs

uncurry zip . bisect :: [a] -> [(a,a)]

From either of these, we can select the ones that are "matching" by filtering for equal tuples:

matchings :: Eq a => [(a,a)] -> [a]
matchings = map fst . filter (\(x,y) -> x == y)

The result is the sum of all of the "matched" numbers, so in the end, we have:

day01a :: [Int] -> Int
day01a =        sum . matchings . (      conseqs       )

day01b :: [Int] -> Int
day01b = (*2) . sum . matchings . (uncurry zip . bisect)

Note that we do need to "double count" for Part 2.

We could parse the actual strings into [Int] by just using map digitToInt :: String -> [Int]

Day 1 Benchmarks

>> Day 01a
benchmarking...
time                 59.08 μs   (56.52 μs .. 61.98 μs)
                     0.981 R²   (0.971 R² .. 0.991 R²)
mean                 61.41 μs   (57.81 μs .. 69.65 μs)
std dev              17.28 μs   (7.177 μs .. 28.41 μs)
variance introduced by outliers: 97% (severely inflated)

>> Day 01b
benchmarking...
time                 93.48 μs   (88.50 μs .. 98.63 μs)
                     0.979 R²   (0.969 R² .. 0.992 R²)
mean                 90.52 μs   (87.72 μs .. 94.51 μs)
std dev              10.30 μs   (6.708 μs .. 14.16 μs)
variance introduced by outliers: 86% (severely inflated)

Day 2

(code)

Good stream processing demonstration. Both problems just boil down to summing a function on all lines:

day02a :: [[Int]] -> Int
day02a = sum . map checkA

day02b :: [[Int]] -> Int
day02b = sum . map checkB

checkA is just the maximum minus the minimum:

checkA :: [Int] -> Int
checkA xs = maximum xs - minimum xs

checkB requires you to "find" an item subject to several constraints, and this can be done using the list monad instance (to pretend to be writing Prolog) or simply a list comprehension.

checkB :: [Int] -> Int
checkB xs = head $ do
    y:ys   <- tails (sort xs)
    (d, 0) <- (`divMod` y) <$> ys
    return d

First we list all of our "possibilities" that we want to search -- we consider all y : ys, where y is some element in our list, and ys is all of items greater than or equal to y in the list.

Then we consider the divMod of any number in ys by y, but only the ones that give a mod of 0 (the perfect divisor of y in ys).

Our result is d, the result of the perfect division.

Parsing is pretty straightforward again; we can use map (map read . words) . lines :: String -> [[Int]] to split by lines, then by words, and read every word.

Day 2 Benchmarks

>> Day 02a
benchmarking...
time                 701.8 μs   (671.5 μs .. 741.4 μs)
                     0.982 R²   (0.961 R² .. 0.996 R²)
mean                 687.1 μs   (670.0 μs .. 721.0 μs)
std dev              80.53 μs   (50.15 μs .. 132.3 μs)
variance introduced by outliers: 81% (severely inflated)

>> Day 02b
benchmarking...
time                 775.4 μs   (742.7 μs .. 822.8 μs)
                     0.974 R²   (0.947 R² .. 0.996 R²)
mean                 769.2 μs   (746.3 μs .. 818.0 μs)
std dev              107.1 μs   (49.91 μs .. 186.3 μs)
variance introduced by outliers: 85% (severely inflated)

Day 3

(code)

My Day 3 solution revolves around the Trail monoid:

newtype Trail a = Trail { runTrail :: a -> ([a], a) }
instance Semigroup (Trail a) where
    f <> g = Trail $ \x -> let (xs, y) = runTrail f x
                               (ys, z) = runTrail g y
                           in  (xs ++ ys, z)
instance Monoid (Trail a) where
    mempty  = Trail ([],)
    mappend = (<>)

Which describes a function that "leaves a trail" as it is being run. The mappend/<> action composes two functions together (one after the other), and also combines the "trails" that they leave behind.

In an unrelated monoid usage, we have

type Pos = (Sum Int, Sum Int)

So p1 <> p2 will be the component-wise addition of two points.

To start off, we build ulam :: [Pos], an infinite list of positions, starting from the middle of the spiral and moving outwards. ulam !! 0 would be the very center (the 1st position), ulam !! 10 would be the 11th position, etc.

We build this spiral using move, our most basic Trail:

move :: Pos -> Trail Pos
move p = Trail $ \p0 -> ([p0 <> p], p0 <> p)

move (1,0) would give a Trail that moves one tile to the right, and leaves the new position in its trail.

We can then build the entire spiral by <>ing (using foldMap) Trails forever:

spiral :: Trail Pos
spiral = move (0,0)
      <> foldMap loop [1..]
  where
    loop :: Int -> Trail Pos
    loop n = stimes (2*n-1) (move ( 1, 0))
          <> stimes (2*n-1) (move ( 0, 1))
          <> stimes (2*n  ) (move (-1, 0))
          <> stimes (2*n  ) (move ( 0,-1))

And for ulam, we run the Trail from (0,0), and get the trail list (fst).

ulam :: [Pos]
ulam = fst $ runTrail spiral (0,0)

Part 1

Part 1 is then just getting the nth item in ulam, and calculating its distance from the center:

day03a :: Int -> Int
day03a i = norm $ ulam !! (i - 1)
  where
    norm (Sum x, Sum y) = abs x + abs y

Part 2

For Part 2, we keep the state of the filled out cells as a Map Pos Int, which stores the number at each position. If the position has not been "reached" yet, it will not be in the Map.

We can use State to compose these functions easily. Here we write a function that takes a position and fills in that position's value in the Map appropriately, and returns the new value at that position:

updateMap :: Pos -> State (M.Map Pos Int) Int
updateMap p = state $ \m0 ->
    let newPos = sum . mapMaybe (`M.lookup` m0) $
          [ p <> (Sum x, Sum y) | x <- [-1 .. 1]
                                , y <- [-1 .. 1]
                                , x /= 0 || y /= 0
                                ]
    in  (newPos, M.insertWith (const id) p newPos m0)

We use M.insertWith (const id) instead of M.insert because we don't want to overwrite any previous entries.

Since we wrote updateMap using State, we can just traverse over ulam -- if updateMap p updates the map at point p and returns the new value at that position, then traverse updateMap ulam updates updates the map at every position in ulam, one-by-one, and returns the new values at each position.

cellNums :: [Int]
cellNums = flip evalState (M.singleton (0, 0) 1) $
    traverse updateMap ulam

And so part 2 is just finding the first item matching some predicate, which is just find from base:

day03b :: Int -> Int
day03b i = fromJust $ find (> i) cellNums

Day 3 Benchmarks

>> Day 03a
benchmarking...
time                 2.706 ms   (2.640 ms .. 2.751 ms)
                     0.997 R²   (0.995 R² .. 0.999 R²)
mean                 2.186 ms   (2.090 ms .. 2.267 ms)
std dev              231.4 μs   (198.3 μs .. 267.7 μs)
variance introduced by outliers: 66% (severely inflated)

>> Day 03b
benchmarking...
time                 2.999 μs   (2.639 μs .. 3.438 μs)
                     0.870 R²   (0.831 R² .. 0.935 R²)
mean                 3.684 μs   (2.945 μs .. 4.457 μs)
std dev              1.629 μs   (1.190 μs .. 2.117 μs)
variance introduced by outliers: 99% (severely inflated)

Day 4

(code)

Day 4 is very basic stream processing. Just filter for lines that have "all unique" items, and count how many lines are remaining.

Part 1 and Part 2 are basically the same, except Part 2 checks for uniqueness up to ordering of letters. If we sort the letters in each word first, this normalizes all of the words so we can just use ==.

day04a :: [[String]] -> Int
day04a = length . filter uniq

day04b :: [[String]] -> Int
day04b = length . filter uniq . (map . map) sort

All that's left is finding a function to tell us if all of the items in a list are unique.

uniq :: Eq a => [a] -> Bool
uniq xs = length xs == length (nub xs)

There are definitely ways of doing this that scale better, but given that all of the lines in my puzzle input are less than a dozen words long, it's really not worth it to optimize!

(We can parse the input into a list of list of strings using map words . lines :: String -> [[String]])

Day 4 Benchmarks

>> Day 04a
benchmarking...
time                 1.786 ms   (1.726 ms .. 1.858 ms)
                     0.990 R²   (0.984 R² .. 0.995 R²)
mean                 1.776 ms   (1.738 ms .. 1.877 ms)
std dev              193.2 μs   (98.00 μs .. 356.9 μs)
variance introduced by outliers: 73% (severely inflated)

>> Day 04b
benchmarking...
time                 3.979 ms   (3.431 ms .. 4.421 ms)
                     0.912 R²   (0.852 R² .. 0.974 R²)
mean                 3.499 ms   (3.349 ms .. 3.805 ms)
std dev              703.5 μs   (475.7 μs .. 1.026 ms)
variance introduced by outliers: 88% (severely inflated)

Day 5

(code)

Day 5 centers around the Tape zipper:

data Tape a = Tape { _tLefts  :: [a]
                   , _tFocus  :: a
                   , _tRights :: [a]
                   }
  deriving Show

We have the "focus" (the current pointer position), the items to the left of the focus (in reverse order, starting from the item closest to the focus), and the items to the right of the focus.

Tape is neat because moving one step to the left or right is O(1). It's also "type-safe" in our situation, unlike an IntMap, because it enforces a solid unbroken tape space.

One fundamental operation on a tape is move, which moves the focus on a tape to the left or right by an Int offset. If we ever reach the end of the list, it's Nothing.

-- | `move n` is O(n)
move :: Int -> Tape Int -> Maybe (Tape Int)
move n (Tape ls x rs) = case compare n 0 of
    LT -> case ls of
      []    -> Nothing
      l:ls' -> move (n + 1) (Tape ls' l (x:rs))
    EQ -> Just (Tape ls x rs)
    GT -> case rs of
      []    -> Nothing
      r:rs' -> move (n - 1) (Tape (x:ls) r rs')

Now we just need to simulate the machine in the puzzle:

step
    :: (Int -> Int)         -- ^ cell update function
    -> Tape Int
    -> Maybe (Tape Int)
step f (Tape ls x rs) = move x (Tape ls (f x) rs)

At every step, move based on the item at the list focus, and update that item accordingly.

We can write a quick utility function to continually apply a a -> Maybe a until we hit a Nothing:

iterateMaybe :: (a -> Maybe a) -> a -> [a]
iterateMaybe f x0 = x0 : unfoldr (fmap dup . f) x0
  where
    dup x = (x,x)

And now we have our solutions. Part 1 and Part 2 are pretty much the same, except for different updating functions.

day05a :: Tape Int -> Int
day05a = length . iterateMaybe (step update)
  where
    update x = x + 1

day05b :: Tape Int -> Int
day05b = length . iterateMaybe (step update)
  where
    update x
      | x >= 3    = x - 1
      | otherwise = x + 1

Note that we do have to parse our Tape from an input string. We can do this using something like:

parse :: String -> Tape Int
parse (map read.lines->x:xs) = Tape [] x xs
parse _                      = error "Expected at least one line"

Parsing the words in the line, and setting up a Tape focused on the far left item.

Day 5 Benchmarks

>> Day 05a
benchmarking...
time                 514.3 ms   (417.9 ms .. 608.1 ms)
                     0.995 R²   (0.983 R² .. 1.000 R²)
mean                 479.1 ms   (451.4 ms .. 496.5 ms)
std dev              26.27 ms   (0.0 s .. 30.17 ms)
variance introduced by outliers: 19% (moderately inflated)

>> Day 05b
benchmarking...
time                 1.196 s    (1.164 s .. 1.265 s)
                     1.000 R²   (0.999 R² .. 1.000 R²)
mean                 1.211 s    (1.197 s .. 1.221 s)
std dev              15.45 ms   (0.0 s .. 17.62 ms)
variance introduced by outliers: 19% (moderately inflated)

Day 6

(code)

Day 6 is yet another simulation of a virtual machine. There might be an analytic way to do things, but input size is small enough that you can just directly simulate the machine in a reasonable time.

Step

At the most basic level, we need to write a function to advance the simulation one step in time:

step :: V.Vector Int -> V.Vector Int
step v = V.accum (+) v' ((,1) <$> indices)
  where
    maxIx     = V.maxIndex v
    numBlocks = v V.! maxIx
    v'        = v V.// [(maxIx, 0)]
    indices   = (`mod` V.length v) <$> [maxIx + 1 .. maxIx + numBlocks]

V.accum (+) v' ((,1) <$> indices) will increment all indices in indices in the vector by 1 -- potentially more than once times if it shows up in indices multiple times. For example, if indices is [4,7,1,2,4] will increment the numbers at indices 4, 7, 1, 2, and 4 again (so the number at position 4 will be incremented twice).

All that's left is generating indices. We know we need an entry for every place we want to "drop a block". We get the starting index using V.maxIndex, and so get the number of blocks to drop using v V.! maxIx. Our list of indices is just [maxIx + 1 .. maxIx + numBlocks], but all mod'd by by the size of v so we cycle through the indices.

We must remember to re-set the starting position's value to 0 before we start.

Thanks to glguy for the idea to use accum!

Loop

We can now just iterate step :: [V.Vector Int], which just contains an infinite list of steps. We want to now find the loops.

To do this, we can scan across iterate step. We keep track of a m :: Map a Int, which stores all of the previously seen states (as keys), along with how long ago they were seen. We also keep track of the number of steps we have taken so far (n)

findLoop :: Ord a => [a] -> (Int, Int)
findLoop = go 0 M.empty
  where
    go _ _ []     = error "We expect an infinite list"
    go n m (x:xs) = case M.lookup x m of
        Just l  -> (n, l)
        Nothing -> go (n + 1) (M.insert x 1 m') xs
      where
        m' = succ <$> m

At every step, if the Map does include the previously seen state as a key, then we're done. We return the associated value (how long ago it was seen) and the number of steps we have taken so far.

Otherwise, insert the new state into the Map, update all of the old "last-time-seen" values (by fmapping succ), and move on.

All Together

We have our whole challenge:

day06 :: V.Vector Int -> (Int, Int)
day06 = findLoop . iterate step

Part 1 is the fst of that, and Part 2 is the snd of that.

We can parse the input using V.fromList . map read . words :: String -> V.Vector Int.

Day 6 Benchmarks

>> Day 06a
benchmarking...
time                 681.9 ms   (658.3 ms .. 693.4 ms)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 669.9 ms   (665.6 ms .. 672.8 ms)
std dev              4.220 ms   (0.0 s .. 4.869 ms)
variance introduced by outliers: 19% (moderately inflated)

>> Day 06b
benchmarking...
time                 688.7 ms   (504.2 ms .. 881.2 ms)
                     0.990 R²   (0.964 R² .. 1.000 R²)
mean                 710.2 ms   (687.9 ms .. 731.7 ms)
std dev              36.52 ms   (0.0 s .. 37.19 ms)
variance introduced by outliers: 19% (moderately inflated)

Day 7

(code)

We can just build the tree in Haskell. We have basically a simple rose tree of Ints, so we can use Tree Int from Data.Tree (from the containers package).

Part 1

Our input is essentially M.Map String (Int, S.Set String), a map of string labels to their weights and the labels of their leaves.

-- | Returns the root label and the tree
buildTree
    :: M.Map String (Int, S.Set String)
    -> (String, Tree Int)
buildTree m = (root, result)
  where
    allChildren :: S.Set String
    allChildren = S.unions (snd <$> toList m)
    root :: String
    root = S.findMax $ M.keysSet m `S.difference` allChildren

    result :: Tree Int
    result = flip unfoldTree root $ \p ->
      let (w, cs) = m M.! p
      in  (w, toList cs)

Building a tree is pretty simple with unfoldTree :: (a -> [b] -> (a,[b])) -> b -> Tree a. Given an initial seed value, and a way to give a "result" (node content) and all new seeds, it can unfold out a tree for us. The initial seed is the root node, and the unfolding process looks up the weights and all of the children of the given label.

The only complication now is finding the "root" of the entire tree. This is simply the only symbol that is not in the union of all children sets.

We technically don't need the strings in the tree, but we do need it for Part 1, so we can return it as a second input using a tuple.

day07a :: M.Map String (Int, S.Set String) -> String
day07a = fst . buildTree

One nice thing about using a tree is that we can actually visualize it using drawTree :: Tree String -> String from containers! It's kind of big though so it's difficult to inspect for our actual input, but it's nice for being able to check the sample input.

Part 2

Time to find the bad node.

findBad :: Tree Int -> Maybe Int
findBad t0 = listToMaybe badChildren <|> anomaly
  where
    badChildren :: [Int]
    badChildren = mapMaybe findBad $ subForest t0
    weightMap :: M.Map Int [Int]
    weightMap = M.fromListWith (++)
              . map (\t -> (sum t, [rootLabel t]))
              $ subForest t0
    anomaly :: Maybe Int
    anomaly = case sortOn (length . snd) (M.toList weightMap) of
      -- end of the line
      []                       -> Nothing
      -- all weights match
      [_]                      -> Nothing
      -- exactly one anomaly
      [(wTot1, [w]),(wTot2,_)] -> Just (w + (wTot2 - wTot1))
      -- should not happen
      _                        -> error "More than one anomaly for node"

At the heart of it all, we check if any of the children are bad, before checking if the current node itself is bad. This is because any anomaly on the level of our current node is not fixable if there are any errors in children nodes.

To isolate bad nodes, I built a Map Int [Int], which is a map of unique "total weight" to a list of all of the immediate child weights that have that total weight. We can build a total weight by just using sum :: Tree Int -> Int, which adds up all of the weights of all of the child nodes.

If this map is empty, it means that there are no children. Nothing, no anomaly.

If this map has one item, it means that there is only one unique total weight amongst all of the child nodes. Nothing, no anomaly.

If the map has two items, it means that there are two distinct total weights, and one of those should have exactly one corresponding child node. (We can sort the list to ensure that that anomaly node is the first one in the list)

From here we can compute what that anomaly node's weight (w1) should really be, and return Just that.

Any other cases don't make sense (more than two distinct total weights, or a situation where there isn't exactly one odd node)

day07b :: M.Map String (Int, S.Set String) -> Int
day07b = fromJust . findBad . snd . buildTree

Parsing

Parsing is straightforward but not trivial.

parseLine :: String -> (String, (Int, S.Set String))
parseLine (words->p:w:ws) =
    (p, (read w, S.fromList (filter isAlpha <$> drop 1 ws)))
parseLine _ = error "No parse"

parse :: String -> M.Map String (Int, S.Set String)
parse = M.fromList . map parseLine . lines

Day 7 Benchmarks

>> Day 07a
benchmarking...
time                 8.411 ms   (7.956 ms .. 8.961 ms)
                     0.973 R²   (0.954 R² .. 0.989 R²)
mean                 8.129 ms   (7.939 ms .. 8.447 ms)
std dev              736.6 μs   (501.9 μs .. 1.058 ms)
variance introduced by outliers: 50% (moderately inflated)

>> Day 07b
benchmarking...
time                 12.30 ms   (11.36 ms .. 14.21 ms)
                     0.909 R²   (0.815 R² .. 0.993 R²)
mean                 12.06 ms   (11.55 ms .. 13.00 ms)
std dev              1.799 ms   (935.1 μs .. 2.877 ms)
variance introduced by outliers: 69% (severely inflated)

Day 8

(code)

Happy to see that Day 8, like day 7, is another problem that is very suitable for Haskell! :)

I decided to make an ADT to encode each instruction

data Instr = Instr { _iRegister  :: String
                   , _iUpdate    :: Int
                   , _iCondReg   :: String
                   , _iPredicate :: Int -> Bool
                   }

It includes a register to update, an update amount, a register to check for a condition, and a predicate to apply to see whether or not to apply an update.

So something like

b inc 5 if a > 1

would be parsed as

Instr { _iRegister  = "b"
      , _iUpdate    = 5
      , _iCondReg   = "a"
      , _iPredicate = (> 1)
      }

From this, our updating function step is basically following the logic of the puzzle's update process:

step :: M.Map String Int -> Instr -> M.Map String Int
step m (Instr r u c p)
  | p (M.findWithDefault 0 c m) = M.insertWith (+) r u m
  | otherwise                   = m

Part 1

So this makes Part 1 basically a simple foldl, to produce the final Map of all the registers. Then we use maximum :: Ord v => Map k v -> v to get the maximum register value.

day08a :: [Instr] -> Int
day08a = maximum . foldl' step M.empty

Note that this might potentially give the wrong answer if all register values in the Map are negative. Then maximum of our Map would be negative, but there are still registers that exist with 0 that aren't in our Map.

Part 2

Part 2 is basically a simple scanl.

day08b :: [Instr] -> Int
day08b = maximum . foldMap toList . scanl' step M.empty

foldl gave us the final Map, but scanl gives us all the intermediate Maps that were formed along the way.

We want the maximum value that was ever seen, so we use foldMap toList :: [Map k v] -> [v] to get a list of all values ever seen, and maximum that list. There are definitely more efficient ways to do this! The same caveat (situation where all registers are always negative) applies here.

By the way, isn't it neat that switching between Part 1 and Part 2 is just switching between foldl and scanl? (Observation thanks to cocreature) Higher order functions and purity are the best!

Parsing

Again, parsing an Instr is straightforward but non-trivial.

parseLine :: String -> Instr
parseLine (words->r:f:u:_:c:o:x:_) =
    Instr { _iRegister  = r
          , _iUpdate    = f' (read u)
          , _iCondReg   = c
          , _iPredicate = (`op` read x)
          }
  where
    f' = case f of
      "dec" -> negate
      _     -> id
    op = case o of
      ">"  -> (>)
      ">=" -> (>=)
      "<"  -> (<)
      "<=" -> (<=)
      "==" -> (==)
      "!=" -> (/=)
      _    -> error "Invalid op"
parseLine _ = error "No parse"

Care has to be taken to ensure that dec 5, for instance, is parsed as an update of -5.

It is interesting to note that -- as a consequence of laziness -- read u and f' might never be evaluated, and u and f might never be parsed. This is because if the condition is found to be negative for a line, the _iUpdate field is never used, so we can throw away u and f without ever evaluating them!

Day 8 Benchmarks

>> Day 08a
benchmarking...
time                 8.545 ms   (8.085 ms .. 9.007 ms)
                     0.984 R²   (0.975 R² .. 0.994 R²)
mean                 8.609 ms   (8.365 ms .. 9.328 ms)
std dev              1.068 ms   (432.2 μs .. 2.039 ms)
variance introduced by outliers: 67% (severely inflated)

>> Day 08b
benchmarking...
time                 9.764 ms   (9.185 ms .. 10.44 ms)
                     0.975 R²   (0.955 R² .. 0.993 R²)
mean                 9.496 ms   (9.233 ms .. 9.816 ms)
std dev              846.1 μs   (567.6 μs .. 1.200 ms)
variance introduced by outliers: 50% (moderately inflated)

Day 9

(code)

Today I actually decided to live stream my leader board attempt! Admittedly I was in a new and noisy environment, so adding live streaming to that only made my attempt a bit more complicated :)

Anyway, our solution today involves the AST Tree:

data Tree = Garbage String
          | Group [Tree]

Getting the score is a simple recursive traversal:

treeScore :: Tree -> Int
treeScore = go 1
  where
    go _ (Garbage _ ) = 0
    go n (Group   ts) = n + sum (go (n + 1) <$> ts)

Getting the total amount of garbage is, as well:

treeGarbage :: Tree -> Int
treeGarbage (Garbage n ) = length n
treeGarbage (Group   ts) = sum (treeGarbage <$> ts)

And so that's essentially our entire solution:

day09a :: Tree -> Int
day09a = treeScore

day09b :: Tree -> Int
day09b = treeGarbage

Parsing

Parsing was simpler than I originally thought it would be. We can use the megaparsec library's parser combinators:

parseTree :: Parser Tree
parseTree = P.choice [ Group   <$> parseGroup
                     , Garbage <$> parseGarbage
                     ]
  where
    parseGroup :: Parser [Tree]
    parseGroup = P.between (P.char '{') (P.char '}') $
        parseTree `P.sepBy` P.char ','
    parseGarbage :: Parser String
    parseGarbage = P.between (P.char '<') (P.char '>') $
        catMaybes <$> many garbageChar
      where
        garbageChar :: Parser (Maybe Char)
        garbageChar = P.choice
          [ Nothing <$ (P.char '!' *> P.anyChar)
          , Just    <$> P.noneOf ">"
          ]

Our final Tree is either a Group (parsed with parseGroup) or Garbage (parsed with parseGarbage).

  • parseGroup parses Trees separated by ,, between curly brackets.

  • parseGarbage parses many consecutive valid garbage tokens (Which may or may not contain a valid garbage character, Maybe Char), between angled brackets. It catMaybes the contents of all of the tokens to get all actual garbage characters.

    Thanks to rafl for the idea of using many and between for parseGarbage instead of my original explicitly recursive solution!

And so we have:

parse :: String -> Tree
parse = either (error . show) id . P.runParser parseTree ""

We do need to handle the case where the parser doesn't succeed, since runParser returns an Either.

Day 9 Benchmarks

>> Day 09a
benchmarking...
time                 2.508 ms   (2.366 ms .. 2.687 ms)
                     0.957 R²   (0.910 R² .. 0.990 R²)
mean                 2.589 ms   (2.477 ms .. 3.009 ms)
std dev              628.2 μs   (223.5 μs .. 1.246 ms)
variance introduced by outliers: 94% (severely inflated)

>> Day 09b
benchmarking...
time                 3.354 ms   (3.108 ms .. 3.684 ms)
                     0.952 R²   (0.919 R² .. 0.992 R²)
mean                 3.196 ms   (3.086 ms .. 3.383 ms)
std dev              411.1 μs   (232.5 μs .. 595.1 μs)
variance introduced by outliers: 76% (severely inflated)

Day 10

(code) (stream)

I feel like I actually had a shot today, if it weren't for a couple of silly mistakes! :( First I forgot to add a number, then I had a stray newline in my input for some reason. For Day 9, I struggled to get an idea of what's going on, but once I had a clear plan, the rest was easy. For Day 10, the clear idea was fast, but the many minor lapses along the way were what probably delayed me the most :)

Our solution today revolves around this state type:

data HashState = HS { _hsVec  :: V.Vector Int
                    , _hsPos  :: Word8
                    , _hsSkip :: Word8
                    }

Interesting note -- this Vector, Int pairing is actually something that has come up a lot over the previous Advent of Code puzzles. It's basically a vector attached with some "index" (or "focus"). It's actually a manifestation of the Store Comonad. Something like this really would have made a lot of the previous puzzles really simple, or at least would have been very suitable for their implementations.

Part 1

Anyway, most of the algorithm boils down to a foldl with this state on some list of inputs:

step :: HashState -> Word8 -> HashState
step (HS v0 p0 s0) n = HS v1 p1 s1
  where
    ixes = fromIntegral . (+ p0) <$> init [0 .. n]
    vals = (v0 V.!) <$> ixes
    v1   = v0 V.// zip ixes (reverse vals)
    p1   = p0 + n + s0
    s1   = s0 + 1

Our updating function is somewhat of a direct translation of the requirements. All of the indices to update are enumerated using [0 .. n]. But, we only want the first n items (we don't want to actually include n, just n - 1), so we can take the init of it. We shift their positions by + p0.

The "trick" to the cyclic vector is that Word8 addition is modular arithmetic, so this will actually cause overflows to wrap around like we require. For example, (+ 253) <$> [0..5] is [253,254,255,0,1,2]

We also need the values at each of the indices, so we map (v0 V.!) over our list of indices.

Finally, we use (//) :: Vector a -> [(Int, a)] -> Vector a to update all of the items necessary. // replaces all of the indices in the list with the values they are paired up with. For us, we want to put the items back in the list in reverse order, so we zip ixes and reverse vals, so that the indices at ixes are set to be the values reverse vals.

Our new position is p0 + n + s0 -- the current position plus the length plus the skip count. Again, because of Word8 arithmetic, this wraps around at 255, so it has the behavior we want.

Now we can iterate this using foldl'

process :: [Word8] -> V.Vector Int
process = _hsVec . foldl' step hs0
  where
    hs0 = HS (V.generate 256 id) 0 0

From here, we can write our Part 1:

day10a :: [Int] -> Int
day10a = product . V.take 2 . process

We can parse our input using map read . splitOn "," :: String -> [Int], splitOn from the split library.

Part 2

Part 2 is pretty straightforward in that the logic is extremely simple, just do a series of transformations.

First we can make the "knot hash" itself:

knothash :: String -> [Word8]
knothash = map (foldr xor 0) . chunksOf 16 . V.toList . process
         . concat . replicate 64 . (++ salt)
         . map (fromIntegral . ord)
  where
    salt  = [17, 31, 73, 47, 23]

We:

  1. Append the salt bytes at the end
  2. concat . replicate 64 :: [a] -> [a], replicate the list of inputs 64 times
  3. process things like how we did in Part 1
  4. Break into chunks of 16 (using chunksOf from the split library)
  5. foldr each chunk of 16 using xor

And our actual day10b is then just applying this and printing this as hex:

day10b :: [Word8] -> String
day10b = concatMap (printf "%02x") . knothash

We leverage the printf formatter from Text.Printf to generate the hex, being careful to ensure we pad the result.

Not super complicated, it's just that there are so many steps described in the puzzle!

Day 10 Benchmarks

Note: Benchmarks measured with storable vectors.

>> Day 10a
benchmarking...
time                 254.6 μs   (242.1 μs .. 268.9 μs)
                     0.925 R²   (0.851 R² .. 0.976 R²)
mean                 348.8 μs   (289.1 μs .. 467.6 μs)
std dev              265.2 μs   (147.4 μs .. 414.0 μs)
variance introduced by outliers: 99% (severely inflated)

>> Day 10b
benchmarking...
time                 25.00 ms   (21.24 ms .. 27.61 ms)
                     0.936 R²   (0.822 R² .. 0.992 R²)
mean                 26.21 ms   (24.47 ms .. 33.03 ms)
std dev              6.425 ms   (1.676 ms .. 13.03 ms)
variance introduced by outliers: 83% (severely inflated)

Day 11

(code)

Nothing too interesting here! Just a straightforward application of the great grid library.

We barely need to wrap its neighbor function (which lets us move in a given direction) for our usage:

step :: (Int, Int) -> HexDirection -> (Int, Int)
step p = fromJust . neighbour UnboundedHexGrid p

day11a :: [HexDireciton] -> Int
day11a = distance UnboundedHexGrid (0,0) . foldl' step (0,0)

It's just a foldl of neighbor, and then finding the distance at the final point.

And, like day 8's solution, all we need for Part 2 is to switch foldl' to scanl:

day11a :: [HexDireciton] -> Int
day11b = maximum . map (distance UnboundedHexGrid (0,0)) . scanl step (0,0)

foldl gives us the final position, but scanl gives us the intermediate ones. We just map our distance function onto all of the intermediate positions to get a list of intermediate distances, and take the maximum of those.

The most time consuming part was probably writing the parsing function:

parse :: String -> [HexDirection]
parse = map (parseDir . filter isAlpha) . splitOn ","
  where
    parseDir = \case
      "nw" -> Northwest
      "n"  -> North
      "ne" -> Northeast
      "se" -> Southeast
      "s"  -> South
      "sw" -> Southwest
      d    -> error $ "Bad direction " ++ d

Much thanks to Amy de Buitléir for the library, which does most of the heavy lifting :)

Day 11 Benchmarks

>> Day 11a
benchmarking...
time                 6.331 ms   (5.971 ms .. 6.778 ms)
                     0.960 R²   (0.917 R² .. 0.992 R²)
mean                 6.974 ms   (6.444 ms .. 8.575 ms)
std dev              2.855 ms   (528.3 μs .. 5.360 ms)
variance introduced by outliers: 97% (severely inflated)

>> Day 11b
benchmarking...
time                 7.267 ms   (7.017 ms .. 7.503 ms)
                     0.988 R²   (0.976 R² .. 0.995 R²)
mean                 7.337 ms   (7.172 ms .. 7.586 ms)
std dev              563.7 μs   (392.0 μs .. 794.2 μs)
variance introduced by outliers: 44% (moderately inflated)

Day 12

(code)

For Day 12, I made a monoid that is collection of disjoint sets, which we use to model the set of distinct "groups" in our puzzle. The sets represent things that are all interconnected.

newtype Disjoints = D { getD :: S.Set IS.IntSet }
instance Monoid Disjoints where
    mempty        = D S.empty
    mappend xs ys = foldl' go ys (getD xs)
      where
        go (D zs) z = D (newGroup `S.insert` disjoints)
          where
            overlaps  = S.filter (not . IS.null . (`IS.intersection` z)) zs
            disjoints = zs `S.difference` overlaps
            newGroup  = IS.unions $ z : S.toList overlaps

The mappend action is union, but preserving disjoint connection property. If we assume that all items in a set are connected, then the merger of two collections of disjoint groups will be a new collection of disjoint groups, merging together any of the original sets if it is found out that their items have any connections.

For example, merging DG [[3,5],[8,9],[10,11]] with DG [[5,6,8]] will give DG [[3,5,6,8,9], [10,11]].

Now our entire thing is just a foldMap. If we treat each of the original lines as IS.IntSet, a set of connected things:

build :: [IS.IntSet] -> Disjoints
build = foldMap (D . S.singleton)

where D . S.singleton :: IS.IntSet -> Disjoints, the "single group" Disjoints.

From here, querying for the size of the group containing 0, and the number of groups total, is pretty simple:

day12a :: [IS.IntSet] -> Int
day12a = IS.size . fromJust
       . find (0 `IS.member`)
       . getD . build

day12b :: [IS.IntSet] -> Int
day12b = S.size . getD . build

Part 2 is even simpler than Part 1!

Parsing is again straightforward:

parseLine :: String -> IS.IntSet
parseLine (words->n:_:ns) = IS.fromList $ read n
                                        : map (read . filter isDigit) ns
parseLine _               = error "No parse"

parse :: String -> [IS.IntSet]
parse = map parseLine . lines

Day 12 Benchmarks

>> Day 12a
benchmarking...
time                 53.76 ms   (44.69 ms .. 59.42 ms)
                     0.961 R²   (0.859 R² .. 0.999 R²)
mean                 58.32 ms   (54.25 ms .. 73.01 ms)
std dev              12.51 ms   (1.563 ms .. 21.58 ms)
variance introduced by outliers: 73% (severely inflated)

>> Day 12b
benchmarking...
time                 51.23 ms   (44.52 ms .. 55.72 ms)
                     0.973 R²   (0.925 R² .. 0.998 R²)
mean                 59.26 ms   (54.50 ms .. 76.39 ms)
std dev              15.13 ms   (3.328 ms .. 26.23 ms)
variance introduced by outliers: 82% (severely inflated)

Day 13

(code)

Day 13 is a puzzle that reveals itself nicely after putting in a moment to think of some analytic solutions.

The motion of the scanners follows a Triangle Wave. I picked up the equation on the wikipedia page:

triangle range t = abs ((t - range) `mod` (range * 2) - range)

This is a triangle wave starting at zero, that goes from 0 to range.

It's probably not the cleanest solution, but it works ok as a direct translation! We also don't need the abs, since we only care about when triangle range t == 0, but it doesn't hurt to leave it there for clarity.

Now we can write a function to see if you are caught at a given depth and range:

caughtAt
    :: Int          -- delay
    -> (Int, Int)   -- depth, range
    -> Bool
caughtAt delay (d, r) = triangle (r - 1) (d + delay) == 0

Our range is actually one less than triangle's expected range (we travel from 0 to r-1). And, t is depth + delay. That is, if our initial delay is 0, then t = depth -- it will take us depth picoseconds to get to that given depth. In general, it will take us depth + delay picoseconds to get to a given depth -- a contribution from waiting to start, and a contribution from the time it will take to actually reach that depth once we start.

Day 13 Benchmarks

>> Day 13a
benchmarking...
time                 211.9 μs   (202.1 μs .. 222.9 μs)
                     0.976 R²   (0.959 R² .. 0.992 R²)
mean                 211.3 μs   (204.7 μs .. 222.9 μs)
std dev              29.80 μs   (19.13 μs .. 47.19 μs)
variance introduced by outliers: 89% (severely inflated)

>> Day 13b
benchmarking...
time                 192.1 ms   (188.2 ms .. 197.3 ms)
                     0.999 R²   (0.999 R² .. 1.000 R²)
mean                 197.0 ms   (195.0 ms .. 199.7 ms)
std dev              3.138 ms   (1.944 ms .. 4.778 ms)
variance introduced by outliers: 14% (moderately inflated)

Day 14

(code)

Part 1 is a simple application of the "knot hash" function we wrote: different inputs. We can make a row of a grid by running knothash :: String -> [Word8] on the seed, using printf to format things as a binary string, and then using map (== '1') to convert our binary string into a list of Bools. These represent a list of "on" or "off" cells.

mkRow :: String -> Int -> [Bool]
mkRow seed n = map (== '1') . concatMap (printf "%08b") . knothash
             $ seed ++ "-" ++ show n

Our grid is then just running this function for every row, to get a grid of on/off cells:

mkGrid :: String -> [[Bool]]
mkGrid seed = map (mkRow seed) [0..127]

The actual challenge is then just counting all of the Trues:

day14a :: String -> Int
day14a = length . filter id . concat . mkGrid

For Part 2, we can actually re-use the same Disjoints monoid that we used for Day 12. We'll just add in sets of neighboring lit points, and count how many disjoint sets come out at the end.

We're going to leverage Data.Ix, to let us enumerate over all cells in a grid with range :: ((Int, Int), (Int, Int)) -> [(Int, Int)]. Data.Ix also gives us index :: (Int, Int) -> Int, which allows us to "encode" a coordinate as an Int, so we can use it with the IntSet that we wrote earlier. (You could just as easily use a Set (Int, Int) instead of an IntSet under index, but it's significantly less performant)

litGroups :: [[Bool]] -> Disjoints
litGroups grid = foldMap go (range r)
  where
    r = ((0,0),(127,127))
    isLit (x,y) = grid !! y !! x
    go p | isLit p   = D . S.singleton . IS.fromList
                     . map (index r) . (p:) . filter isLit
                     $ neighbors p
         | otherwise = mempty

neighbors :: (Int, Int) -> [(Int, Int)]
neighbors (x,y) = [ (x+dx, y+dy) | (dx, dy) <- [(0,1),(0,-1),(1,0),(-1,0)]
                                 , inBounds (x + dx) && inBounds (y + dy)
                  ]
  where
    inBounds z = z >= 0 && z < 128

So part 2 is just running litGroups and counting the resulting number of disjoint groups:

day14b :: String -> Int
day14b = S.size . getD . litGroups . mkGrid

Day 14 Benchmarks

>> Day 14a
benchmarking...
time                 1.085 s    (946.8 ms .. 1.171 s)
                     0.998 R²   (0.996 R² .. 1.000 R²)
mean                 1.105 s    (1.077 s .. 1.119 s)
std dev              24.32 ms   (0.0 s .. 25.04 ms)
variance introduced by outliers: 19% (moderately inflated)

>> Day 14b
benchmarking...
time                 1.358 s    (1.290 s .. 1.450 s)
                     0.999 R²   (0.998 R² .. 1.000 R²)
mean                 1.321 s    (1.306 s .. 1.333 s)
std dev              18.95 ms   (0.0 s .. 20.79 ms)
variance introduced by outliers: 19% (moderately inflated)

Day 15

(code)

This one is a really "easy" one from a Haskell perspective. We can just generate the outputs of each stream as an infinite lazily linked list, take the number of items we need, and count the pairs that match a specific predicate.

In particular, the predicate we care about is whether or not two items have the same final 16 bits. This is the same as checking if two integers have value when converted to Word16's (16-bit words).

The generating function, given a "factor" and a "seed", is:

generate :: Int -> Int -> Int
generate fac = (`mod` 2147483647) . (* fac)

We can then just generate them infinitely (using iterate and an initial seed), zip the two streams together, take the first 40000000 items, filter for the ones where the two items match, and count the length of the resulting list.

match :: Int -> Int -> Bool
match = (==) @Word16 `on` fromIntegral

day15a :: Int -> Int -> Int
day15a seedA seedB = length
                   . filter (uncurry match)
                   . take 4e7
                   $ zip (iterate (generate 16807) seedA)
                         (iterate (generate 48271) seedB)

Part 2 is pretty much the same thing, except we filter for things that are divisible by 4 in the first list, and things that are divisible by 8 in the second list. To gain the "asynchronous" behavior that the problem is asking for, we have to do this on the lists before they are zipped. That way, all zip ever sees (and pairs) are the pre-filtered lists.

divBy :: Int -> Int -> Bool
x `divBy` b = x `mod` b == 0

day15b :: Int -> Int -> Int
day15b seedA seedB = length
                   . filter (uncurry match)
                   . take 5e6
                   $ zip (filter (`divBy` 4) . iterate (generate 16807) $ seedA)
                         (filter (`divBy` 8) . iterate (generate 48271) $ seedB)

All in all a very nice "functional" problem with a functional solution :)

Parsing is basically finding the seeds as the only numeric values on each line:

parse :: String -> (Int, Int)
parse inp = (a, b)
  where
    a:b:_ = read . filter isDigit <$> lines inp

Day 15 Benchmarks

>> Day 15a
benchmarking...
time                 2.443 s    (2.409 s .. 2.506 s)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 2.413 s    (2.404 s .. 2.422 s)
std dev              15.09 ms   (0.0 s .. 15.61 ms)
variance introduced by outliers: 19% (moderately inflated)

>> Day 15b
benchmarking...
time                 952.2 ms   (839.4 ms .. 1.054 s)
                     0.998 R²   (0.996 R² .. 1.000 R²)
mean                 967.0 ms   (944.7 ms .. 984.5 ms)
std dev              27.27 ms   (0.0 s .. 30.41 ms)
variance introduced by outliers: 19% (moderately inflated)

Day 16

(code)

Day 16 was one of my favorites! It was what prompted this joyful tweet:

Your friends: Group theory is nice but it's it'll never be useful for programming.

#adventofcode: "You come upon a very unusual sight; a group of programs here appear to be dancing..."

One thing you can notice is that you can basically collect all of the swaps/permutations separately, and then all of the renaming separately, and then apply them separately. They really exist on different "planes", so to speak.

That being said, we can make a data structure that represents a permutation:

newtype Perm a = P { permMap :: M.Map a a }
    deriving Show

lookupPerm :: Ord a => Perm a -> a -> a
lookupPerm p k = M.findWithDefault k k (permMap p)

Where a Map like M.fromList [(1,3),(3,4),(4,1)] would turn the list [1,2,3,4,5] to [3,2,4,1,5] ("move 3 to 1, 4 to 3, etc."). "Following" a permutation is done using lookupPerm -- lookupPerm for the example permutation with 1 would give 3., on 5 would give 5, etc.

Perm is a Monoid, where <> is composing/sequencing permutations, and mempty is the identity permutation:

instance Ord a => Semigroup (Perm a) where
    x <> y = P $ (lookupPerm x <$> permMap y) `M.union` permMap x
instance Ord a => Monoid (Perm a) where
    mappend = (<>)
    mempty  = P M.empty

A full description of a dance is then just a collection of shufflings and a collection of renamings:

type Dance = (Perm Int, Dual (Perm Char))

We use Dual (Perm Char) to describe the renamings because renamings compose in the opposite direction of shuffles. Dual is a newtype wrapper that gives a new Monoid instance where <> is backwards (mappend (Dual x) (Dual y) = Dual (mappend y x))

Because of the Monoid instance of tuples, Dance is a Monoid, where composing dances is composing the two permutations.

We can "apply" a Dance:

runDance :: Dance -> String
runDance (pI, pN) = lookupPerm (getDual pN)
                  . toName
                  . lookupPerm pI
                <$> [0..15]
  where
    toName c = chr (c + ord 'a')

Which is, for all of the slots in our domain ([1..15]), we follow pI (the shuffles), assign them their proper names (with toName), and follow pN (the renamings).

From here, we can write a function to parse a single dance move:

parseMove :: String -> Dance
parseMove = \case
    's':(read->n)                     -> (rotator n  , mempty            )
    'x':(map read.splitOn "/"->n:m:_) -> (swapper n m, mempty            )
    'p':n:_:m:_                       -> (mempty     , Dual (swapper n m))
    _                                 -> error "No parse"
  where
    rotator :: Int -> Perm Int
    rotator n = P $ M.fromList [ (i, (i - n) `mod` 16) | i <- [0..15] ]
    swapper :: Ord a => a -> a -> Perm a
    swapper x y = P $ M.fromList [ (x, y), (y, x) ]

And then foldMap it on all of the lines:

parse :: String -> Dance
parse = foldMap parseMove . splitOn ","

foldMap :: (String -> Dance) -> [String] -> Dance maps our parsing function to create a bunch of Dances, and then folds/composes them all together.

So that's basically just part 1!

day16a :: String -> String
day16a = runDance . parse

Part 2 we can use stimes :: Semigroup m => Int -> m -> m, which does efficient exponentiation-by-squaring. If we use stimes 1000000000, it'll compose the same item with itself one billion times by only doing about 30 composition operations. This makes Part 2 doable in reasonable time:

day16b :: String -> String
day16b = runDance . stimes 1e9 . parse

If we naively "ran" the dance over and over again, we'd have to do one billion operations. However, using smart exponentiation-by-squaring with stimes, we do the same thing with only about 30 operations!

Day 16 Benchmarks

>> Day 16a
benchmarking...
time                 108.7 ms   (103.4 ms .. 113.0 ms)
                     0.993 R²   (0.969 R² .. 1.000 R²)
mean                 106.8 ms   (104.3 ms .. 111.9 ms)
std dev              5.427 ms   (2.202 ms .. 8.277 ms)
variance introduced by outliers: 10% (moderately inflated)

>> Day 16b
benchmarking...
time                 106.4 ms   (90.12 ms .. 117.4 ms)
                     0.982 R²   (0.961 R² .. 0.999 R²)
mean                 116.3 ms   (109.2 ms .. 136.4 ms)
std dev              17.04 ms   (3.190 ms .. 25.59 ms)
variance introduced by outliers: 48% (moderately inflated)

Day 17

(code)

For Day 17 I used Tape again -- for the O(1) insertions. (Even though moving around is amortized O(n)).

data Tape a = Tape { _tLefts  :: [a]
                   , _tFocus  :: a
                   , _tRights :: [a]
                   }
  deriving Show

unshift :: a -> Tape a -> Tape a
unshift y (Tape ls x rs) = Tape (x:ls) y rs

moveRight :: Tape a -> Tape a
moveRight (Tape ls x rs) = case rs of
    []    -> let l :| ls' = NE.reverse (x :| ls)
             in  Tape [] l ls'
    r:rs' -> Tape (x:ls) r rs'

The only difference between this motion and the previous motion is the periodic boundary conditions of tape motion. Before, if we went past the edge of the tape, we'd return Nothing. Here, however, we want to "cycle" around, so we reverse the left-hand list and move our focus to the last item in the list.

With that in mind, we can write our stepping function:

step :: Int -> Tape a -> a -> Tape a
step n t0 x = unshift x . moveC n $ t0

We expect the number of steps to take, the initial tape, and the item to add. This will cycle the tape the given number of steps and then insert the desired item.

Part 1 is then just applying this as a foldl:

day17a :: Int -> Int
day17a n = head . _tRights
         $ foldl' (step n) (Tape [] 0 []) [1 .. 2017]

Part 2 can't really be done by iterating this process 50 million times. One thing we can leverage is the fact that since 0 is there from the beginning (at position 0), we only need to keep track of all the items that are ever inserted at position 1:

day17b :: Int -> Int
day17b n = last
         . elemIndices @Int 1
         $ scanl jump 0 [1 .. 5e7]
  where
    jump i x = ((i + n) `mod` x) + 1

At each step, we "jump" the n steps from the current position, being sure to mod by the current size of the tape. scanl then gives us the position of the cursor for all points in our process. We then find all of the positions where the function jumps to 1 using elemIndices, and find the last one.

Day 17 Benchmarks

>> Day 17a
benchmarking...
time                 18.38 ms   (15.25 ms .. 21.37 ms)
                     0.910 R²   (0.855 R² .. 0.972 R²)
mean                 23.24 ms   (20.33 ms .. 33.50 ms)
std dev              11.62 ms   (2.391 ms .. 21.67 ms)
variance introduced by outliers: 95% (severely inflated)

>> Day 17b
benchmarking...
time                 747.6 ms   (694.3 ms .. 881.0 ms)
                     0.996 R²   (0.986 R² .. 1.000 R²)
mean                 771.3 ms   (749.1 ms .. 809.6 ms)
std dev              33.29 ms   (0.0 s .. 34.91 ms)
variance introduced by outliers: 19% (moderately inflated)

Day 18

(code)

Day 18 Benchmarks

>> Day 18a
benchmarking...
time                 450.8 μs   (393.3 μs .. 540.9 μs)
                     0.898 R²   (0.849 R² .. 0.992 R²)
mean                 426.0 μs   (403.0 μs .. 476.6 μs)
std dev              102.4 μs   (39.56 μs .. 179.0 μs)
variance introduced by outliers: 95% (severely inflated)

>> Day 18b
benchmarking...
time                 232.5 ms   (208.6 ms .. 252.2 ms)
                     0.991 R²   (0.962 R² .. 1.000 R²)
mean                 232.9 ms   (224.5 ms .. 240.3 ms)
std dev              10.83 ms   (7.343 ms .. 13.68 ms)
variance introduced by outliers: 14% (moderately inflated)

Day 19

(code)

Ever since discovering how fun many is in Day 18, I felt inspired to abuse it again in Day 19.

In Day 19 we can use the search monad, [], and combine it with StateT to make what I call the "effectful search" monad, StateT s []. I go over this a bit in an old blog post of mine. An action in StateT s [] is an exploration down several paths, where each step could modify an internal s state kept during the search.

In our case we are going to be searching through the cells of a grid, and our state will be our current position and previous position.

I'm going to be using the linear library's V2 Int type to represent a point, mostly because it gives us a Num instance we can use (to add and subtract points).

Any, here is our single search step:

type Grid  = V.Vector (V.Vector Char)
type Point = L.V2 Int

neighborsOf :: Point -> [Point]
neighborsOf p0 = (+ p0) <$> [ L.V2 0 1, L.V2 0 (-1), L.V2 1 0, L.V2 (-1) 0 ]

follow :: Grid -> StateT (Point, Point) [] Char
follow g = get >>= \(p0, p1) -> do      -- last position, current position
    Just currChar <- return $ gridAt p1
    p2 <- case currChar of
        '+' -> lift $ neighbors p1
        _   -> return $ p1 + (p1 - p0)
    Just nextChar <- return $ gridAt p2
    guard $ p2       /= p0
    guard $ nextChar /= ' '
    put (p1, p2)
    return nextChar
  where
    gridAt (L.V2 x y) = (V.!? x) =<< g V.!? y

At each step, we:

  1. Get our current position
  2. Lookup the character at that position, which might fail if the coordinate is not in our grid. If it fails, close off this branch.
  3. If it succeeds, fork into a branch for every potential new point:
    • If the current character is '+', we need to turn! Fork off a new branch for every direction/neighbor.
    • If the current character is anything else, we just move in a straight line. Continue down one single branch with the new next point, in straight-line fashion. (Thanks, Verlet)
  4. Get the character at the new position. Kill off the fork if the new character is out of bounds.
  5. Now kill off the current fork if:
    • The new point is our previous location. We don't want to go backwards.
    • The new character is a blank line. This means we reached a dead end.
  6. If we're still alive, update our state.
  7. Return the new character!

And that's it! One step!

And now, we can repeat this single step multiple times until we fail, using many :: Alternative f => f a -> f [a]. many will repeat the step as many times as possible, collect all of the results, and return them in a list. If we many (follow g), we repeat follow g until we reach a dead end, and then return all of the Chars that follow g emitted along the way.

followToTheEnd :: Grid -> StateT (Point, Point) [] String
followToTheEnd g = ('|':) <$> many (follow g)

We add ('|':) to the beginning of the result so we can account for the first position's character.

And that's our full Day 19. We can use evalStateT :: StateT (Point, Point) [] a -> (Point, Point) -> [a], to get all of the successful paths (paths that are followed to the end, using many in our case). We get the first result using head. The result is a list of all characters emitted by the successful path.

day19 :: Grid -> [Char]
day19 g = head . flip evalStateT p0 $ followToTheEnd g
  where
    p0      = (L.V2 x0 (-1), L.V2 x0 0)
    Just x0 = V.elemIndex '|' (g V.! 0)

Now all that is left is parsing and extracting the answers.

day19a :: String -> String
day19a = filter isAlpha . day19 . parse

day19b :: String -> Int
day19b = length . day19 . parse

parse :: String -> V.Vector (V.Vector Char)
parse = V.fromList . map V.fromList . lines

Day 19 Benchmarks

>> Day 19a
benchmarking...
time                 31.26 ms   (30.37 ms .. 31.99 ms)
                     0.993 R²   (0.978 R² .. 0.999 R²)
mean                 31.22 ms   (30.63 ms .. 32.06 ms)
std dev              1.569 ms   (661.8 μs .. 2.179 ms)
variance introduced by outliers: 17% (moderately inflated)

>> Day 19b
benchmarking...
time                 28.87 ms   (13.57 ms .. 37.24 ms)
                     0.598 R²   (0.127 R² .. 0.898 R²)
mean                 47.90 ms   (38.97 ms .. 60.18 ms)
std dev              19.34 ms   (13.19 ms .. 27.93 ms)
variance introduced by outliers: 92% (severely inflated)

Day 20

(code)

Day 20 starts out as a simple physics simulator/numerical integrator:

type Point = L.V3 Int

data Particle a = P { _pAcc :: !a
                    , _pVel :: !a
                    , _pPos :: !a
                    }
  deriving (Functor, Foldable, Traversable, Show, Eq, Ord)

type System = [Particle Point]

Using the linear package again, for V3, a 3-vector. It's also convenient to decide a Particle to contain a description of its acceleration, velocity, and position. Our whole system will be a list of Particle Points. Note that we parameterize Particle so that we can give useful higher-kinded instances like Functor and Traversable.

Stepping the simulation ends up being just stepping every particle. Interestingly enough, we can actually use scanl (+) 0 (for Traversable) to do the integration step:

-- | scanl generalized to work on all Traversable
scanlT :: Traversable t => (b -> a -> b) -> b -> t a -> t b
scanlT = -- implementatation left as exercise, but I really wish this was
         -- already in base :|

step :: Num a => Particle a -> Particle a
step = scanlT (+) 0

This is because it replaces _pAcc with 0 + _pAcc, and then it replaces _pVel with 0 + _pAcc + _pVel, and then finally replaces _pPos with 0 + _pAcc + _pVel + _pPos -- just like the problem asks!

For part 1, we can just map step a System several points, and then find closest point:

norm :: Point -> Int
norm = sum . fmap abs

day20a :: System -> Int
day20a = V.minIndex . V.fromList    -- hijacking minIndex from Vector
       . map (norm . _pPos)
       . (!! 1000)
       . iterate (map step)

However, we are really just looking for the asymptotic behavior. In the long run, the distance is dominated by the |a| t^2 term, so we really just need to look for the particle with the highest normed initial acceleration.

day20a :: System -> Int
day20a = V.minIndex . V.fromList
       . (map . fmap) norm      -- [Particle Point] -> [Particle Int]
       . parse

The Ord instance of Particle Int is such that it sorts first by the _pAcc field, then the _pVel field, then the _pPos field. So it'll find first the highest normed acceleration, and break ties using the highest normed velocity. However, this tie breaking isn't actually sound -- there are situations where this won't be true. However, there were no ties in my data set so this method was ok :)

For part 2, we can define a function that takes out all "duplicated" points, using a frequency map and filtering for frequencies greater than 1:

collide :: System -> System
collide s0 = filter ((`S.notMember` collisions) . _pPos) s0
  where
    collisions :: S.Set Point
    collisions = M.keysSet . M.filter @Int (> 1)
               . M.fromListWith (+)
               . map ((,1) . _pPos)
               $ toList s0

Now we just iterate collide . map step.

We can pick the thousandth element again, like we might have for part 1. However, we can be a little smart with a stopping condition:

day20b :: Challenge
day20b = show . length . fromJust . find stop
       . iterate (collide . map step)
       . parse
  where
    stop = (> 1000) . minimum . map (norm . _sPos)

Here, we iterate until the particle closest to the origin is greater than a 1000-cube away from the origin. Essentially, this is waiting until all of the points clear a 2000-wide cube around the origin. Thinking about the input, there will be some particles that start out near the origin and start heading towards the origin. This condition will wait until the last of those particles exits the origin cube, and check for the number of collisions then.

Parsing

We can parse into System using really silly view patterns :)

parse :: String -> System
parse = map parseLine . lines
  where
    parseLine :: String -> Particle Point
    parseLine (map(read.filter num).splitOn","->[pX,pY,pZ,vX,vY,vZ,aX,aY,aZ])
                = P { _pAcc = L.V3 aX aY aZ
                    , _pVel = L.V3 vX vY vZ
                    , _pPos = L.V3 pX pY pZ
                    }
    parseLine _ = error "No parse"
    num :: Char -> Bool
    num c = isDigit c || c == '-'

Day 20 Benchmarks

>> Day 20a
benchmarking...
time                 29.87 ms   (28.16 ms .. 32.18 ms)
                     0.989 R²   (0.979 R² .. 0.997 R²)
mean                 33.94 ms   (32.33 ms .. 38.26 ms)
std dev              5.085 ms   (1.678 ms .. 8.683 ms)
variance introduced by outliers: 61% (severely inflated)

>> Day 20b
benchmarking...
time                 67.18 ms   (64.33 ms .. 72.99 ms)
                     0.990 R²   (0.975 R² .. 0.998 R²)
mean                 66.90 ms   (64.83 ms .. 68.67 ms)
std dev              3.437 ms   (2.439 ms .. 4.727 ms)
variance introduced by outliers: 16% (moderately inflated)

Day 21

(code)

Day 21 Benchmarks

>> Day 21a
benchmarking...
time                 2.169 ms   (2.056 ms .. 2.335 ms)
                     0.911 R²   (0.796 R² .. 0.996 R²)
mean                 2.235 ms   (2.138 ms .. 2.621 ms)
std dev              477.3 μs   (184.0 μs .. 1.054 ms)
variance introduced by outliers: 90% (severely inflated)

>> Day 21b
benchmarking...
time                 3.833 s    (3.540 s .. 4.438 s)
                     0.997 R²   (0.994 R² .. 1.000 R²)
mean                 3.764 s    (3.678 s .. 3.868 s)
std dev              96.29 ms   (0.0 s .. 109.8 ms)
variance introduced by outliers: 19% (moderately inflated)

Day 22

(code)

Day 22 Benchmarks

>> Day 22a
benchmarking...
time                 6.036 ms   (5.771 ms .. 6.360 ms)
                     0.975 R²   (0.951 R² .. 0.991 R²)
mean                 6.102 ms   (5.916 ms .. 6.364 ms)
std dev              704.9 μs   (467.2 μs .. 1.074 ms)
variance introduced by outliers: 67% (severely inflated)

>> Day 22b
benchmarking...
time                 7.825 s    (7.623 s .. 8.054 s)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 7.786 s    (7.750 s .. 7.815 s)
std dev              47.35 ms   (0.0 s .. 51.70 ms)
variance introduced by outliers: 19% (moderately inflated)

Day 23

(code)

Day 23 Benchmarks

>> Day 23a
benchmarking...
time                 87.32 ms   (81.75 ms .. 92.92 ms)
                     0.991 R²   (0.974 R² .. 0.998 R²)
mean                 86.94 ms   (84.60 ms .. 90.52 ms)
std dev              4.436 ms   (3.076 ms .. 6.214 ms)

>> Day 23b
benchmarking...
time                 5.983 ms   (5.436 ms .. 6.836 ms)
                     0.897 R²   (0.814 R² .. 0.990 R²)
mean                 5.757 ms   (5.527 ms .. 6.383 ms)
std dev              976.3 μs   (413.1 μs .. 1.700 ms)
variance introduced by outliers: 81% (severely inflated)

Day 24

(code)

Day 24 Benchmarks

>> Day 24a
benchmarking...
time                 1.681 s    (1.570 s .. 1.743 s)
                     0.999 R²   (0.999 R² .. 1.000 R²)
mean                 1.673 s    (1.653 s .. 1.686 s)
std dev              19.25 ms   (0.0 s .. 22.18 ms)
variance introduced by outliers: 19% (moderately inflated)

>> Day 24b
benchmarking...
time                 1.795 s    (1.661 s .. NaN s)
                     0.999 R²   (0.997 R² .. 1.000 R²)
mean                 1.828 s    (1.794 s .. 1.850 s)
std dev              33.11 ms   (0.0 s .. 38.19 ms)
variance introduced by outliers: 19% (moderately inflated)

Day 25

(code)

Day 25 Benchmarks

>> Day 25a
benchmarking...
time                 2.648 s    (2.510 s .. 2.834 s)
                     0.999 R²   (0.998 R² .. 1.000 R²)
mean                 2.643 s    (2.607 s .. 2.668 s)
std dev              38.04 ms   (0.0 s .. 43.77 ms)
variance introduced by outliers: 19% (moderately inflated)