Skip to content

Reflections 2019

Jump to bottom
github-actions[bot] edited this page Jan 2, 2025 · 7 revisions

2016 / 2018 / 2019 / 2020 / 2021 / 2022 / 2023 / 2024

Table of Contents

Day 1

Top / Prompt / Code / Standalone

Haskell has a history of making Day 1's seem trivial :) In this case it's a straightforward map:

fuel :: Int -> Int
fuel = subtract 2 . (`div` 3)

part1 :: [Int] -> Int
part1 = sum . map fuel

part2 :: [Int] -> Int
part2 = sum . map (sum . drop 1 . takeWhile (>= 0) . iterate fuel)

These can be parsed with map read . lines!

I accidentally forgot the drop 1 the first time I submitted, so I hit the cooldown. Teaches me to remember to test all my answers next time :)

Day 1 Benchmarks

>> Day 01a
benchmarking...
time                 682.7 ns   (679.6 ns .. 687.0 ns)
                     1.000 R²   (0.999 R² .. 1.000 R²)
mean                 689.7 ns   (684.7 ns .. 694.7 ns)
std dev              17.74 ns   (13.38 ns .. 21.00 ns)
variance introduced by outliers: 35% (moderately inflated)

* parsing and formatting times excluded

>> Day 01b
benchmarking...
time                 12.59 μs   (12.57 μs .. 12.60 μs)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 12.59 μs   (12.58 μs .. 12.61 μs)
std dev              51.02 ns   (41.85 ns .. 60.27 ns)

* parsing and formatting times excluded

Day 2

Top / Prompt / Code / Standalone

So the bytecode/VM problems start day 2 this year, eh?

This one was also pretty straightforward. For these types of problems, I like to use Data.IntMap or Data.Sequence for the memory, since they both have O(log n) indexing. Data.Sequence is the better choice here because it's basically IntMap with the indices (0, 1, 2 ...) automatically given for us :)

I usually use Data.Sequence instead of Data.Vector because it has a better story when you want to change the length (by adding or removing elements): Data.Vector is very bad, unless you have some sort of amortized abstraction. However, in this case we don't ever change the length, so Data.Vector is technically just as good here :)

So parsing:

import           Data.List.Split (splitOn)
import           Data.Sequence (Seq(..))
import qualified Data.Sequence as Seq

type Memory = (Int, Seq Int)

parse :: String -> Memory
parse = (0,) . Seq.fromList . map read . splitOn ","

We write our stepping function:

step :: Memory -> Maybe Memory
step (p, r) = do
    o <- Seq.lookup p r >>= \case
      1 -> pure (+)
      2 -> pure (*)
      _ -> empty
    [a, b, c] <- traverse (`Seq.lookup` r) [p+1 .. p+3]
    [y, z]    <- traverse (`Seq.lookup` r) [a,b]
    pure (p + 4, Seq.update c (o y z) r)

And away we go!

runProg :: Memory -> Maybe Int
runProg m@(_,r) = case step m of
  Nothing -> Seq.lookup 0 r
  Just m' -> runProg m'

part1 :: String -> Maybe Int
part1 str = runProg (p, r')
  where
    (p,r) = parse str
    r'    = Seq.update 1 12 . Seq.update 2 2 $ r

For part 2 we can just do a brute force search

part2 :: String -> Maybe (Int, Int)
part2 str = listToMaybe
    [ (noun, verb)
    | noun <- [0..99]
    , verb <- [0..99]
    , let r' = Seq.update 1 noun . Seq.update 2 verb $ r
    , runProg (p, r') == Just 19690720
    ]
  where
    (p, r) = parse str

This doesn't take too long on my machine! But for my actual solution, I actually used a binary search (that I had coded up for last year). I noticed that noun increases the answer by a lot, and verb increases it by a little, so by doing an binary search on noun, then an binary search on verb, you can get a good answer pretty quickly. My part 2 time (470 μs) is only twice as long as my part 1 time (260 μs) with the binary search. Happy that some prep time paid off :)

part2' :: String -> Maybe (Int, Int)
part2' str =  do
    noun <- binaryMinSearch (\i ->
        runProg (p, Seq.update 1 (i + 1) r) > Just moon
      ) 0 99
    let r' = Seq.update 1 noun r
    verb <- binaryMinSearch (\i ->
        runProg (p, Seq.update 2 (i + 1) r) > Just moon
      ) 0 99
    pure (noun, verb)
  where
    moon = 19690720
    (p, r) = parse str

This gets us an O(log n) search instead of an O(n^2) search, cutting down times pretty nicely.

Just for the same of completion, I'm including my implementation of binaryMinSearch here. It's tucked away in my utilities/common functionality file normally!

-- | Find the lowest value where the predicate is satisfied within the
-- given bounds.
binaryMinSearch
    :: (Int -> Bool)
    -> Int                  -- ^ min
    -> Int                  -- ^ max
    -> Maybe Int
binaryMinSearch p = go
  where
    go !x !y
        | x == mid || y == mid = Just (x + 1)
        | p mid                = go x mid
        | otherwise            = go mid y
      where
        mid = ((y - x) `div` 2) + x

Day 2 Benchmarks

>> Day 02a
benchmarking...
time                 53.46 μs   (53.32 μs .. 53.59 μs)
                     0.999 R²   (0.998 R² .. 1.000 R²)
mean                 54.31 μs   (53.48 μs .. 57.59 μs)
std dev              5.344 μs   (148.8 ns .. 11.36 μs)
variance introduced by outliers: 83% (severely inflated)

* parsing and formatting times excluded

>> Day 02b
benchmarking...
time                 753.1 μs   (751.6 μs .. 754.4 μs)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 752.5 μs   (751.6 μs .. 753.3 μs)
std dev              2.619 μs   (2.210 μs .. 3.047 μs)

* parsing and formatting times excluded

Day 3

Top / Prompt / Code / Standalone

As another data processing one, I feel like this might be another win for Haskell as well :) My part 2 leaderboard position was much higher than my part1 position --- my suspicion is that the new twist made it difficult for imperative coders, but the twist was naturally handled in the Haskell case.

First off, I'm going to parse the path not as a series of directions and numbers, but rather as a list of each individual step to take. This was similar to my approach for 2016 Day 1. I'm using my favorite type for describing points, V2, because it has a really useful Num instance to support addition of points.

import           Data.List.Split
import           Linear.V2

parsePath :: String -> [V2 Int]
parsePath = concatMap parsePoint . splitOn ","
  where
    parsePoint (d:ns) = replicate (read ns) $ case d of
      'U' -> V2   0    1
      'R' -> V2   1    0
      'D' -> V2   0  (-1)
      'L' -> V2 (-1)   0
    parsePoint _      = []

Now, our list of points is simply a cumulative sum, which comes from our best friend scanl' (and family). We use scanl1 to get the running sum of all the direction pieces, and get the set of all points.

visited :: [V2 Int] -> Set (V2 Int)
visited = S.fromList . scanl1 (+)

Now Part 1 is:

part1 :: String -> Int
part1 str = minimum (S.map mannDist (S.intersection xs ys))
  where
    [xs, ys] = map (visited . parsePath) (lines str)
    mannDist (V2 x y) = abs x + abs y

Once we get the intersection (the set of points that are visited by both), we can map the mannDist over each intersection and find the minimum.

Part 2 adds an "extra twist", in that now we also want to keep track of the time it takes to reach each point. This requires only a small tweak to visited:

visited2 :: [V2 Int] -> Map (V2 Int) Int
visited2 = M.fromListWith min        -- turn it into a map, keeping first seen
         . flip zip [1..]            -- list of (sum, time taken)
         . scanl1 (+)                -- running sum

We pair each item in the running sum with the time taken, and so get a map of points seen to time taken to get to that point. We make sure to use M.fromListWith min so that we keep the lowest time at each point.

Part 2 is very similar, then:

part2 :: String -> Int
part2 str = minimum (M.intersectionWith (+) xs ys)
  where
    [xs, ys] = map (visited2 . parsePath) (lines str)

Using M.intersectionWith (+) instead of S.intersection, because we want the map that has the same keys in both paths, while adding together the times at each key.

Note that we can actually solve part1 using visited2 instead of visited...because we can "forget" the values in a Map (V2 Int) Int by using M.keysSet :: Map k a -> Set k.

Day 3 Benchmarks

>> Day 03a
benchmarking...
time                 137.9 ms   (135.5 ms .. 141.9 ms)
                     0.999 R²   (0.998 R² .. 1.000 R²)
mean                 138.2 ms   (136.7 ms .. 139.6 ms)
std dev              2.360 ms   (1.561 ms .. 3.453 ms)
variance introduced by outliers: 11% (moderately inflated)

* parsing and formatting times excluded

>> Day 03b
benchmarking...
time                 136.8 ms   (134.5 ms .. 141.5 ms)
                     0.999 R²   (0.997 R² .. 1.000 R²)
mean                 139.9 ms   (137.0 ms .. 148.4 ms)
std dev              6.852 ms   (1.930 ms .. 11.10 ms)
variance introduced by outliers: 11% (moderately inflated)

* parsing and formatting times excluded

Day 4

Top / Prompt / Code / Standalone

I should probably appreciate these Haskell freebies while they still last :) I have a feeling they're not going to be this frictionless for long!

It's handy to have a function for giving us consecutive pairs of items:

consecs :: [a] -> [(a,a)]
consecs xs = zip xs (tail xs)

Now for the fun part: making our filters! For part 1, we have two filters on the digits: first, that the digits are monotonic, and second, that at least one pair of consecutive digits matches:

mono :: Ord a => [a] -> Bool
mono = all (\(x,y) -> y >= x) . consecs

dups :: Eq a => [a] -> Bool
dups = any (\(x,y) -> x == y) . consecs

For part 2, we have two filters: the same mono filter, but also that we have a group that is exactly length two. For that we can use group, which groups a list into chunks of equal items: group "abbbcc" == ["a","bbb","cc"]. We then check if any of the chunks have a length of exactly two:

strictDups :: Eq a => [a] -> Bool
strictDups = any ((== 2) . length) . group

And from here, we just run our filters on the range and count the number of items:

part1 :: Int -> Int -> Int
part1 mn mx = length . filter (\x -> all ($ show x) [mono, dups      ])
            $ [mn .. mx]

part2 :: Int -> Int -> Int
part2 mn mx = length . filter (\x -> all ($ show x) [mono, strictDups]) . range
            $ [mn .. mx]

For parsing the range, we can use splitOn again:

range :: String -> (x, y)
range str = (x, y)
  where
    [x, y] =  map read (splitOn "-" str)

(Also, note to self next time ... if going for time, if you just have two numbers in your input, just enter the numbers directly into the source file at first, heh, instead of trying to parse them)

Day 4 Benchmarks

>> Day 04a
benchmarking...
time                 24.15 ms   (24.07 ms .. 24.25 ms)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 24.11 ms   (24.08 ms .. 24.15 ms)
std dev              83.64 μs   (59.11 μs .. 114.2 μs)

* parsing and formatting times excluded

>> Day 04b
benchmarking...
time                 24.31 ms   (24.12 ms .. 24.68 ms)
                     0.999 R²   (0.997 R² .. 1.000 R²)
mean                 24.27 ms   (24.18 ms .. 24.47 ms)
std dev              274.3 μs   (66.32 μs .. 487.8 μs)

* parsing and formatting times excluded

Day 5

Top / Prompt / Code

Day 5 Benchmarks

>> Day 05a
benchmarking...
time                 98.86 μs   (98.78 μs .. 99.00 μs)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 98.98 μs   (98.86 μs .. 99.18 μs)
std dev              477.2 ns   (358.1 ns .. 752.5 ns)

* parsing and formatting times excluded

>> Day 05b
benchmarking...
time                 164.0 μs   (163.7 μs .. 164.4 μs)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 163.7 μs   (163.5 μs .. 163.8 μs)
std dev              653.9 ns   (500.3 ns .. 782.9 ns)

* parsing and formatting times excluded

Day 6

Top / Prompt / Code / Standalone

This one is pretty fun in Haskell because you get to use a trick that everyone loves but nobody gets to use often enough --- recursive knot tying! Basically it's an idiomatic way to do dynamic programming in Haskell by taking advantage of lazy data structures (this blog post is my favorite explanation of it).

The general idea is: let's say we had a map of children to parents, Map String String. To get the count of all indirect orbits, we can get a Map String Int, a map of children to the number of parents and indirect parents above them, and get the sum of those.

But how do we compute that?

Here, I'm going to show the "finale" first, and explain the way to get there:

type Parent = String
type Child  = String

parents :: Map Child Parent

parentsCount     :: Map Child Int
parentsCount     = parents <&> \p -> case M.lookup p parentsCount of
    Nothing -> 1
    Just n  -> n + 1

parentsOfParents :: Map Child [Parent]
parentsOfParents = parents <&> \p -> case M.lookup p parentsOfParents of
    Nothing -> []
    Just ps -> p:ps

Fun, right? And satisfyingly symmetrical. That's more or less it!

So, how do we get there?

Let's call the child-parent map and the parent counts map as:

type Parent = String
type Child  = String

parents      :: Map Child Parent
parentsCount :: Map Child Int

We see that the two have the same keys, so we can "map" a function over the parents map to get parentsCount:

parentsCount :: Map Child Int
parentsCount = fmap countTheParents parents

countTheParents :: Parent -> Int
countTheParents p = -- ?

So how do we countTheParents? Well, we can look the parent up in parentsCount, add one to the answer. That's because if the parent has n indirect parents, then the child has n + 1 indirect parents:

parentsCount :: Map Child Int
parentsCount = fmap countTheParents parents

countTheParents :: Parent -> Int
countTheParents p = case M.lookup p parentsCount of
    Nothing -> 1        -- count is 1
    Just n  -> n + 1    -- count is 1 + number of parents of parents

And that's it!

part1 :: Int
part1 = sum parentsCount

The interesting thing here is that the leaves of parentsCount are lazily evaluated --- so they can recursively refer to each other!

We can do part2 in the same way, basically: we can build a list of parents of parents of parents "YOU", and then a list of parents of parents of parents of "SAN", and count the number of items that are unique to each.

parentsOfParents :: Map Child [Parent]
parentsOfParents = fmap getPP parents

getPP :: Parent -> [Parent]
getPP p = case M.lookup p parentsOfParents of
    Nothing -> []       -- no parents
    Just pp -> p : pp   -- parent consed to parents of parents

Note that we actually could have defined parentsCount this way too:

-- we could have done this
parentsCount :: Map Child Int
parentsCount = fmap length parentsOfParents

(But this is worse than the way we did it originally. Do you see why?)

But anyway, for part 2, we will get the parents of parents of "YOU" and the parents of parents of "SAN" and count the items that are unique to each:

import qualified Data.Set as S

part2 :: Int
part2 = S.size onlyYou + S.size onlySan
  where
    Just you = M.lookup "YOU" parentsOfParents
    Just san = M.lookup "SAN" parentsOfParents
    onlyYou  = you S.\\ san     -- remove all items in `san` from `you`
    onlySan  = san S.\\ you     -- remove all items in `you` from `san`

Note that because the leaves in a Map are lazy, this will only actually construct a list [Parent] for the keys that you look up --- parents lists for keys you don't care about are never assembled.

The nice thing about recursive knot tying is that it gives a very concise and readable way of saying "what you want":

parentsCount :: Map Child Int
parentsCount = fmap countTheParents parents

countTheParents :: Parent -> Int
countTheParents p = case M.lookup p parentsCount of
    Nothing -> 1
    Just n  -> n + 1

This code is pretty easy to walk through, and logic of getting the parent count (countTheParents) can be easily read as English: "If you get nothing when you look up the parent in the parents count, then you only have one parent. If you do get something, then it's one plus that something".

The recursive way here makes it much more readable in a "denotative" sense: you say what it is, and the program/compiler figures out the rest for you. Because of this, knot tying is often cited as one of the flashy "tech demos" of denotative programming. You might have seen someone write fibs = 1 : 1 : zipWith (+) fibs (tail fibs) --- that's the same thing going on here.

And, with a lazy language like Haskell, it means that the leaves remain unevaluated until we need them. This will explode in your face in other languages: if you evaluate all of the leaves "in order", then the first item will depend on another unevaluated item, which might cause an error in other languages.

It's always fun when a puzzle demonstrates so well a trick that is essential in every Haskeller's tool belt :)

Day 6 Benchmarks

>> Day 06a
benchmarking...
time                 301.1 μs   (300.9 μs .. 301.6 μs)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 299.6 μs   (299.1 μs .. 300.7 μs)
std dev              2.893 μs   (1.596 μs .. 5.405 μs)

* parsing and formatting times excluded

>> Day 06b
benchmarking...
time                 267.5 μs   (265.6 μs .. 268.4 μs)
                     1.000 R²   (0.999 R² .. 1.000 R²)
mean                 259.3 μs   (257.0 μs .. 261.1 μs)
std dev              6.845 μs   (6.340 μs .. 7.516 μs)
variance introduced by outliers: 20% (moderately inflated)

* parsing and formatting times excluded

Day 7

Top / Prompt / Code

Day 7 Benchmarks

>> Day 07a
benchmarking...
time                 7.234 ms   (7.215 ms .. 7.257 ms)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 7.238 ms   (7.229 ms .. 7.246 ms)
std dev              24.01 μs   (19.95 μs .. 28.28 μs)

* parsing and formatting times excluded

>> Day 07b
benchmarking...
time                 39.18 ms   (38.36 ms .. 40.43 ms)
                     0.998 R²   (0.997 R² .. 1.000 R²)
mean                 38.58 ms   (38.42 ms .. 39.15 ms)
std dev              539.5 μs   (149.5 μs .. 982.3 μs)

* parsing and formatting times excluded

Day 8

Top / Prompt / Code / Standalone

This one feels like another Haskell freebie from the early days. I'm not complaining, we'll take what we can get :)

We'll define a useful function that counts the number of items in a list that is equal to a given value:

numMatches :: Eq a => a -> [a] -> Int
numMatches x = length . filter (== x)

We can use the chunksOf function from the amazing split package to split our input into chunks of 150. Then we can find the maximum of those lines based on their zero count. Then we encode the answer.

part1 :: String -> Int
part1 = encodeAnswer
      . minimumBy (comparing (numMatches '0'))
      . chunksOf 150
  where
    encodeAnswer xs = numMatches '1' xs * numMatches '2' xs

For part 2, we can use transpose turn a list of lines into a list where every item is all of the pixel data for that pixel. So it would turn

["1234"
,"1234"
,"1234"
]

into

["111"
,"222"
,"333"
,"333"
]

which is exactly what we need to process it.

Finding the 'pixel value' of each pixel is basically the first non-2 pixel in each list. The first way that came to my mind was to use dropWhile (== '2'), but filter (/= '2') would have worked as well.

part2 :: String -> String
part2 = map (head . dropWhile (== '2'))
      . transpose
      . chunksOf 150

And that's it! Well, almost. Part 2 requires looking at 0/1 transparency data and deducing our image. For me, I wrote a function to display it nicely:

showImage :: String -> String
showImage = unlines
          . chunksOf 25         -- number of columns
          . map (\case '0' -> ' '; _ -> '#')
#  # ###  #  # #### ###
#  # #  # #  # #    #  #
#  # ###  #  # ###  #  #
#  # #  # #  # #    ###
#  # #  # #  # #    #
 ##  ###   ##  #    #

Day 8 Benchmarks

>> Day 08a
benchmarking...
time                 163.2 μs   (163.0 μs .. 163.4 μs)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 163.6 μs   (163.5 μs .. 164.0 μs)
std dev              851.4 ns   (592.2 ns .. 1.301 μs)

* parsing and formatting times excluded

>> Day 08b
benchmarking...
time                 199.1 μs   (197.2 μs .. 200.2 μs)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 197.2 μs   (196.7 μs .. 197.9 μs)
std dev              2.088 μs   (1.717 μs .. 2.725 μs)

* parsing and formatting times excluded

Day 9

Top / Prompt / Code

Day 9 Benchmarks

>> Day 09a
benchmarking...
time                 312.8 μs   (312.4 μs .. 313.2 μs)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 312.8 μs   (312.5 μs .. 313.2 μs)
std dev              1.155 μs   (869.7 ns .. 1.510 μs)

* parsing and formatting times excluded

>> Day 09b
benchmarking...
time                 550.8 ms   (548.2 ms .. 556.5 ms)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 551.7 ms   (550.4 ms .. 552.8 ms)
std dev              1.564 ms   (512.0 μs .. 2.119 ms)
variance introduced by outliers: 19% (moderately inflated)

* parsing and formatting times excluded

Day 10

Top / Prompt / Code / Standalone

Ah, a 2D lattice map problem -- a staple of Advent of Code, and a favorite to many (including me!)

The first thing to do is get our map into a format we can use. Using V2 Int to represent a 2d point (because of its useful instances like Num and Applicative), we want to get things into a Set of all asteroids. This is common enough that I have a pre-made utility function to handle this, but for demonstration's sake we can implement it like:

import qualified Data.Set as S

type Point = V2 Int

asteroidSet :: String -> Set Point
asteroidSet = ifoldMap (\y -> ifoldMap (\x -> crunch (V2 x y)))
            . lines
  where
    crunch p '#' = S.singleton p
    crunch _ _   = S.empty

Here I'm using the very handy ifoldMap :: Monoid m => (Int -> a -> m) -> [a] from Control.Lens.Indexed, which is a very useful function that I hope will some day make it to base. It's like foldMap with also the indices available.

Anyway, how do we check if an asteroid is obscured? There are probably many good methods, but for me I found all the points in a straight line between two asteroids, and checked if any of those items are in the asteroid field. (I did attempt also to get the set of all unique angles, but that method ended up being 10x slower for some reason? also using floating point equality makes me feel queasy to my core)

lineTo :: Point -> Point -> [Point]
lineTo p0 p1 = [ p0 + t *^ step | t <- [1 .. gcf  - 1] ]
  where
    d@(V2 dx dy) = p1 - p0
    gcf          = gcd dx dy
    step         = (`div` gcf) <$> d

Hopefully this shows at least is a good demonstration of why I like V2 Int as Point so much. We take advantages of its instances a lot, including:

  • Using the Num instance to compute the deltas, V2 dx dy = p1 - p0
  • Using the Functor instance to compute the step, (div gcf) <$> d
  • The handy scalar multiplication function c *^ v

I love V2 :D

Anyway, the main crux of this algorithm is the list comprehension, which computes the "steps" between the start and finish.

We can now check all the viewable points.

viewableIn
    :: Set Point    -- ^ asteroid field
    -> Point        -- ^ vantage point
    -> Set Point    -- ^ all viewable points
viewableIn asteroids p = S.filter good (toList asteroids)
  where
    good q = p /= q
          && all (`S.notMember` asteroids) (lineTo p q)

Now we can do part 1:

part1 :: Set Point -> Int
part1 asteroids = S.findMax $
    S.map (S.length . viewableIn asteroids) asteroids

For part 2, we are going to structure our program as an unfoldr. Unfoldr generates items while keeping some internal state. We'll use the "currently aimed at asteroid" and "asteroids left" as our state, and emit newly eliminated asteroids. Then we can simply get the 200th item in the resulting list:

part2 :: Set Point -> Point
part2 asteroids =
    unfoldr (shootFrom station) (Nothing, asteroids) !! 199
  where
    station = maximumBy (comparing (S.size . viewableIn asteroids))
                asteroids

So we have shootFrom as our iterating function. Our "state" will be Maybe Point (the asteroid our blaster is aimed at) and Set Point, the asteroid field remaining. We'll return Nothing when we run out of asteroids to eliminate.

To implement shootFrom, it's useful to be able to sort all viewable asteroids by the angle they make. To do that, I made a function angleFrom which computes the angle between two points, clockwise from vertical. I use atan2 with some algebraic finessing to make sure north is the minimal amount, and the direction moves appropriately (we flip its arguments and remember to invert the y axis).

angleTo :: Point -> Point -> Double
angleTo p0 p1 = atan2 (-fromIntegral dx) (fromIntegral dy)
  where
    V2 dx dy = p1 - p0

We now have all the parts to write shootFrom:

shootFrom
    :: Point                                    -- ^ station
    -> (Maybe Point, Set Point)                 -- ^ current aim and remaining asteroids
    -> Maybe (Point, Maybe Point, Set Point))   -- ^ blasted asteroid, new aim, leftover field
shootFrom station (aim, asteroids) = guard (not (S.null asteroids)) $>
    case aim of
      Nothing ->
        let targ:next:_ = targetList
        in  (targ, (Just next, S.delete targ asteroids))
      Just a ->
        let targ:next:_ = dropWhile (/= a) targetList
        in  (targ, (Just next, S.delete targ asteroids))
  where
    targetList = cycle
               . sortOn (angleTo station)
               . toList
               $ viewableIn asteroids station

Our targetList is all of the remaining asteroids that are viewable from our station, sorted by their angle from the station (0 being north, going clockwise). We cycle :: [a] -> [a] it, which loops it on itself forever, so that the "next target" will always be the item after the current target. It turns [a,b,c] into [a,b,c,a,b,c,a,b,c...], so if we want to ask "what target comes after c?", we can see that a is after c in the cycled version.

First, we use guard to return Nothing immediately if there are no asteroids left. But if there are asteroids left, we then check what we are aiming at. If we aren't aiming at anything, just find the first item in the target list and blast at that. Otherwise, eat up the target list until we find the item we are aiming at, and blast at that. In both cases, the item after our target will be the new item we are aiming at.

We just then need to make sure we delete our target in the new Set Point, to remove it from the pool.

This one was a nice mix of math, geometry, spatial awareness, and a sense of iterative algorithms (like shootFrom) -- for me, all of the best parts of an Advent of Code challenge :)

Day 10 Benchmarks

>> Day 10a
benchmarking...
time                 5.234 ms   (5.202 ms .. 5.272 ms)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 5.224 ms   (5.213 ms .. 5.239 ms)
std dev              39.44 μs   (29.46 μs .. 53.16 μs)

* parsing and formatting times excluded

>> Day 10b
benchmarking...
time                 8.858 ms   (8.813 ms .. 8.890 ms)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 8.805 ms   (8.789 ms .. 8.822 ms)
std dev              43.65 μs   (34.98 μs .. 52.24 μs)

* parsing and formatting times excluded

Day 11

Top / Prompt / Code / Standalone

Okay, so I have a bit of backlog on my intcode-related posts (days 5, 7, and 9). But we've gotten to the point where the incode implementation isn't the interesting part, but how we use it is, so maybe it's time for a fresh start :)

This challenge affirmed my choice to use conduit to model my Intcode VM. (I actually use conduino, my own lightweight alternative to conduit, because it was able to handle something in Day 7 that I couldn't easily get conduit to handle. But since conduit is an actual industry-ready library that is commonly used, I'm going to write this tutorial in terms of it instead)

For a "preview" of the end, my final code is more or less:

fullBot :: Memory -> Conduit i o (State Hull) ()
fullBot m = sensor
         .| intcodeVM m
         .| painterMover

For those unfamiliar with conduit, ConduitT i o is a monad transformer (like StateT s, or ReaderT r, or WriterT w, etc.) that offers two new primitives:

await :: ConduitT i o m (Maybe i)
yield :: o -> ConduitT i o m ()

This should feel very similar to similar actions from StateT, ReaderT, and WriterT:

-- similar in form to 'await'
get :: StateT  s m s
ask :: ReaderT r m r

-- similar in form to 'yield'
put  :: s -> StateT  s m ()
tell :: w -> WriterT w m ()

You can think of await like reading from an input pipe, like stdin: you pick off the next item the pipe is delivering you. You can think of yield like writing to an output pipe, like stdout. You can then combine conduits to create new conduits, like c1 .| c2 -- it feeds the output of c1 into the input of c2, etc.

So for a type like ConduitT i o m a, i is the input stream's type, o is the output stream's type, m is the underlying monad, and a is the result type that is yielded when computation finishes.

My VM machine is essentially:

intcodeVM :: Memory -> ConduitT Int Int m Memory

Given some starting memory state, you return a ConduitT Int Int m Memory: take Ints as input, output Ints, and when it's done, output the finished Memory once we halt.

So we have our transforming pipe...what sort of input does it need, and how are we handling the output?

The input stream is relatively simple. Let's put together a hull state:

type Point = V2 Int         -- V2, from linear library
data Color = Black | White

data Hull = Hull
    { hDir :: Point         -- ^ unit-length direction vector
    , hPos :: Point
    , hMap :: Map Point Color
    }

emptyHull :: Hull
emptyHull = Hull (V2 0 1) 0 M.empty

The underlying monad of our Conduit (that all components will be able to access) will be State Hull.

Our input pipe is will read the current hull point and output 0 or 1 based on black or white:

sensor :: ConduitT i Int (State Hull) a
sensor = forever $ do
    Hull _ p m <- get
    case M.lookup p m of
      Nothing    -> yield 0     -- black
      Just Black -> yield 0     -- black
      Just White -> yield 1     -- white

It'll just keep on reading and yielding, forever and ever.

Our output pipe will read the input of intcodeVM and adjust the state appropriately --- it's slightly trickier because we have to parse the input and modify the state. await returns a Maybe, so if we get two Just's then we make our changes and repeat it all over again. Otherwise, we're done.

painterMover :: ConduitT Int o (State Hull) ()
painterMover = do
    color <- fmap parseColor <$> await
    turn  <- fmap parseTurn  <$> await
    case (color, turn) of
      (Just c, Just t) -> do
        modify $ \(Hull d p m) ->
          let d' = t d
          in  Hull d' (p + d') (M.insert p c m)
        painterMover                -- recurse
      _                ->
        pure ()                     -- we're done!
  where
    parseColor 0 = Black
    parseColor 1 = White
    parseTurn  0 (V2 x y) = V2 (-y)   x     -- turn left
    parseTurn  1 (V2 x y) = V2   y  (-x)    -- turn right

And that's it!

fullBot :: Memory -> Conduit i o (State Hull) ()
fullBot m = sensor
         .| intcodeVM m
         .| painterMover

We can run a full pipeline using runConduit:

part1 :: Memory -> Int
part1 m = M.size m
  where
    Hull _ p m = execState (runConduit (fullBot m)) emptyHull

Part 2 is the same thing but we start on a painted hull:

whiteHull :: Hull
whiteHull = Hull (V2 0 1) 0 (M.singleton 0 White)

part1 :: Memory -> Map Point Color
part1 m = m
  where
    Hull _ _ m = execState (runConduit (fullBot m)) whiteHull

The nice thing I like about the conduit method is that it lends itself really well to "hooking up" the machine with input streams and output processing! For a machine that basically simulates stdin and stdout, it works very well, I think! You only need to think:

  1. How am I generating input?
  2. How am I processing output?

And your entire program will just be generator .| intcodeVM m .| processor. This also worked pretty well as a mental model for Day 7 as well, because we can easily pipe multiple independent machines: intcodeVM m .| intcodeVM m .| intcodeVM m, and they will all maintain separate and independent memories as they feed items to each other. conduit handles all of the actual message passing, and all you have to do is assemble your pipeline and let it churn away!

Note that even if you didn't structure your intcode VM as a Conduit, it's pretty easy to "turn it into" a ConduitT Int Int. Integrating it into conduit is nice even if you didn't intend to do it originally, using basic do notation and combinations of await and yield and recursion.

Writing your intcodeVM conduit

Is this you? Do you have your intcode VM written in a way that doesn't really support streaming input easily, but want to convert it into a conduit? Are you worried you will have to throw everything away and start from scratch?

Fear not --- there is a way to wrap an existing intcode VM implementation in Conduit so you can get that sweet intcodeVM m :: Conduit Int Int m Memory action!

All you need to do is, using your existing implementation, write this function:

type Memory         -- contains current position, register state, and base

runMemory
    :: Memory                   -- ^ initial memory
    -> ( [Int]                  -- ^ output emitted before halt or input asked
       , Either
           Memory               -- ^ either a halted machine ...
           (Int -> Memory)      -- ^ ... or a continuation awaiting one input
       )

From there, you can construct intcodeVM like this:

intcodeVM :: Memory -> ConduitT Int Int m Memory
intcodeVM m0 = do
    mapM_ yield outs
    case next of
      Left  finalMemory -> pure finalMemory     -- halt!
      Right nextWith    -> do
        inp <- await
        case inp of
          Nothing -> pure ()                    -- no more input so what can you do, right?
          Just i  -> intcodeVM (nextWith i)     -- recurse!
  where
    (outs, next) = runMemory m0

And there you have it! You can now do the rest of the code described in this post :)

Day 11 Benchmarks

>> Day 11a
benchmarking...
time                 327.4 ms   (326.2 ms .. 328.3 ms)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 326.7 ms   (326.1 ms .. 327.0 ms)
std dev              555.1 μs   (185.1 μs .. 804.7 μs)
variance introduced by outliers: 16% (moderately inflated)

* parsing and formatting times excluded

>> Day 11b
benchmarking...
time                 26.30 ms   (26.24 ms .. 26.38 ms)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 26.37 ms   (26.32 ms .. 26.41 ms)
std dev              90.17 μs   (73.81 μs .. 120.9 μs)

* parsing and formatting times excluded

Day 12

Top / Prompt / Code

Day 12 Benchmarks

>> Day 12a
benchmarking...
time                 180.0 μs   (179.6 μs .. 180.4 μs)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 180.2 μs   (180.0 μs .. 180.4 μs)
std dev              748.6 ns   (602.4 ns .. 1.039 μs)

>> Day 12b
benchmarking...
time                 10.48 ms   (10.44 ms .. 10.52 ms)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 10.49 ms   (10.47 ms .. 10.51 ms)
std dev              60.03 μs   (44.43 μs .. 84.98 μs)

Day 13

Top / Prompt / Code

Day 13 Benchmarks

>> Day 13a
benchmarking...
time                 34.95 ms   (34.82 ms .. 35.03 ms)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 35.09 ms   (35.02 ms .. 35.20 ms)
std dev              189.6 μs   (124.8 μs .. 278.2 μs)

* parsing and formatting times excluded

>> Day 13b
benchmarking...
time                 1.892 s    (1.879 s .. 1.900 s)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 1.886 s    (1.882 s .. 1.889 s)
std dev              3.505 ms   (1.773 ms .. 4.504 ms)
variance introduced by outliers: 19% (moderately inflated)

* parsing and formatting times excluded

Day 14

Top / Prompt / Code

Day 14 Benchmarks

>> Day 14a
benchmarking...
time                 106.8 μs   (106.3 μs .. 107.2 μs)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 106.6 μs   (106.5 μs .. 106.8 μs)
std dev              529.9 ns   (428.2 ns .. 692.1 ns)

* parsing and formatting times excluded

>> Day 14b
benchmarking...
time                 6.055 ms   (6.023 ms .. 6.103 ms)
                     1.000 R²   (0.999 R² .. 1.000 R²)
mean                 6.070 ms   (6.049 ms .. 6.106 ms)
std dev              85.37 μs   (57.55 μs .. 114.2 μs)

* parsing and formatting times excluded

Day 15

Top / Prompt / Code

Day 15 Benchmarks

>> Day 15a
benchmarking...
time                 141.5 ms   (140.1 ms .. 144.8 ms)
                     1.000 R²   (0.999 R² .. 1.000 R²)
mean                 141.1 ms   (140.0 ms .. 142.0 ms)
std dev              1.407 ms   (1.038 ms .. 1.882 ms)
variance introduced by outliers: 12% (moderately inflated)

* parsing and formatting times excluded

>> Day 15b
benchmarking...
time                 519.2 ms   (509.2 ms .. 526.5 ms)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 523.5 ms   (520.6 ms .. 528.4 ms)
std dev              4.804 ms   (394.1 μs .. 6.164 ms)
variance introduced by outliers: 19% (moderately inflated)

* parsing and formatting times excluded

Day 16

Top / Prompt / Code

Day 16 Benchmarks

>> Day 16a
benchmarking...
time                 426.0 ms   (408.1 ms .. 437.9 ms)
                     1.000 R²   (0.999 R² .. 1.000 R²)
mean                 424.2 ms   (421.3 ms .. 427.4 ms)
std dev              3.456 ms   (1.626 ms .. 4.847 ms)
variance introduced by outliers: 19% (moderately inflated)

* parsing and formatting times excluded

>> Day 16b
benchmarking...
time                 54.91 ms   (53.66 ms .. 56.35 ms)
                     0.997 R²   (0.990 R² .. 1.000 R²)
mean                 54.86 ms   (53.34 ms .. 56.08 ms)
std dev              2.490 ms   (1.553 ms .. 4.111 ms)
variance introduced by outliers: 15% (moderately inflated)

* parsing and formatting times excluded

Day 17

Top / Prompt / Code / Standalone

It's been a while since one of these! I spent a lot of last week traveling and it's been tough getting through the backlog :)

For today I'm only going to be discussing some parts of the solution that I think are particularly interesting in Haskell: in particular, Part 2's path construction and compression.

Once you have a set of points, it's useful to try to figure out the path to the end. From the constraints of the problem, we can make an educated guess that our "pathfinding" has to be extremely simple in order to accommodate for the small program size we can give. Basically, it will be:

  1. Is there a spot in front of us? If so, step forward and repeat from step 1.
  2. Otherwise, is there a spot to our left? If so, turn left and repeat from step 1.
  3. Otherwise, is there a spot to our right? If so, turn right and repeat from step 1.
  4. Otherwise, we've reached the end.

I'm going to use Set Point (where Point is V2 Int, for reasons discussed in earlier problems) to describe our scaffolding, and a data type to keep track of bot state. The directionality will be tracked by keeping a unit vector in the direction the bot is facing.

type Point = V2 Int
data BotState = BS { bsPos :: Point, bsDir :: Point }
data Move = TurnLeft | GoForward | TurnRight
  deriving Eq

findPath :: Set Point -> BotState -> [Move]
findPath scaff = unfoldr go
  where
    go (BS p0 d0@(V2 dx dy))
        | forward   `S.member` scaff = Just (GoForward, BS forward d0       )
        | leftward  `S.member` scaff = Just (TurnLeft , BS p0      turnLeft )
        | rightward `S.member` scaff = Just (TurnRight, BS p0      turnRight)
      where
        forward   = p0 + d0
        turnLeft  = V2 dy    (-dx)
        turnRight = V2 (-dy) dx
        leftward  = p0 + turnLeft
        rightward = p0 + turnRight

To turn our path into a "run-length encoding" of instructions, we will convert them into Either Int Int, where Left n means "turn left and go n forward", and Right n means "turn right and go n forwards". The easiest way to do that is probably to use group and chunksOf

pathToProg :: [Move] -> [Either Int Int]
pathToProg = traverse toInstr . chunksOf 2 . group
  where
    toInstr [[TurnLeft ],fs] = Just $ Left  (length fs)
    toInstr [[TurnRight],fs] = Just $ Right (length fs)
    toInstr _                = Nothing

Alright, so now form a Set Point and a BotState starting point, we get the run-length encoding of our journey. However, we now need to turn that into repetitions of three distinct chunks, A, B, and C.

To do this, we can write a general combinator to turn any [a] into encodings in terms of A, B, and C subprograms. Let's call it:

findProgs :: Eq a => [a] -> Maybe ([a], [a], [a])

If we start thinking about how we can pick these things, we notice some interesting properties. For example, for a string like abcdefg, we have many possible options for A: it's either a or ab or abc or abcd, etc. A must be a prefix of our string. However, once we "commit" to an A, then that also gives us our possibilities for b: in the same way, b must be a prefix of the remaining string after we "eliminate" A. So if we "pick" A to be abc, the B can be either d or de or def or defg, etc.

This sort of "if we pick this ... then we can pick that ... and if we pick that ..." system is exactly what Logic Programming is great for! And we can actually do some nice logic programing in Haskell using the List monad. I've actually written about using the list monad for this purpose multiple times over the years.

So let's lay out our full algorithm:

  1. We can pick A from any prefix of our string.
  2. Once we break out occurrences of our chosen A from the string, we can now pick B from any unbroken prefix of the remaining string.
  3. Once we break out occurrences of our chosen B from the string, we can now pick C from any unbroken prefix of the remaining string.
  4. Once we break out occurrences of our chosen C from the string, we only have a "real" solution if there are no other unclaimed items in the string.

This all translates pretty directly to usage of the List monad. findProgs will now return all valid A/B/C pairs:

findProgs :: Eq a => [a] -> [([a], [a], [a])]
findProgs p0 = do
    a <- validPrefix p0

    let withoutA = splitOn' a p0
    b <- case withoutA of
        []        -> empty              -- 'A' consumed everything, whoops
        bs : _    -> validPrefix bs

    let withoutB = splitOn' b =<< withoutA
    c <- case withoutB of
        []        -> empty              -- 'A' and 'B' consumed everything, whoops
        cs : _    -> validPrefix cs

    let withoutC = splitOn' c =<< withoutB
    guard $ null withoutC

    pure (a, b, c)
  where
    -- | Get all valid prefixes
    validPrefix = take 4 . filter (not . null) . inits
    -- | a version of splitOn that only returns non-empty lists
    splitOn' x = filter (not . null) . splitOn x

Note that here I am using a simple predicate to filter out subprograms that are "too long" (the take 4 in validPrefix). For a more robust solution, we can do validPrefix = filter validLength . inits, testing on the length of the strings that encode the programs.

And that is mostly it! We can reconstruct our original program by using iterated applications of stripPrefix, taking whatever prefix is valid at every point:

-- | Given an association list of subroutines and their "label", iteratively
-- chomp through a string replacing each occurence of the subroutine with the
-- label.
chomp :: Eq a => [([a], b)] -> [a] -> [b]
chomp progs = unfoldr go
  where
    go xs = asum
      [ (r,) <$> stripPrefix prog xs
      | (prog, r) <- progs
      ]

The nice thing about writing these functions "in general" (instead of just for Either Int Int) is that it forces us to ignore some of the unimportant details, and allows us only to use properties of lists (like lengths) and equality testing.

And our final solution is, given a set of scaffolding points and an initial bot state:

data Prog = A | B | C

data Output = O
    { oProg :: [Prog]
    , oA    :: [Either Int Int]
    , oB    :: [Either Int Int]
    , oC    :: [Either Int Int]
    }

part2 :: Set Point -> BotState -> Maybe Output
part2 scaff b0 = listToMaybe (findProgs path) <&> \(a,b,c) ->     -- <&> is flip fmap
    O { oProg = chomp [(a, A), (b, B), (c, C)] path
      , oA    = a
      , oB    = b
      , oC    = c
      }
  where
    path = findPath scaff b0

Day 17 Benchmarks

>> Day 17a
benchmarking...
time                 18.97 μs   (18.93 μs .. 19.01 μs)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 18.99 μs   (18.97 μs .. 19.01 μs)
std dev              76.76 ns   (63.96 ns .. 94.62 ns)

* parsing and formatting times excluded

>> Day 17b
benchmarking...
time                 54.44 μs   (54.33 μs .. 54.53 μs)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 54.52 μs   (54.42 μs .. 54.66 μs)
std dev              378.3 ns   (285.5 ns .. 513.4 ns)

* parsing and formatting times excluded

Day 18

Top / Prompt / Code

Day 18 Benchmarks

>> Day 18a
benchmarking...
time                 804.9 ms   (799.0 ms .. 809.7 ms)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 802.0 ms   (800.4 ms .. 803.4 ms)
std dev              1.674 ms   (1.147 ms .. 1.997 ms)
variance introduced by outliers: 19% (moderately inflated)

* parsing and formatting times excluded

>> Day 18b
benchmarking...
time                 122.1 ms   (120.9 ms .. 122.6 ms)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 120.5 ms   (119.1 ms .. 121.2 ms)
std dev              1.555 ms   (541.2 μs .. 2.435 ms)
variance introduced by outliers: 11% (moderately inflated)

* parsing and formatting times excluded

Day 19

Top / Prompt / Code

Day 19 Benchmarks

>> Day 19a
benchmarking...
time                 1.623 s    (NaN s .. 1.627 s)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 1.623 s    (1.622 s .. 1.624 s)
std dev              1.244 ms   (1.058 ms .. 1.333 ms)
variance introduced by outliers: 19% (moderately inflated)

* parsing and formatting times excluded

>> Day 19b
benchmarking...
time                 3.162 s    (3.060 s .. 3.247 s)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 3.171 s    (3.143 s .. 3.199 s)
std dev              30.89 ms   (16.06 ms .. 43.51 ms)
variance introduced by outliers: 19% (moderately inflated)

* parsing and formatting times excluded

Day 20

Top / Prompt / Code

Day 20 Benchmarks

>> Day 20a
benchmarking...
time                 7.674 ms   (7.657 ms .. 7.692 ms)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 7.653 ms   (7.645 ms .. 7.664 ms)
std dev              28.47 μs   (23.28 μs .. 34.58 μs)

* parsing and formatting times excluded

>> Day 20b
benchmarking...
time                 18.64 ms   (18.60 ms .. 18.69 ms)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 18.54 ms   (18.45 ms .. 18.59 ms)
std dev              125.6 μs   (76.59 μs .. 172.9 μs)

* parsing and formatting times excluded

Day 21

Top / Prompt / Code

Day 21 Benchmarks

>> Day 21a
benchmarking...
time                 63.03 ms   (62.70 ms .. 63.39 ms)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 62.87 ms   (62.72 ms .. 63.05 ms)
std dev              298.5 μs   (175.1 μs .. 427.5 μs)

* parsing and formatting times excluded

>> Day 21b
benchmarking...
time                 1.391 s    (1.363 s .. 1.408 s)
                     1.000 R²   (1.000 R² .. NaN R²)
mean                 1.396 s    (1.392 s .. 1.398 s)
std dev              3.787 ms   (1.998 ms .. 5.339 ms)
variance introduced by outliers: 19% (moderately inflated)

* parsing and formatting times excluded

Day 22

Top / Prompt / Code / Standalone

Today's challenge, I think, shows a lot of advantages in the ways that Haskell approaches mathematical abstractions :)

Unlike the other reflections, today I'm not going to explain "how I do it", as much as "how I came up with the answer" --- and hopefully try to show how Haskell's framing of mathematical abstractions like groups help guide us to the answer.

Reading the problem, the initial thought is that we have what is essentially a composition of permutations -- the mathematical word for "shuffle", basically.

One of the most famous properties of permutations is that they are a "group", which means they can be composed (associatively), have an identity, and can be inverted. This means that if you have two permutations, you can "squish" them to create a new permutation, and work with that new permutation the same way. I've talked about using group theory principles to help guide us towards solutions and optimizations in Advent of Code challenges in the past.

The first big advantage here is that we can treat our transformations as data, and not as functions. And that if we have two transformations, we can always create a new one (just a normal data type value) that represents the composition of the two original ones.

Knowing permutations are a group, it means that once we settle on our representation of them, Perm, we can write an instance of Perm for Semigroup, Monoid, and Group, common abstractions in Haskell that many types are already instances of. Abstractions like Semigroup and Monoid are pretty much an everyday thing in Haskell, so this fits in quite nicely. Group comes from the groups package, which also provides some nice applications of group theory.

class Semigroup p where
    -- | permutation composition: compose two permutations to yield a new one
    (<>) :: p -> p -> p

-- | extreeeemely efficient way of composing a permutation with itself
-- multiple times, thanks to group theory
stimes :: Int -> p -> p

class Monoid p where
    -- | the identity permutation, where p <> mempty = p
    mempty :: p

class Group p where
    -- | invert a permutation. so p <> invert p = mempty
    invert :: p -> p

Just knowing that permutations form a group naturally guides us to these abstractions --- we already know what interface our type will have, even before we write any code. We know that no matter what our implementation of permutation will be, we will have (<>), stimes, mempty, invert available to us to use. So, let's do just that! We'll use a stub data type Perm to represent our permutation and "pretend" we have that interface on it. We'll write our function first and then fill in the interface later!

-- | Represents a permutation of n cards
data Perm n

-- | Given a permutation list, find the place where a given index ends up.
(@$) :: Perm n -> Finite n -> Finite n

-- | Parse a string line into the permutation it represents
parsePerm :: String -> Perm n

-- | Given a permutation list, find the place where 2019 ends up
part1 :: [Perm 10007] -> Finite 10007
part1 perms = bigPerm @$ 2019
  where
    bigPerm = mconcat perms

And...that's it! For the actual "logic" of our part 1!

Here, I'm using Finite n from the great finite-typelits library, where Finite 100 represents "an index between 0 and 99", etc. It's just exactly the right "shape" to represent the index of a deck of cards. finite-typelits wasn't designed with group theory in mind, but it's still a great tool here --- which is a testament to how flexible these abstractions can actually be :)

We can plan out our part 2 as well:

-- | Given a permutation list, find the index that will end up at 2020
part2 :: [Perm 119315717514047] -> Finite 119315717514047
part2 perms = invert biiigPerm @$ 2020
  where
    bigPerm   = mconcat perms
    biiigPerm = stimes 101741582076661 bigPerm

Part 2, I think, is where the group theory really shines.

  1. We take advantage of stimes, which uses repeated squaring. That means that to compute stimes 8 x, instead of using x <> x <> x <> x <> x <> x <> x <> x, it does let x2 = x <> x; x4 = x2 <> x2 in x4 <> x4, essentially cutting down the number of multiplications exponentially. This means that to compute stimes 101741582076661, we only need to do about 47 multiplications (log base 2), and not 101741582076661.

    This is only possible because we know that permutation composition is associative, so it doesn't matter how we associate our parentheses. It is only "safe" to use repeated squaring if you know that your operation is associative. Having a semigroup abstraction in the first place guides us to this efficient solution --- in a way that is pre-built just for us! This is made all the more powerful because semigroup is a ubiquitous abstraction in Haskell, so we "think about" it all the time.

  2. Remember how p @$ 2019 gives us the index that 2019 is sent to? Well, we want something else in this case. We basically want the index that will be sent to 2020. So, we want to reverse the function. Luckily, since our function is just a permutation, it is easy to reverse this: just invert the permutation!

    The idea that we can simply invert a permutation instead of having to write a whole new permutation representation just to do "backwards indexing" is something that we are guided to, just by recognizing that permutations form a group.

Now, time to actually write our permutation representation -- the definition of Perm. A good first guess might be to write our permutation as an actual function. Then, we can just use function composition as our permutation composition.

data Perm n = Perm (Finite n -> Finite n)

(@$) :: Perm n -> Finite n -> Finite n
Perm f @$ x  = f x

parsePerm :: KnownNat n => String -> Perm n
parsePerm str = case words str of
    "cut":n:_           -> Perm $ \i -> i - modulo (read n)
    "deal":"into":_     -> Perm $ \i -> maxBound - i
    "deal":"with":_:n:_ -> Perm $ \i -> i * modulo (read n)

instance Semigroup (Perm n) where
    Perm f <> Perm g = Perm (f . g)
instance Monoid (Perm n) where
    mempty = Perm id
instance Group (Perm n) where
    invert (Perm f) = ?????

Note that Finite n's Num instance is inherently modular arithmetic, so things like negate and multiplication will "do the right thing". We use modulo:

modulo :: KnownNat n => Integer -> Finite n

which "reads" an Integer into a Finite n, making sure to wrap it in a cyclic way if it is negative or too high.

This way works... but we see that there isn't any nice way to write invert for this. Also, stimes doesn't help us too much here, because repeated squaring of function composition is...still a lot of function compositions in the end. So, back to the drawing board.

If we look carefully at parsePerm, we might start to see a pattern in all of our permutations. In fact, they all seem to follow the same form:

"cut":n:_           -> Perm $ \i -> i - modulo (read n)
"deal":"into":_     -> Perm $ \i -> negate i + maxBound
"deal":"with":_:n:_ -> Perm $ \i -> i * modulo (read n)

They all seem to be some "scaling" and "adding" of i. If we align things up, this becomes a little more clear:

"cut":n:_           -> Perm $ \i ->                1 * i - modulo (read n)
"deal":"into":_     -> Perm $ \i ->               -1 * i + maxBound
"deal":"with":_:n:_ -> Perm $ \i ->  modulo (read n) * i

Each of these seems to be some sort of scaling-and-adding of i...also known as an Affine Transformation, but modulo some cyclic rotation.

Well...affine transformations on cyclic indices are a subset of permutations in general. More importantly, we know (after some googling) that they are also closed with respect to composition and inversion ... which means that they are, themselves, a group! Maybe we can represent this as our permutation type:

data Affine n = Aff { aScale :: Finite n
                    , aShift :: Finite n
                    }

(@$) :: KnownNat n => Affine n -> Finite n -> Finite n
Aff a b @$ x = a * x + b

parseAffine :: KnownNat n => String -> Affine n
parseAffine str = case words str of
    "cut":n:_           -> Aff                1  (-modulo (read n))
    "deal":"into":_     -> Aff        (negate 1)          maxBound
    "deal":"with":_:n:_ -> Aff (modulo (read n))                 0

So far so good :) Now to think of what our composition actions are. Composing a' x + b' after a x + b is a' (a x + b) + b', which is a' a x + a' b + b':

instance KnownNat n => Semigroup (Affine n) where
    Aff a' b' <> Aff a b = Aff (a' * a) (a' * b + b')

The identity permutation just leaves x alone, 1 x + 0:

instance Monoid (Affine n) where
    mempty = Aff 1 0

Inverting something means that we want invert p <> p == mempty. So that means we want

invert (Aff a b) <> Aff a b = Aff 1 0
       Aff a' b' <> Aff a b = Aff 1 0
 Aff (a' * a) (a' * b + b') = Aff 1 0

Which means we need a' * a = 1, and a' * b + b' = 0. To solve a' * a = 1, we can imagine that cycling a through the whole deck gets you back to a. (If n is prime, then a, a*a, a*a*a, etc. will all be unique...so you will keep on getting unique numbers until you exhaust the entire space at a^size to arrive back at a) So:

         a^n = a
=> a^(n-1)*a = a    -- definition of exponentiation
=> a^(n-1)   = 1    -- a^(n-1) leaves a unchanged, so it must be 1
=> a^(n-2)*a = 1    -- definition of exponentiation

From this we can see that if a' * a = 1, then a' must be a^(n-2).

The second case is a little simpler: we see that b' = -(a' * b)

instance KnownNat n => Group (Affine n) where
    invert (Aff a b) = Aff a' b'
      where
        a' = a ^ (maxBound @(Finite n) - 1)
        b' = negate $ a' * b

And...we're done! This actually is pretty efficient with repeated squaring because we are just squaring numbers.

Well, this feels a little anticlimactic, doesn't it? Just to close us out, I'll re-paste the code we planned before, now with the context that we have implemented the appropriate permutation types. We get the [Affine n]s by using parseAffine on the lines of our input group (remembering to reverse because that's how compositions work by convention).

-- | Given a permutation list, find the place where 2019 ends up
part1 :: [Affine 10007] -> Finite 10007
part1 perms = bigPerm @$ 2019
  where
    bigPerm = mconcat perms

-- | Given a permutation list, find the index that will end up at 2020
part2 :: [Affine 119315717514047] -> Finite 119315717514047
part2 perms = invert biiigPerm @$ 2020
  where
    bigPerm   = mconcat perms
    biiigPerm = stimes 101741582076661 bigPerm

As expected, Haskell performs these ~47 multiplication steps pretty quickly, and part 2 is only about 3 times slower than part 1 (~50μs vs. ~20μs).

Hopefully this is an illustrative story about taking advantage of how Haskell frames abstractions (as typeclasses) to guide us to an answer that might not have been obvious in the first place!

Day 22 Benchmarks

>> Day 22a
benchmarking...
time                 5.018 μs   (4.972 μs .. 5.052 μs)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 4.986 μs   (4.961 μs .. 5.013 μs)
std dev              88.34 ns   (83.38 ns .. 96.54 ns)
variance introduced by outliers: 17% (moderately inflated)

* parsing and formatting times excluded

>> Day 22b
benchmarking...
time                 12.94 μs   (12.84 μs .. 13.05 μs)
                     0.999 R²   (0.999 R² .. 1.000 R²)
mean                 12.90 μs   (12.82 μs .. 12.96 μs)
std dev              247.0 ns   (223.4 ns .. 260.8 ns)
variance introduced by outliers: 17% (moderately inflated)

* parsing and formatting times excluded

Day 23

Top / Prompt / Code

Day 23 Benchmarks

>> Day 23a
benchmarking...
time                 15.95 ms   (15.87 ms .. 16.03 ms)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 15.95 ms   (15.87 ms .. 16.03 ms)
std dev              191.3 μs   (127.4 μs .. 275.7 μs)

* parsing and formatting times excluded

>> Day 23b
benchmarking...
time                 267.3 ms   (259.4 ms .. 275.3 ms)
                     1.000 R²   (0.998 R² .. 1.000 R²)
mean                 267.7 ms   (266.3 ms .. 270.5 ms)
std dev              2.389 ms   (565.4 μs .. 3.429 ms)
variance introduced by outliers: 16% (moderately inflated)

* parsing and formatting times excluded

Day 24

Top / Prompt / Code

Day 24 Benchmarks

>> Day 24a
benchmarking...
time                 1.208 ms   (1.206 ms .. 1.209 ms)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 1.208 ms   (1.206 ms .. 1.210 ms)
std dev              5.604 μs   (4.294 μs .. 7.948 μs)

* parsing and formatting times excluded

>> Day 24b
benchmarking...
time                 638.7 ms   (623.1 ms .. 660.1 ms)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 642.2 ms   (639.4 ms .. 647.2 ms)
std dev              4.876 ms   (353.4 μs .. 6.172 ms)
variance introduced by outliers: 19% (moderately inflated)

* parsing and formatting times excluded

Day 25

Top / Prompt / Code

Day 25 Benchmarks

<< not benchmarked >>
Clone this wiki locally