2016 / 2017 / 2018 / 2019 / 2020 / 2021
- Day 1
- Day 2
- Day 3
- Day 4
- Day 5 (no reflection yet)
- Day 6
- Day 7 (no reflection yet)
- Day 8
- Day 9 (no reflection yet)
- Day 10
- Day 11
- Day 12 (no reflection yet)
- Day 13 (no reflection yet)
- Day 14 (no reflection yet)
- Day 15 (no reflection yet)
- Day 16 (no reflection yet)
- Day 17
- Day 18 (no reflection yet)
- Day 19 (no reflection yet)
- Day 20 (no reflection yet)
- Day 21 (no reflection yet)
- Day 22
- Day 23 (no reflection yet)
- Day 24 (no reflection yet)
- Day 25 (no reflection yet)
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 01a
benchmarking...
time 757.0 ns (751.8 ns .. 765.8 ns)
1.000 R² (0.999 R² .. 1.000 R²)
mean 754.6 ns (752.3 ns .. 757.8 ns)
std dev 9.060 ns (5.630 ns .. 15.72 ns)
variance introduced by outliers: 10% (moderately inflated)
* parsing and formatting times excluded
>> Day 01b
benchmarking...
time 16.67 μs (15.87 μs .. 17.58 μs)
0.983 R² (0.972 R² .. 0.994 R²)
mean 17.36 μs (16.81 μs .. 18.03 μs)
std dev 1.917 μs (1.281 μs .. 2.800 μs)
variance introduced by outliers: 88% (severely inflated)
* parsing and formatting times excluded
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 $ rFor 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 strThis 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 strThis 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 02a
benchmarking...
time 86.53 μs (81.17 μs .. 91.71 μs)
0.980 R² (0.972 R² .. 0.990 R²)
mean 83.56 μs (80.86 μs .. 87.26 μs)
std dev 10.92 μs (9.121 μs .. 13.01 μs)
variance introduced by outliers: 89% (severely inflated)
* parsing and formatting times excluded
>> Day 02b
benchmarking...
time 1.183 ms (1.130 ms .. 1.260 ms)
0.982 R² (0.973 R² .. 0.992 R²)
mean 1.266 ms (1.239 ms .. 1.283 ms)
std dev 79.61 μs (55.60 μs .. 113.4 μs)
variance introduced by outliers: 50% (moderately inflated)
* parsing and formatting times excluded
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 yOnce 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 sumWe 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 03a
benchmarking...
time 233.5 ms (223.1 ms .. 256.2 ms)
0.996 R² (0.991 R² .. 1.000 R²)
mean 237.5 ms (229.7 ms .. 247.4 ms)
std dev 11.97 ms (7.075 ms .. 18.94 ms)
variance introduced by outliers: 14% (moderately inflated)
* parsing and formatting times excluded
>> Day 03b
benchmarking...
time 244.1 ms (222.5 ms .. 261.4 ms)
0.992 R² (0.974 R² .. 1.000 R²)
mean 233.3 ms (223.3 ms .. 241.6 ms)
std dev 12.35 ms (8.551 ms .. 16.70 ms)
variance introduced by outliers: 14% (moderately inflated)
* parsing and formatting times excluded
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) . consecsFor 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) . groupAnd 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 04a
benchmarking...
time 26.90 ms (25.80 ms .. 29.08 ms)
0.987 R² (0.964 R² .. 1.000 R²)
mean 27.66 ms (26.88 ms .. 29.26 ms)
std dev 2.400 ms (1.119 ms .. 3.848 ms)
variance introduced by outliers: 37% (moderately inflated)
* parsing and formatting times excluded
>> Day 04b
benchmarking...
time 34.90 ms (32.77 ms .. 36.52 ms)
0.989 R² (0.980 R² .. 0.997 R²)
mean 32.64 ms (31.09 ms .. 34.22 ms)
std dev 2.930 ms (1.977 ms .. 3.745 ms)
variance introduced by outliers: 36% (moderately inflated)
* parsing and formatting times excluded
Reflection not yet written -- please check back later!
>> Day 05a
benchmarking...
time 158.0 μs (151.2 μs .. 163.9 μs)
0.986 R² (0.976 R² .. 0.995 R²)
mean 157.6 μs (152.6 μs .. 161.5 μs)
std dev 13.66 μs (10.52 μs .. 16.98 μs)
variance introduced by outliers: 76% (severely inflated)
* parsing and formatting times excluded
>> Day 05b
benchmarking...
time 274.9 μs (270.1 μs .. 279.8 μs)
0.994 R² (0.991 R² .. 0.997 R²)
mean 249.9 μs (240.8 μs .. 257.1 μs)
std dev 26.98 μs (25.15 μs .. 29.84 μs)
variance introduced by outliers: 82% (severely inflated)
* parsing and formatting times excluded
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:psFun, 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 IntWe 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 parentsAnd that's it!
part1 :: Int
part1 = sum parentsCountThe 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 parentsNote 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 + 1This 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 06a
benchmarking...
time 350.4 μs (348.5 μs .. 351.9 μs)
1.000 R² (1.000 R² .. 1.000 R²)
mean 350.1 μs (348.7 μs .. 353.4 μs)
std dev 6.563 μs (3.030 μs .. 13.85 μs)
variance introduced by outliers: 10% (moderately inflated)
* parsing and formatting times excluded
>> Day 06b
benchmarking...
time 356.0 μs (351.8 μs .. 362.9 μs)
0.998 R² (0.996 R² .. 1.000 R²)
mean 356.3 μs (353.2 μs .. 367.1 μs)
std dev 17.13 μs (5.609 μs .. 34.34 μs)
variance introduced by outliers: 44% (moderately inflated)
* parsing and formatting times excluded
Reflection not yet written -- please check back later!
>> Day 07a
benchmarking...
time 12.50 ms (11.38 ms .. 13.38 ms)
0.966 R² (0.943 R² .. 0.984 R²)
mean 10.90 ms (10.54 ms .. 11.63 ms)
std dev 1.261 ms (945.7 μs .. 1.636 ms)
variance introduced by outliers: 61% (severely inflated)
* parsing and formatting times excluded
>> Day 07b
benchmarking...
time 51.86 ms (49.20 ms .. 54.31 ms)
0.993 R² (0.985 R² .. 0.998 R²)
mean 48.66 ms (47.11 ms .. 50.11 ms)
std dev 2.904 ms (2.035 ms .. 3.772 ms)
variance introduced by outliers: 15% (moderately inflated)
* parsing and formatting times excluded
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' xsFor 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 150And 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 08a
benchmarking...
time 178.0 μs (176.5 μs .. 180.8 μs)
0.996 R² (0.987 R² .. 1.000 R²)
mean 178.6 μs (176.7 μs .. 184.0 μs)
std dev 10.67 μs (3.230 μs .. 19.97 μs)
variance introduced by outliers: 58% (severely inflated)
* parsing and formatting times excluded
>> Day 08b
benchmarking...
time 158.9 μs (153.6 μs .. 165.4 μs)
0.991 R² (0.984 R² .. 0.998 R²)
mean 156.0 μs (153.9 μs .. 162.0 μs)
std dev 10.34 μs (5.707 μs .. 15.34 μs)
variance introduced by outliers: 64% (severely inflated)
* parsing and formatting times excluded
Reflection not yet written -- please check back later!
>> Day 09a
benchmarking...
time 464.0 μs (446.4 μs .. 487.6 μs)
0.990 R² (0.985 R² .. 0.995 R²)
mean 448.0 μs (440.9 μs .. 460.3 μs)
std dev 29.61 μs (20.67 μs .. 42.53 μs)
variance introduced by outliers: 59% (severely inflated)
* parsing and formatting times excluded
>> Day 09b
benchmarking...
time 804.4 ms (359.8 ms .. 1.119 s)
0.967 R² (0.884 R² .. 1.000 R²)
mean 885.1 ms (821.3 ms .. 932.5 ms)
std dev 63.24 ms (32.74 ms .. 85.67 ms)
variance introduced by outliers: 20% (moderately inflated)
* parsing and formatting times excluded
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.emptyHere 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) <$> dHopefully 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
Numinstance to compute the deltas,V2 dx dy = p1 - p0 - Using the
Functorinstance to compute the step,(divgcf) <$> 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) asteroidsFor 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))
asteroidsSo 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 - p0We 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 stationOur 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 10a
benchmarking...
time 7.687 ms (7.219 ms .. 8.198 ms)
0.978 R² (0.962 R² .. 0.991 R²)
mean 7.302 ms (7.030 ms .. 7.569 ms)
std dev 768.0 μs (693.5 μs .. 838.2 μs)
variance introduced by outliers: 61% (severely inflated)
* parsing and formatting times excluded
>> Day 10b
benchmarking...
time 12.55 ms (11.79 ms .. 13.16 ms)
0.975 R² (0.954 R² .. 0.991 R²)
mean 11.86 ms (11.55 ms .. 12.43 ms)
std dev 1.050 ms (745.5 μs .. 1.385 ms)
variance introduced by outliers: 46% (moderately inflated)
* parsing and formatting times excluded
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
.| painterMoverFor 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 MemoryGiven 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.emptyThe 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 -- whiteIt'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 rightAnd that's it!
fullBot :: Memory -> Conduit i o (State Hull) ()
fullBot m = sensor
.| intcodeVM m
.| painterMoverWe can run a full pipeline using runConduit:
part1 :: Memory -> Int
part1 m = M.size m
where
Hull _ p m = execState (runConduit (fullBot m)) emptyHullPart 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)) whiteHullThe 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:
- How am I generating input?
- 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.
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 m0And there you have it! You can now do the rest of the code described in this post :)
>> Day 11a
benchmarking...
time 449.3 ms (374.1 ms .. 515.5 ms)
0.997 R² (0.988 R² .. 1.000 R²)
mean 403.5 ms (374.3 ms .. 429.0 ms)
std dev 34.00 ms (11.84 ms .. 45.12 ms)
variance introduced by outliers: 22% (moderately inflated)
* parsing and formatting times excluded
>> Day 11b
benchmarking...
time 31.67 ms (29.17 ms .. 33.66 ms)
0.986 R² (0.977 R² .. 0.998 R²)
mean 30.37 ms (29.72 ms .. 31.37 ms)
std dev 1.643 ms (899.0 μs .. 2.083 ms)
variance introduced by outliers: 17% (moderately inflated)
* parsing and formatting times excluded
Reflection not yet written -- please check back later!
>> Day 12a
benchmarking...
time 248.2 μs (233.7 μs .. 267.1 μs)
0.978 R² (0.971 R² .. 0.992 R²)
mean 240.7 μs (234.2 μs .. 250.2 μs)
std dev 26.73 μs (18.80 μs .. 33.75 μs)
variance introduced by outliers: 83% (severely inflated)
>> Day 12b
benchmarking...
time 15.12 ms (13.55 ms .. 17.28 ms)
0.934 R² (0.892 R² .. 0.972 R²)
mean 14.23 ms (13.58 ms .. 15.10 ms)
std dev 1.896 ms (1.363 ms .. 2.424 ms)
variance introduced by outliers: 63% (severely inflated)
Reflection not yet written -- please check back later!
>> Day 13a
benchmarking...
time 42.40 ms (38.76 ms .. 48.23 ms)
0.958 R² (0.904 R² .. 1.000 R²)
mean 40.91 ms (39.80 ms .. 43.60 ms)
std dev 3.462 ms (1.759 ms .. 5.517 ms)
variance introduced by outliers: 32% (moderately inflated)
* parsing and formatting times excluded
>> Day 13b
benchmarking...
time 2.334 s (2.030 s .. 2.700 s)
0.997 R² (0.990 R² .. 1.000 R²)
mean 2.514 s (2.422 s .. 2.662 s)
std dev 139.8 ms (18.88 ms .. 179.8 ms)
variance introduced by outliers: 19% (moderately inflated)
* parsing and formatting times excluded
Reflection not yet written -- please check back later!
>> Day 14a
benchmarking...
time 130.7 μs (128.3 μs .. 132.1 μs)
0.996 R² (0.994 R² .. 0.998 R²)
mean 126.4 μs (123.0 μs .. 129.1 μs)
std dev 9.511 μs (8.121 μs .. 11.33 μs)
variance introduced by outliers: 70% (severely inflated)
* parsing and formatting times excluded
>> Day 14b
benchmarking...
time 8.646 ms (8.020 ms .. 9.150 ms)
0.964 R² (0.934 R² .. 0.982 R²)
mean 7.490 ms (7.178 ms .. 7.848 ms)
std dev 853.1 μs (683.1 μs .. 1.141 ms)
variance introduced by outliers: 63% (severely inflated)
* parsing and formatting times excluded
Reflection not yet written -- please check back later!
>> Day 15a
benchmarking...
time 195.5 ms (186.7 ms .. 208.4 ms)
0.998 R² (0.993 R² .. 1.000 R²)
mean 195.1 ms (189.5 ms .. 198.4 ms)
std dev 6.097 ms (2.312 ms .. 9.424 ms)
variance introduced by outliers: 14% (moderately inflated)
* parsing and formatting times excluded
>> Day 15b
benchmarking...
time 720.1 ms (700.8 ms .. 729.6 ms)
1.000 R² (1.000 R² .. 1.000 R²)
mean 765.9 ms (745.4 ms .. 800.7 ms)
std dev 33.24 ms (2.260 ms .. 41.42 ms)
variance introduced by outliers: 19% (moderately inflated)
* parsing and formatting times excluded
Reflection not yet written -- please check back later!
>> Day 16a
benchmarking...
time 514.9 ms (501.2 ms .. 560.7 ms)
0.999 R² (0.996 R² .. 1.000 R²)
mean 508.7 ms (502.8 ms .. 517.0 ms)
std dev 9.011 ms (500.4 μs .. 11.27 ms)
variance introduced by outliers: 19% (moderately inflated)
* parsing and formatting times excluded
>> Day 16b
benchmarking...
time 75.94 ms (73.22 ms .. 78.71 ms)
0.997 R² (0.988 R² .. 0.999 R²)
mean 70.10 ms (65.48 ms .. 72.83 ms)
std dev 6.082 ms (2.578 ms .. 8.929 ms)
variance introduced by outliers: 26% (moderately inflated)
* parsing and formatting times excluded
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:
- Is there a spot in front of us? If so, step forward and repeat from step 1.
- Otherwise, is there a spot to our left? If so, turn left and repeat from step 1.
- Otherwise, is there a spot to our right? If so, turn right and repeat from step 1.
- 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 + turnRightTo 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 _ = NothingAlright, 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:
- We can pick
Afrom any prefix of our string. - Once we break out occurrences of our chosen
Afrom the string, we can now pickBfrom any unbroken prefix of the remaining string. - Once we break out occurrences of our chosen
Bfrom the string, we can now pickCfrom any unbroken prefix of the remaining string. - Once we break out occurrences of our chosen
Cfrom 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 xNote 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 17a
benchmarking...
time 34.75 μs (33.59 μs .. 35.54 μs)
0.992 R² (0.989 R² .. 0.995 R²)
mean 35.01 μs (34.28 μs .. 35.80 μs)
std dev 2.588 μs (2.018 μs .. 3.052 μs)
variance introduced by outliers: 74% (severely inflated)
* parsing and formatting times excluded
>> Day 17b
benchmarking...
time 79.25 μs (76.04 μs .. 82.05 μs)
0.992 R² (0.987 R² .. 0.995 R²)
mean 78.15 μs (76.07 μs .. 80.95 μs)
std dev 8.138 μs (6.600 μs .. 11.35 μs)
variance introduced by outliers: 84% (severely inflated)
* parsing and formatting times excluded
Reflection not yet written -- please check back later!
>> Day 18a
benchmarking...
time 1.804 s (1.790 s .. 1.834 s)
1.000 R² (1.000 R² .. 1.000 R²)
mean 1.807 s (1.801 s .. 1.813 s)
std dev 7.492 ms (2.513 ms .. 10.14 ms)
variance introduced by outliers: 19% (moderately inflated)
* parsing and formatting times excluded
>> Day 18b
benchmarking...
time 204.5 ms (200.1 ms .. 211.5 ms)
0.999 R² (0.998 R² .. 1.000 R²)
mean 204.6 ms (203.5 ms .. 207.5 ms)
std dev 2.346 ms (265.4 μs .. 3.631 ms)
variance introduced by outliers: 14% (moderately inflated)
* parsing and formatting times excluded
Reflection not yet written -- please check back later!
>> Day 19a
benchmarking...
time 2.231 s (2.119 s .. 2.376 s)
0.999 R² (0.999 R² .. 1.000 R²)
mean 2.169 s (2.145 s .. 2.201 s)
std dev 32.39 ms (10.45 ms .. 43.71 ms)
variance introduced by outliers: 19% (moderately inflated)
* parsing and formatting times excluded
>> Day 19b
benchmarking...
time 4.059 s (3.953 s .. 4.288 s)
1.000 R² (NaN R² .. 1.000 R²)
mean 4.118 s (4.064 s .. 4.197 s)
std dev 76.09 ms (23.61 ms .. 102.4 ms)
variance introduced by outliers: 19% (moderately inflated)
* parsing and formatting times excluded
Reflection not yet written -- please check back later!
>> Day 20a
benchmarking...
time 10.31 ms (9.635 ms .. 11.18 ms)
0.955 R² (0.921 R² .. 0.980 R²)
mean 11.90 ms (11.34 ms .. 12.67 ms)
std dev 1.885 ms (1.328 ms .. 2.511 ms)
variance introduced by outliers: 74% (severely inflated)
* parsing and formatting times excluded
>> Day 20b
benchmarking...
time 31.48 ms (30.85 ms .. 32.01 ms)
0.998 R² (0.992 R² .. 1.000 R²)
mean 31.60 ms (31.31 ms .. 32.22 ms)
std dev 896.0 μs (495.7 μs .. 1.448 ms)
* parsing and formatting times excluded
Reflection not yet written -- please check back later!
>> Day 21a
benchmarking...
time 78.59 ms (75.14 ms .. 81.47 ms)
0.996 R² (0.987 R² .. 1.000 R²)
mean 78.30 ms (77.21 ms .. 80.88 ms)
std dev 2.591 ms (498.2 μs .. 3.973 ms)
* parsing and formatting times excluded
>> Day 21b
benchmarking...
time 1.924 s (1.592 s .. 2.418 s)
0.993 R² (0.979 R² .. NaN R²)
mean 1.836 s (1.774 s .. 1.884 s)
std dev 68.63 ms (27.58 ms .. 95.04 ms)
variance introduced by outliers: 19% (moderately inflated)
* parsing and formatting times excluded
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 -> pJust 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 permsAnd...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 bigPermPart 2, I think, is where the group theory really shines.
-
We take advantage of
stimes, which uses repeated squaring. That means that to computestimes 8 x, instead of usingx <> x <> x <> x <> x <> x <> x <> x, it doeslet x2 = x <> x; x4 = x2 <> x2 in x4 <> x4, essentially cutting down the number of multiplications exponentially. This means that to computestimes 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.
-
Remember how
p @$ 2019gives us the index that2019is sent to? Well, we want something else in this case. We basically want the index that will be sent to2020. So, we want to reverse the function. Luckily, since our function is just a permutation, it is easy to reverse this: justinvertthe 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 nwhich "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) * iEach 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)) 0So 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 0Inverting 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 0Which 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' * bAnd...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 bigPermAs 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 22a
benchmarking...
time 12.16 μs (11.82 μs .. 12.31 μs)
0.991 R² (0.985 R² .. 0.994 R²)
mean 10.93 μs (10.49 μs .. 11.41 μs)
std dev 1.483 μs (1.424 μs .. 1.602 μs)
variance introduced by outliers: 92% (severely inflated)
* parsing and formatting times excluded
>> Day 22b
benchmarking...
time 34.44 μs (34.09 μs .. 34.95 μs)
0.998 R² (0.996 R² .. 0.999 R²)
mean 34.48 μs (34.25 μs .. 34.75 μs)
std dev 859.0 ns (695.5 ns .. 1.274 μs)
variance introduced by outliers: 24% (moderately inflated)
* parsing and formatting times excluded
Reflection not yet written -- please check back later!
>> Day 23a
benchmarking...
time 24.20 ms (21.95 ms .. 26.26 ms)
0.974 R² (0.942 R² .. 0.994 R²)
mean 26.17 ms (24.80 ms .. 29.95 ms)
std dev 4.533 ms (1.170 ms .. 7.601 ms)
variance introduced by outliers: 72% (severely inflated)
* parsing and formatting times excluded
>> Day 23b
benchmarking...
time 516.3 ms (381.8 ms .. 708.0 ms)
0.985 R² (0.957 R² .. 1.000 R²)
mean 493.1 ms (446.1 ms .. 514.9 ms)
std dev 35.85 ms (925.8 μs .. 50.40 ms)
variance introduced by outliers: 20% (moderately inflated)
* parsing and formatting times excluded
Reflection not yet written -- please check back later!
>> Day 24a
benchmarking...
time 2.093 ms (1.914 ms .. 2.431 ms)
0.938 R² (0.899 R² .. 0.996 R²)
mean 2.000 ms (1.950 ms .. 2.098 ms)
std dev 215.8 μs (112.1 μs .. 363.4 μs)
variance introduced by outliers: 72% (severely inflated)
* parsing and formatting times excluded
>> Day 24b
benchmarking...
time 1.163 s (1.077 s .. 1.227 s)
0.999 R² (0.999 R² .. 1.000 R²)
mean 1.144 s (1.110 s .. 1.161 s)
std dev 31.79 ms (3.031 ms .. 40.34 ms)
variance introduced by outliers: 19% (moderately inflated)
* parsing and formatting times excluded
Reflection not yet written -- please check back later!
>> Day 25a
benchmarking...
time 2.480 s (2.285 s .. 2.579 s)
0.999 R² (0.998 R² .. 1.000 R²)
mean 2.324 s (2.255 s .. 2.379 s)
std dev 78.63 ms (47.26 ms .. 95.70 ms)
variance introduced by outliers: 19% (moderately inflated)
* parsing and formatting times excluded