-
Notifications
You must be signed in to change notification settings - Fork 0
Reflections 2018
2016 / 2018 / 2019 / 2020 / 2021 / 2022 / 2023 / 2024
- Day 1
- Day 2
- Day 3
- Day 4
- Day 5
- Day 6
- Day 7 (benchmark only)
- Day 8
- Day 9
- Day 10
- Day 11
- Day 12
- Day 13
- Day 14 (benchmark only)
- Day 15
- Day 16
- Day 17 (benchmark only)
- Day 18 (benchmark only)
- Day 19 (benchmark only)
- Day 20
- Day 21 (benchmark only)
- Day 22 (benchmark only)
- Day 23 (benchmark only)
- Day 24 (benchmark only)
- Day 25 (benchmark only)
Top / Prompt / Code / Standalone
Day 1 is a pretty straightforward functional programming sort of pipeline.
The first part is just a sum:
day01a :: [Int] -> Int
day01a = sumThe second part is a little tricker, but we can get a list of running sums with
scanl (+) 0. We need to find the first repeated item in that list of
running totals. We can do this using explicit recursion down the linked list:
import qualified Data.Set as S
firstRepeated :: [Int] -> Maybe Int
firstRepeated = go S.empty
where
go seen (x:xs)
| x `S.member` seen = Just x -- this is it, chief
| otherwise = go (x `S.insert` seen) xs -- we have to look furhterAnd so then we have our full pipeline. We do need to remember to loop the input
list infinitely by using cycle.
day01b :: [Int] -> Maybe Int
day01b = firstRepeated . scanl (+) 0 . cycleWe do need a parser, and we can leverage readMaybe:
parseItem :: String -> Maybe Int
parseItem = readMaybe . filter (/= '+')
parseList :: String -> Maybe [Int]
parseList = traverse parseItem . linesOne small extra bonus note --- as a Haskeller, we are always taught to be
afraid of explicit recursion. So, the implementation of firstRepeated is a
little unsettling. We can write it using a catamorphism instead, from the
recursion-schemes library:
firstRepeated :: [Int] -> Maybe Int
firstRepeated xs = cata go xs S.empty
where
go :: ListF Int (Set Int -> Maybe Int)
-> Set Int
-> Maybe Int
go Nil _ = Nothing
go (Cons x searchRest) seen
| x `S.member` seen = Just x -- this is it, chief
| otherwise = searchRest (x `S.insert` seen) -- we have to look furthercata wraps up a very common sort of recursion, so we can safely write our
firstRepeated as a non-recursive function.
>> Day 01a
benchmarking...
time 2.073 μs (2.060 μs .. 2.089 μs)
1.000 R² (1.000 R² .. 1.000 R²)
mean 2.079 μs (2.071 μs .. 2.086 μs)
std dev 25.58 ns (21.37 ns .. 30.82 ns)
* parsing and formatting times excluded
>> Day 01b
benchmarking...
time 69.88 ms (69.68 ms .. 70.34 ms)
1.000 R² (1.000 R² .. 1.000 R²)
mean 69.30 ms (69.04 ms .. 69.49 ms)
std dev 433.2 μs (299.3 μs .. 629.2 μs)
* parsing and formatting times excluded
Top / Prompt / Code / Standalone
Day 2 part 1 works out nicely in a functional paradigm because it can be seen as just building a couple of frequency tables.
I often use this function to generate a frequency table of values in a list:
import qualified Data.Map as M
freqs :: [a] -> Map a Int
freqs = M.fromListWith (+) . map (,1)Day 2 part 1 is then to:
- Build a frequency map for chars for each line
- Aggregate all of the seen frequencies in each line
- Build a frequency map of the seen frequencies
- Look up how often freq 2 and freq 3 occurred, and then multiply
So we have:
day02a :: [String] -> Maybe Int
day02a = mulTwoThree
. freqs
. concatMap (nubOrd . M.elems . freqs)
mulTwoThree :: Map Int Int -> Maybe Int
mulTwoThree mp = (*) <$> M.lookup 2 mp <*> M.lookup 3 mpPart 2 for this day is pretty much the same as Part 2 for day 1, only instead of finding the first item that has already been seen, we find the first item who has any neighbors who had already been seen.
import Control.Lens
import qualified Data.Set as S
firstNeighbor :: [String] -> Maybe (String, String)
firstNeighbor = go S.empty
where
go seen (x:xs) = case find (`S.member` seen) (neighbors x) of
Just n -> Just (x, n)
Nothing -> go (x `S.insert` seen) xs
go _ [] = Nothing
neighbors :: String -> [String]
neighbors xs = [ xs & ix i .~ newChar
| i <- [0 .. length xs - 1]
| newChar <- ['a'..'z']
]firstNeighbor will return the first item who has a neighbor that has already
been seen, along with that neighbor.
The answer we need to return is the common letters between the two strings, so we can write a function to only keep common letters between two strings:
onlySame :: String -> String -> String
onlySame xs = catMaybes . zipWith (\x y -> x <$ guard (x == y)) xs
-- > onlySame "abcd" "abed" == "abd"And that's pretty much the entire pipeline:
day02a :: [String] -> Maybe String
day02a = fmap (uncurry onlySame) . firstNeighborParsing is just lines :: String -> [String], which splits a string on lines.
>> Day 02a
benchmarking...
time 466.7 μs (465.8 μs .. 467.6 μs)
1.000 R² (1.000 R² .. 1.000 R²)
mean 466.6 μs (466.2 μs .. 467.3 μs)
std dev 1.876 μs (1.503 μs .. 2.523 μs)
* parsing and formatting times excluded
>> Day 02b
benchmarking...
time 37.80 ms (37.66 ms .. 37.97 ms)
1.000 R² (1.000 R² .. 1.000 R²)
mean 37.74 ms (37.69 ms .. 37.82 ms)
std dev 135.3 μs (98.29 μs .. 169.7 μs)
* parsing and formatting times excluded
Top / Prompt / Code / Standalone
Day 3 brings back one of my favorite data structures in Haskell -- Map (Int, Int)! It's basically a sparse grid. It maps coordinates to values at each
coordinate.
We're going to use V2 Int (from linear) instead of (Int, Int) (they're
the same thing), because we get to use the overloaded + operator to do
point-wise addition. Let's also define a rectangle specification and claim
record type to keep things clean:
type Coord = V2 Int
data Rect = R { rStart :: Coord
, rSize :: Coord
}
data Claim = C { cId :: Int
, cRect :: Rect
}Now, we want to make a function that, given a rectangle, produces a list of
every coordinate in that rectangle. We can take advantage of range from
Data.Ix, which enumerates all coordinates between two corners:
tiles :: Rect -> [Coord]
tiles (R start size) = range (topLeft, bottomRight)
where
topLeft = start
bottomRight = start + size - 1 -- V2 has a Num instanceNow we can stake all of the claims and lay all of the tiles down into a Map Coord Int, a frequency map of coordinates that have been claimed (and how many
times they have been claimed):
layTiles :: [Rect] -> Map Coord Int
layTiles = freqs . concatMap tiles(Reusing freqs from Day 2)
From there, we need to count how many frequencies we observe are greater than 1. We can do that by filtering and counting how many are left.
import qualified Data.Map as M
day03a :: [Rect] -> Int
day03a = length . filter (>= 2) . M.elems . layTilesFor day03, we can use find to search our list of claims by id's,
[(Int, Rect)] and find any claim that is completely non-overlapping.
We can check if a claim is non-overlapping or not by checking our map of staked
tiles and making sure that every square in the claim has exactly frequency 1.
noOverlap :: Map Coord Int -> Rect -> Bool
noOverlap tilesClaimed r = all isAlone (tiles r)
where
isAlone c = M.lookup c tilesClaimed == Just 1And that's our Part 2:
day03b :: [Claim] -> Maybe Int
day03b ts = cId <$> find (noOverlap stakes . cRect) ts
where
stakes = layTiles (map snd ts)Parsing for this one is a little tricky, but we can get away with just clearing
out all non-digit characters and using words to split up a string into its
constituent words, and readMaybe to read each one.
parseLine :: String -> Maybe Claim
parseLine = mkLine
. mapMaybe readMaybe
. words
. map onlyDigits
where
mkLine [i,x0,y0,w,h] = Just $ Claim i (R (V2 x0 y0) (V2 w h))
mkLine _ = Nothing
onlyDigits c
| isDigit c = c
| otherwise = ' '>> Day 03a
benchmarking...
time 224.3 ms (216.2 ms .. 232.2 ms)
0.999 R² (0.999 R² .. 1.000 R²)
mean 223.4 ms (220.8 ms .. 225.6 ms)
std dev 3.073 ms (1.968 ms .. 4.187 ms)
variance introduced by outliers: 14% (moderately inflated)
>> Day 03b
benchmarking...
time 208.1 ms (202.6 ms .. 212.8 ms)
1.000 R² (0.999 R² .. 1.000 R²)
mean 206.7 ms (204.8 ms .. 209.1 ms)
std dev 2.866 ms (1.683 ms .. 4.133 ms)
variance introduced by outliers: 14% (moderately inflated)
Top / Prompt / Code / Standalone
Day 4 was fun because it's something that, on the surface, sounds like it requires a state machine to run through a stateful log and accumulate a bunch of time sheets.
However, if we think of the log as just a stream of tokens, we can look at at it as parsing this stream of tokens into time sheets -- no state or mutation required.
First, the types at play:
type Minute = Finite 60
type TimeCard = Map Minute Int
data Time = T { _tYear :: Integer
, _tMonth :: Integer
, _tDay :: Integer
, _tHour :: Finite 24
, _tMinute :: Minute
}
deriving (Eq, Ord)
newtype Guard = G { _gId :: Int }
deriving (Eq, Ord)
data Action = AShift Guard
| ASleep
| AWakeNote that we have a bunch of "integer-like" quantities going on: the
year/month/day/hour/minute, the guard ID, and the "frequency" in the TimeCard
frequency map. Just to help us accidentally not mix things up (like I
personally did many times), we'll make them all different types. A Minute is
a Finite 60 (Finite 60, from the finite-typelits library, is a type that
is basically the integers limited from 0 to 59). Our hours are Finite 24.
Our Guard ID will be a newtype Guard, just so we don't accidentally mix it up
with other types.
Now, after parsing our input, we have a Map Time Action: a map of times to
actions committed at that time. The fact that we store it in a Map ensures
that the log items are ordered and unique.
We now essentially want to parse a stream of (Time, Action) pairs into a Map Guard TimeCard: A map of TimeCards indexed by the guard that has that time
card.
To do that, we'll use the parsec library, which lets us parse over streams of
arbitrary token type. Our parser type will take a (Time, Action) stream:
import qualified Text.Parsec as P
type Parser = P.Parsec [(Time, Action)] ()A Parser Blah will be a parser that, given a stream of (Time, Action)
pairs, will aggregate them into a value of type Blah.
Turning our stream into a Map Guard TimeCard is now your standard
run-of-the-mill parser combinator program.
-- | We define a nap as an `ASleep` action followed by an `AWake` action. The
-- result is a list of minutes slept.
nap :: Parser [Minute]
nap = do
(T _ _ _ _ m0, ASleep) <- P.anyToken
(T _ _ _ _ m1, AWake ) <- P.anyToken
pure [m0 .. m1 - 1] -- we can do this because m0 < m1 always in the
-- input data.
-- | We define a a guard's shift as a `AShift g` action, followed by
-- "many" naps. The result is a list of minutes slept along with the ID of the
-- guard that slept them.
guardShift :: Parser (Guard, [Minute])
guardShift = do
(_, AShift g) <- P.anyToken
napMinutes <- concat <$> many (P.try nap)
pure (g, napMinutes)
-- | A log stream is many guard shifts. The result is the accumulation of all
-- of those shifts into a massive `Map Guard [Minute]` map, but turning all of
-- those [Minutes] into a frequency map instead by using `fmap freqs`.
buildTimeCards :: Parser (Map Guard TimeCard)
buildTimeCards = do
shifts <- M.fromListWith (++) <$> many guardShift
pure (fmap freqs shifts)We re-use the handy freqs :: Ord a => [a] -> Map a Int function, to build a
frequency map, from Day 2.
We can run a parser on our [(Time, Action)] stream by using P.parse :: Parser a -> [(Time, Action)] -> SourceName -> Either ParseError a.
The rest of the challenge involves "the X with the biggest Y" situations, which all boil down to "The key-value pair with the biggest some property of value".
We can abstract over this by writing a function that will find the key-value pair with the biggest some property of value:
import qualified Data.List.NonEmpty as NE
maximumValBy
:: (a -> a -> Ordring) -- ^ function to compare values
-> Map k a
-> Maybe (k, a) -- ^ biggest key-value pair, using comparator function
maximumValBy c = fmap (maximumBy (c `on` snd)) . NE.nonEmpty . M.toList
-- | Get the key-value pair with highest value
maximumVal :: Ord a => Map k a -> Maybe (k, a)
maximumVal = maximumValBy compareWe use fmap (maximumBy ...) . NE.nonEmpty as basically a "safe maximum",
allowing us to return Nothing in the case that the map was empty. This works
because NE.nonEmpty will return Nothing if the list was empty, and Just
otherwise...meaning that maximumBy is safe since it is never given to a
non-empty list.
The rest of the challenge is just querying this Map Guard TimeCard using some
rather finicky applications of the predicates specified by the challenge.
Luckily we have our safe types to keep us from mixing up different concepts by
accident.
eitherToMaybe :: Either e a -> Maybe a
eitherToMaybe = either (const Nothing) Just
day04a :: Map Time Action -> Maybe Int
day04a logs = do
-- build time cards
timeCards <- eitherToMaybe $ P.parse buildTimeCards "" (M.toList logs)
-- get the worst guard/time card pair, by finding the pair with the
-- highest total minutes slept
(worstGuard , timeCard) <- maximumValBy (comparing sum) timeCards
-- get the minute in the time card with the highest frequency
(worstMinute, _ ) <- maximumVal timeCard
-- checksum
pure $ _gId worstGuard * fromIntegral worstMinute
day04b :: Map Time Action -> Maybe Int
day04b logs = do
-- build time cards
timeCards <- eitherToMaybe $ P.parse buildTimeCards "" (M.toList logs)
-- build a map of guards to their most slept minutes
let worstMinutes :: Map Guard (Minute, Int)
worstMinutes = M.mapMaybe maximumVal timeCards
-- find the guard with the highest most-slept-minute
(worstGuard, (worstMinute, _)) <- maximumValBy (comparing snd) worstMinutes
-- checksum
pure $ _gId worstGuard * fromIntegral worstMinuteLike I said, these are just some complicated queries, but they are a direct translation of the problem prompt. The real interesting part is the building of the time cards, I think! And not necessarily the querying part.
Parsing, again, can be done by stripping the lines of spaces and using
words and readMaybes. We can use packFinite :: Integer -> Maybe (Finite n) to get our hours and minutes into the Finite type that T expects.
parseLine :: String -> Maybe (Time, Action)
parseLine str = do
[y,mo,d,h,mi] <- traverse readMaybe timeStamp
t <- T y mo d <$> packFinite h <*> packFinite mi
a <- case rest of
"falls":"asleep":_ -> Just ASleep
"wakes":"up":_ -> Just AWake
"Guard":n:_ -> AShift . G <$> readMaybe n
_ -> Nothing
pure (t, a)
where
(timeStamp, rest) = splitAt 5
. words
. clearOut (not . isAlphaNum)
$ str>> Day 04a
benchmarking...
time 7.874 ms (7.817 ms .. 7.922 ms)
1.000 R² (0.999 R² .. 1.000 R²)
mean 7.836 ms (7.753 ms .. 7.878 ms)
std dev 171.1 μs (111.5 μs .. 285.6 μs)
>> Day 04b
benchmarking...
time 7.633 ms (7.615 ms .. 7.658 ms)
1.000 R² (1.000 R² .. 1.000 R²)
mean 7.618 ms (7.608 ms .. 7.636 ms)
std dev 39.31 μs (24.75 μs .. 67.41 μs)
Top / Prompt / Code / Standalone
My write-up for this is actually [on my blog, here][d05b]! It involves my group theory/free group/group homomorphism based solution. That's my main reflection, but I also had a method that I wrote before, that I would still like to preserve.
So, preserved here was my original solution involving funkcyCons and foldr:
One of the first higher-order functions you learn about in Haskill is foldr,
which is like a "skeleton transformation" of a list.
That's because in Haskell, a (linked) list is one of two constructors: nil
([]) or cons (:). The list [1,2,3] is really 1:(2:(3:[])).
foldr f z is a function that takes a list replaces all :s with f, and
[]s with zs:
[1,2,3] = 1 : (2 : (3 : []))
foldr f z [1,2,3] = 1 `f` (2 `f` (3 `f` z ))This leads to one of the most famous identities in Haskell: foldr (:) [] xs = xs. That's because if we go in and replace all (:)s with (:), and replace
all []s with []... we get back the original list!
But something we can also do is give foldr a "custom cons". A custom cons
that will go in place of the normal cons.
This problem is well-suited for such a custom cons: instead of normal (:),
we'll write a custom cons that respects the rules of reaction: we can't have
two "anti-letters" next to each other:
anti :: Char -> Char -> Bool
anti x y = toLower x == toLower y && x /= y
funkyCons :: Char -> String -> String
x `funkyCons` (y:xs)
| anti x y = xs
| otherwise = x:y:xs
x `funkyCons` [] = [x]So, foldr funkyCons [] will go through a list and replace all (:) (cons)
with funkyCons, which will "bubble up" the reaction.
So, that's just the entire part 1!
day05a :: String -> Int
day05a = length . foldr funkyCons []For part 2 we can just find the minimum length after trying out every character.
day05b :: String -> Int
day05b xs = minimum [ length $ foldr funkyCons [] (remove c xs)
| c <- ['a' .. 'z']
]
where
remove c = filter ((/= c) . toLower)(Note that in the actual input, there is a trailing newline, so in practice we have to strip it from the input.)
>> Day 05a
benchmarking...
time 2.975 ms (2.936 ms .. 3.007 ms)
0.999 R² (0.999 R² .. 0.999 R²)
mean 2.773 ms (2.729 ms .. 2.811 ms)
std dev 130.0 μs (104.5 μs .. 151.8 μs)
variance introduced by outliers: 30% (moderately inflated)
>> Day 05b
benchmarking...
time 22.61 ms (22.49 ms .. 22.73 ms)
1.000 R² (1.000 R² .. 1.000 R²)
mean 22.54 ms (22.41 ms .. 22.61 ms)
std dev 200.0 μs (99.94 μs .. 362.1 μs)
Top / Prompt / Code / Standalone
Day 6 Part 1 has us build a Voronoi Diagram, and inspect properties of it. Again, it's all very functional already, since we just need, basically:
- A function to get a voronoi diagram from a set of points
- A function to query the diagram for properties we care about
Along the way, types will help us write our programs, because we constantly will be asking the compiler for "what could go here" sort of things; it'll also prevent us from putting the wrong pieces together!
We're going to leverage the linear library again, for its V2 Int type
for our points. It has a very useful Num and Foldable instance, which we
can use to write our distance function:
type Point = V2 Int
distance :: Point -> Point -> Int
distance x y = sum $ abs (x - y)We're going to be representing our voronoi diagram using a Map Point Point: a
map of points to the location of the "Site" they are assigned to.
We can generate such a map by getting a Set Point (a set of all points within
our area of interest) and using M.fromSet :: (Point -> Point) -> Set Point -> Map Point Point, to assign a Site to each point.
First, we build a bounding box so don't need to generate an infinite map. The
boundingBox function will take a non-empty list of points (from
Data.List.NonEmpty) and return a V2 Point, which the lower-left and
upper-right corners of our bounding box.
We need to iterate through the whole list and accumulate the minimum and
maximums of x and y. We can do it all in one pass by taking advantage of the
(Semigroup a, Semigroup b) => Semigroup (a, b) instance, the Min and Max
newtype wrappers to give us the appropriate semigroups, and using foldMap1 :: Semigroup m => (a -> m) -> NonEmpty a -> m:
import Data.List.NonEmpty (NonEmpty(..))
import Data.Semigroup.Foldable
type Box = V2 Point
boundingBox :: NonEmpty Point -> Box
boundingBox ps = V2 xMin yMin `V2` V2 xMax yMax
where
(Min xMin, Min yMin, Max xMax, Max yMax) = flip foldMap1 ps $ \(V2 x y) ->
(Min x, Min y, Max x, Max y)(Note that we can just use foldMap, because Min and Max have a Monoid
instance because Int is bounded. But that's no fun! And besides, what if we
had used Integer?)
(Also note that this could potentially blow up the stack, because tuples in Haskell are lazy. If we cared about performance, we'd use a strict tuple type instead of the lazy tuple. In this case, since we only have on the order of a few thousand points, it's not a huge deal)
Next, we write a function that, given a non-empty set of sites and a point we wish to label, return the label (site location) of that point.
We do this by making a NonEmpty (Point, Int) dists that pair up sites to
the distance between that site and the point.
We need now to find the minimum distance in that NonEmpty. But not only
that, we need to find the unique minimum, or return Nothing if we don't
have a unique minimum.
To do this, we can use NE.head . NE.groupWith1 snd . NE.sortWith snd. This
will sort the NonEmpty on the second item (the distance Int), which puts
all of the minimal distances in the front. NE.groupWith1 snd will then group
together the pairs with matching distances, moving all of the minimal distance
to the first item in the list. Then we use the total NE.head to get the
first item: the non-empty list with the minimal distances.
Then we can pattern match on (closestSite, minDist) :| [] to prove that this
"first list" has exactly one item, so the minimum is unique.
labelVoronoi
:: NonEmpty Point -- ^ set of sites
-> Point -- ^ point to label
-> Maybe Point -- ^ the label, if unique
labelVoronoi sites p = do
(closestSite, _) :| [] <- Just
. NE.head
. NE.groupWith1 snd
. NE.sortWith snd
$ dists
pure closestSite
where
dists = sites <&> \site -> (site, distance p site)Once we have our voronoi diagram Map Point Point (map of points to
nearest-site locations), we can use our freqs :: [Point] -> Map Point Int function
that we've used many times to get a Map Point Int, or a map from Site points to
Frequencies --- essentially a map of Sites to the total area of the cells
assigned to them. The problem asks us what the size of the largest cell is, so
that's the same as asking for the largest frequency, maximum.
queryVoronoi :: Map Point Point -> Int
queryVeronoi = maximum . freqs . M.elemsOne caveat: we need to ignore cells that are "infinite". To that we can create the set of all Sitse that touch the border, and then filter out all points in the map that are associated with a Site that touches the border.
cleanVoronoi :: Box -> Map Point Point -> Map Point Point
cleanVoronoi (V2 (V2 xMin yMin) (V2 xMax yMax)) voronoi =
M.filter (`S.notMember` edges) voronoi
where
edges = S.fromList
. mapMaybe (\(point, site) -> site <$ guard (onEdge point))
. M.toList
$ voronoi
onEdge (V2 x y) = or [ x == xMin, x == xMax, y == yMin, y == yMax ]We turn edges into a Set (instead of just a list) because of the fast
S.notMember function, to check if a Site ID is in the set of edge-touching
ID's.
Finally, we need to get a function from a bounding box Box to [Point]: all
of the points in that bounding box. Luckily, this is exactly what the Ix
instance of V2 Int gets us:
import qualified Data.Ix as Ix
bbPoints :: Box -> [Point]
bbPoints (V2 mins maxs) = Ix.range (mins, maxs)And so Part 1 is:
day06a :: NonEmpty Point -> Int
day06a sites = queryVoronoi cleaned
where
bb = boundingBox sites
voronoi = catMaybes
. M.fromSet (labelVoronoi sites)
. S.fromList
$ bbPoints bb
cleaned = cleanVoronoi bb voronoiBasically, a series of somewhat complex queries (translated straight from the prompt) on a voronoi diagram generated by a set of points.
Part 2 is much simpler; it's just filtering for all the points that have a given function, and then counting how many points there are.
day06b :: NonEmpty Point -> Int
day06b sites = length
. filter ((< 10000) . totalDist)
. bbPoints
. boundingBox
$ sites
where
totalDist p = sum $ distance p <$> sites- Get the bounding box with
boundingBox - Generate all of the points in that bounding box with
bbPoints - Filter those points for just those where their
totalDistis less than 10000 - Find the number of such points
Another situation where the Part 2 is much simpler than Part 1 :)
Our parser isn't too complicated; it's similar to the parsers from the previous parts:
parseLine :: String -> Maybe Point
parseLine = (packUp =<<)
. traverse readMaybe
. words
. clearOut (not . isDigit)
where
packUp [x,y] = Just $ V2 x y
packUp _ = Nothing>> Day 06a
benchmarking...
time 218.8 ms (217.0 ms .. 221.1 ms)
1.000 R² (1.000 R² .. 1.000 R²)
mean 219.7 ms (218.9 ms .. 220.4 ms)
std dev 1.054 ms (589.6 μs .. 1.208 ms)
variance introduced by outliers: 14% (moderately inflated)
* parsing and formatting times excluded
>> Day 06b
benchmarking...
time 59.52 ms (59.16 ms .. 59.75 ms)
1.000 R² (1.000 R² .. 1.000 R²)
mean 59.88 ms (59.73 ms .. 60.01 ms)
std dev 260.1 μs (205.8 μs .. 341.4 μs)
* parsing and formatting times excluded
>> Day 07a
benchmarking...
time 35.85 μs (35.80 μs .. 35.93 μs)
1.000 R² (1.000 R² .. 1.000 R²)
mean 35.86 μs (35.84 μs .. 35.90 μs)
std dev 117.8 ns (90.77 ns .. 156.8 ns)
* parsing and formatting times excluded
>> Day 07b
benchmarking...
time 54.33 μs (54.25 μs .. 54.40 μs)
1.000 R² (1.000 R² .. 1.000 R²)
mean 54.28 μs (54.23 μs .. 54.34 μs)
std dev 192.4 ns (158.2 ns .. 241.2 ns)
* parsing and formatting times excluded
Top / Prompt / Code / Standalone
Another nice one for Haskell! We're just parsing a stream of Ints here :)
import qualified Text.Parsec as P
type Parser = P.Parsec [Int] ()with a Parsec [Int] (), it means that our "tokens" are Int. That means
P.anyToken :: Parser Int will pop the next Int from the stream.
Our Day 1 will be the sum1, which will parse a stream of Ints into the sum
of all the metadatas.
sum1 :: Parser Int
sum1 = do
numChild <- P.anyToken
numMeta <- P.anyToken
childs <- sum <$> replicateM numChild sum1
metas <- sum <$> replicateM numMeta P.anyToken
pure $ childs + metasAnd so part 1 is:
day01a :: [Int] -> Int
day01a xs = fromRight 0 . P.parse sum1 ""Part 2 is similar. Again, we parse a stream of ints into a sum:
sum2 :: Parser Int
sum2 = do
numChild <- P.anyToken
numMeta <- P.anyToken
childs <- replicateM numChild sum2
metas <- replicateM numMeta P.anyToken
pure $ if null childs
then sum metas
else sum . mapMaybe (\i -> childs ^? ix (i - 1)) $ metas
I'm using xs ^? ix i (from lens) as a "safe indexing", that returns Maybe a. We need to remember to index into i - 1 because our indexing starts at
one!
And so part 2 is:
day02a :: [Int] -> Int
day02a = fromRight 0 . P.parse sum1 ""We can get a list of [Int] from a string input using map read . words.
>> Day 08a
benchmarking...
time 1.113 ms (1.107 ms .. 1.121 ms)
0.999 R² (0.999 R² .. 1.000 R²)
mean 1.107 ms (1.097 ms .. 1.115 ms)
std dev 30.34 μs (23.04 μs .. 41.54 μs)
variance introduced by outliers: 16% (moderately inflated)
* parsing and formatting times excluded
>> Day 08b
benchmarking...
time 802.9 μs (797.8 μs .. 807.2 μs)
0.999 R² (0.999 R² .. 1.000 R²)
mean 808.1 μs (798.5 μs .. 824.9 μs)
std dev 46.63 μs (7.157 μs .. 86.23 μs)
variance introduced by outliers: 48% (moderately inflated)
* parsing and formatting times excluded
Top / Prompt / Code / Standalone
And today features the re-introduction of an Advent of Code staple: the (circular) tape/zipper! I used this data structure last year for days 5, 17, 18 and 23, and I consider them near and dear to my heart as Advent of Code data structures :)
Last year, I wrote my own implementations on the spot, but since then I've come to appreciate the pointed-list library. A circular tape is a circular data structure with a "focus" that you can move back and forth in. This is the data structure that implements exactly what the challenge talks about! It's linear-time on "moving the focus", and constant-time on insertions and deletions.
The center of everything is the place function, which takes a number to place
and a tape to place it in, and returns an updated tape with the "score"
accumulated for that round.
We see that it is mostly a straightforward translation of the problem
statement. If x is a multiple of 23, then we move 7 spaces to the left, and
return the resulting tape with the item deleted. The score is the deleted item
plus x. Otherwise, we just move 2 spaces to the right and insert x, with a
score of 0.
place
:: Int -- ^ number to place
-> PointedList Int -- ^ tape
-> (Int, PointedList Int) -- ^ resulting tape, and scored points
place x l
| x `mod` 23 == 0
= let l' = PL.moveN (-7) l
toAdd = _focus l'
in (toAdd + x, fromJust (PL.deleteRight l'))
| otherwise
= (0, (PL.insertLeft x . PL.moveN 2) l)We wrap it all up with a run function, which is a strict fold over a list of
(currentPlayer, itemToPlace) pairs, accumulating a (scorecard, tape) state
(our scorecard will be a vector where each index is a different player's
score). At each step, we place, and use the result to update our scorecard
and tape. The lens library offers some nice tool for incrementing a given
index of a vector.
run
:: Int -- ^ number of players
-> Int -- ^ Max # of piece
-> V.Vector Int
run numPlayers maxPiece = fst
. foldl' go (V.replicate numPlayers 0, PL.singleton 0)
$ zip players toInsert
where
go (!scores, !tp) (!player, !x) = (scores & ix player +~ pts, tp')
where
(pts, tp') = place x tp
players = (`mod` numPlayers) <$> [0 ..]
toInsert = [1..maxPiece]And that's it! The answer is just the maximal score in the final score vector:
day09a :: Int -> Int -> Int
day09a numPlayers maxPiece = V.maximum (run numPlayers maxPiece)
day09b :: Int -> Int -> Int
day09b numPlayers maxPiece = V.maximum (run numPlayers (maxPiece * 100))From this naive implementation, Part 1 takes 56.ms, and Part 2 takes 4.5s.
>> Day 09a
benchmarking...
time 26.38 ms (26.07 ms .. 26.59 ms)
0.999 R² (0.999 R² .. 1.000 R²)
mean 25.70 ms (25.23 ms .. 25.92 ms)
std dev 683.7 μs (468.6 μs .. 1.104 ms)
* parsing and formatting times excluded
>> Day 09b
benchmarking...
time 2.968 s (2.929 s .. 3.010 s)
1.000 R² (1.000 R² .. 1.000 R²)
mean 2.980 s (2.968 s .. 3.000 s)
std dev 18.75 ms (552.4 μs .. 23.16 ms)
variance introduced by outliers: 19% (moderately inflated)
* parsing and formatting times excluded
Top / Prompt / Code / Standalone
I originally did this by running a simulation, parting the velocity and points
into two lists and using zipWith (+) for the simulation. However, I found a
much nicer closed-form version that [I wrote about in my blog][d10b]!
>> Day 10a
benchmarking...
time 53.57 μs (53.41 μs .. 53.69 μs)
1.000 R² (1.000 R² .. 1.000 R²)
mean 53.24 μs (53.17 μs .. 53.34 μs)
std dev 319.9 ns (260.8 ns .. 393.6 ns)
* parsing and formatting times excluded
>> Day 10b
benchmarking...
time 19.74 μs (19.71 μs .. 19.79 μs)
1.000 R² (1.000 R² .. 1.000 R²)
mean 19.71 μs (19.69 μs .. 19.75 μs)
std dev 95.08 ns (81.40 ns .. 117.6 ns)
* parsing and formatting times excluded
Top / Prompt / Code / Standalone
Day 11 is a nice opportunity to demonstrate dynamic programming in a purely functional language like Haskell.
Once we define a function to get a power level based on a serial number:
type Point = V2 Int
powerLevel :: Int -> Point -> Int
powerLevel sid (V2 x y) = hun ((rid * y + sid) * rid) - 5
where
hun = (`mod` 10) . (`div` 100)
rid = x + 10We can create a Map of of Point to power level, by creating the set of all
points (using range from Data.Ix) and using M.fromSet with a function.
mkMap :: Int -> Map Point Int
mkMap i = M.fromSet (powerLevel i)
. S.fromList
$ range (V2 1 1, V2 300 300)Now, both Part 1 and Part 2 involve finding sums of contiguous squares in the input. One popular way to do this quickly for many different sums is to build a [summed-area table][]
summedAreaTable :: Map Point Int -> Map Point Int
summedAreaTable mp = force sat
where
sat = M.mapWithKey go mp
go p0 v = (+ v) . sum . catMaybes $
[ negate <$> M.lookup (p0 - V2 1 1) sat
, M.lookup (p0 - V2 1 0) sat
, M.lookup (p0 - V2 0 1) sat
]This is where the dynamic programming happens: our summed area is sat, and we
define sat in a self-recursive way, using M.mapWithKey go. M.mapWithKey go lazily generates each cell of sat by referring to other cells in sat.
Because of laziness, mapWithKey doesn't do any actual "mapping"; but, rather,
allocates thunks at each value in the map. As soon as these thunks are asked
for, they resolve and are kept as resolved values.
For example, note that go (V2 1 1) v11 does not refer to any other value. So,
the map at V2 1 1 is just v11.
However, go (V2 2 1) v21 depends on one other value: M.lookup (V2 1 1) sat.
But, because we already have evaluated this to v11, all is well; our answer
is v21 + v11.
Now, go (V2 2 2) v22 depends on three other values: it depends on M.lookup (V 1 1) sat, M.lookup (V2 1 2) sat, and M.lookup (V2 1 2) sat. GHC will go
and evaluate the ones it needs to evaluate, caching them in the values of the
map, and then just now return the pre-evaluated results.
In this way, we build the summed area table "lazily" in a self-recursive way.
At the end of it all, we return force sat, which makes sure the entire sat
map is filled out all the way (getting rid of all thunks) when the user
actually tries to use the summed area table.
The rest of this involves just making a list of all possible sums of squares, and finding the maximum of all of them. Because all of our sums of squares are now calculable in O(1) on the size of the square (after we generate our table), the search is very manageable.
fromSAT :: Map Point Int -> Point -> Int -> Int
fromSAT sat (subtract (V2 1 1)->p) n = sum . catMaybes $
[ M.lookup p sat
, M.lookup (p + V2 n n) sat
, negate <$> M.lookup (p + V2 0 n) sat
, negate <$> M.lookup (p + V2 n 0) sat
]
findMaxAny :: Map Point Int -> (Point, Int)
findMaxAny mp = fst . maximumBy (comparing snd)
$ [ ((p, n), fromSAT sat p n)
, n <- [1 .. 300]
, p <- range (V2 1 1, V2 (300 - n + 1) (300 - n + 1))
]
where
sat = summedAreaTable mpNote the benchmarks below are actually using an early-cut-off version of
findMaxAny that I implemented after thinking about ways of optimization.
>> Day 11a
benchmarking...
time 54.18 ms (53.55 ms .. 54.76 ms)
0.999 R² (0.997 R² .. 1.000 R²)
mean 53.98 ms (53.52 ms .. 54.54 ms)
std dev 1.064 ms (579.7 μs .. 1.702 ms)
* parsing and formatting times excluded
>> Day 11b
benchmarking...
time 340.4 ms (318.5 ms .. 357.7 ms)
1.000 R² (0.998 R² .. 1.000 R²)
mean 348.8 ms (344.0 ms .. 353.6 ms)
std dev 5.746 ms (3.558 ms .. 7.010 ms)
variance introduced by outliers: 19% (moderately inflated)
* parsing and formatting times excluded
Top / Prompt / Code / Standalone
Day 12 is made a little more fun with everyone's favorite Haskell data structures: maps and sets! (Note that I've pretty much used Maps and Sets for every challenge, more or less!)
We can represent a "context", or neighborhood, as a Set (Finite 5), where
Finite 5 can be thought of as a type that only contains the numbers 0, 1, 2,
3, and 4 (five elements only). We'll treat 0 as "two to the left", 1 as "one
to the left", 2 as "the current point", 3 as "one to the right", and 4 as "two
to the right". The set will contain the given finite if it is "on" in that
position. So, for example, the context #.##. would be S.fromList [0,2,3].
type Ctx = Set (Finite 5)Our ruleset will be Set Ctx, or a set of neighborhoods. If a given
neighborhood is in the set, then that means that the plant is meant to turn
on. Otherwise, it means that the plant is meant to turn off. So, #.##. => #
would mean that the item S.fromList [0,2,3] is in the ruleset, but ##..# => . would mean that the item S.fromList [0,1,4] is not in the ruleset.
Finally, the type of our "world" is just Set Int. If a plant is "on", then
its index will be in the set. Otherwise, its index will not be in the set.
One nice thing about representing the world as Set Int is that getting the
"sum of all plant IDs that are on" is just sum :: Set Int -> Int :)
Writing our step function is going to be filtering all of the "candidate" positions for the ones that remain "on". That's it! We perform this filter by aggregating the neighborhood around each point and checking if the neighborhood is in the ruleset.
step
:: Set Ctx
-> Set Int
-> Set Int
step ctxs w0 = S.fromDistinctAscList
. filter go
$ [S.findMin w0 - 2 .. S.findMax w0 + 2]
where
go i = neighbs `S.member` ctxs
where
neighbs = S.fromDistinctAscList . flip filter finites $ \j ->
(i - 2 + fromIntegral j) `S.member` w0Part 2 requires a bit of trickery. If we monitor our outputs, we can observe that the entire shape of the world starts to loop after a given amount of time. We can find this loop structure by stepping repeatedly and finding the first item that is repeated, by using a "seen items" set. We have to make sure to "normalize" our representation so that the same shame will be matched no matter what coordinate it starts at. I did this by subtracting out the minimum item in the set, so that the leftmost plant is always at zero.
findLoop
:: Set Ctx
-> Set Pos
-> (Int, Int, Int) -- time to loop, loop size, loop incr
findLoop ctxs w0 = go (M.singleton w0 (0, 0)) 1 w0
where
go !seen !i !w = case M.lookup w'Norm seen of
Nothing -> go (M.insert w'Norm (mn, i) seen) (i + 1) w'
Just (seenMn, seenI) -> (seenI, i - seenI, mn - seenMn)
where
w' = step ctxs w
(mn, w'Norm) = normalize w'
normalize w = (mn, S.map (subtract mn) w)
where
mn = S.findMin wAnd now we can be a little clever using divMod to factor out 50 billion into
the "initialization", the "loop amount", and the "amount to increase":
stepN
:: Int
-> Set Pos
-> Set Ctx
-> Set Pos
stepN n w ctx = goN extra
. S.map (+ (loopIncr * looped))
. goN ttl
$ w
where
goN m = (!!! m) . iterate (step ctx)
(ttl, loopSize, loopIncr) = findLoop ctx w
(looped, extra) = (n - ttl) `divMod` loopSize>> Day 12a
benchmarking...
time 707.6 μs (703.2 μs .. 720.5 μs)
1.000 R² (0.999 R² .. 1.000 R²)
mean 706.4 μs (704.9 μs .. 710.1 μs)
std dev 7.595 μs (3.659 μs .. 13.36 μs)
* parsing and formatting times excluded
>> Day 12b
benchmarking...
time 15.84 ms (15.82 ms .. 15.87 ms)
1.000 R² (1.000 R² .. 1.000 R²)
mean 15.82 ms (15.80 ms .. 15.85 ms)
std dev 52.70 μs (38.16 μs .. 86.85 μs)
* parsing and formatting times excluded
Top / Prompt / Code / Standalone
Day 13 is fun because it can be stated in terms of a hylomorphism!
First, our data types:
type Point = V2 Int
data Turn = TurnNW -- ^ a forward-slash mirror @/@
| TurnNE -- ^ a backwards-slash mirror @\\@
| TurnInter -- ^ a four-way intersection
deriving (Eq, Show, Ord)
data Dir = DN | DE | DS | DW
deriving (Eq, Show, Ord, Enum, Bounded)
data Cart = C { _cDir :: Dir
, _cTurns :: Int
}
deriving (Eq, Show)
makeLenses ''Cart
newtype ScanPoint = SP { _getSP :: Point }
deriving (Eq, Show, Num)
instance Ord ScanPoint where
compare = comparing (view _y . _getSP)
<> comparing (view _x . _getSP)
type World = Map Point Turn
type Carts = Map ScanPoint CartWe will be using Map ScanPoint Cart as our priority queue; ScanPoint
newtype-wraps a Point in a way that its Ord instance will give us the
lowest y first, then the lowest x to break ties.
Note that we don't ever have to store any of the "track" positions, | or -.
That's because they don't affect the carts in any way.
Next, we can implement the actual logic of moving a single Cart:
stepCart :: World -> ScanPoint -> Cart -> (ScanPoint, Cart)
stepCart w (SP p) c = (SP p', maybe id turner (M.lookup p' w) c)
where
p' = p + case c ^. cDir of
DN -> V2 0 (-1)
DE -> V2 1 0
DS -> V2 0 1
DW -> V2 (-1) 0
turner = \case
TurnNW -> over cDir $ \case DN -> DE; DE -> DN; DS -> DW; DW -> DS
TurnNE -> over cDir $ \case DN -> DW; DW -> DN; DS -> DE; DE -> DS
TurnInter -> over cTurns (+ 1) . over cDir (turnWith (c ^. cTurns))
turnWith i = case i `mod` 3 of
0 -> turnLeft
1 -> id
_ -> turnLeft . turnLeft . turnLeft
turnLeft DN = DW
turnLeft DE = DN
turnLeft DS = DE
turnLeft DW = DSThere are ways we can the turning and Dir manipulations, but this way already
is pretty clean, I think! We use lens combinators like over to simplify our
updating of carts. If there is no turn at a given coordinate, then the cart
just stays the same, and only the position updates.
Now, to separate out the running of the simulation from the consumption of the results, we can make a type that emits the result of a single step in the world:
data CartLog a = CLCrash Point a -- ^ A crash, at a given point
| CLTick a -- ^ No crashes, just a normal timestep
| CLDone Point -- ^ Only one car left, at a given point
deriving (Show, Functor)And we can use that to implement stepCarts, which takes a "waiting, done"
queue of carts and:
- If
waitingis empty, we dumpdoneback intowaitingand emitCLTickwith our updated state. However, ifdoneis empty, then we are done; emitCLDonewith no new state. - Otherwise, pop an cart from
waitingand move it. If there is a crash, emitCLCrashwith the updated state (with things deleted).
stepCarts
:: World
-> (Carts, Carts)
-> CartLog (Carts, Carts)
stepCarts w (waiting, done) = case M.minViewWithKey waiting of
Nothing -> case M.minViewWithKey done of
Just ((SP lastPos, _), M.null->True) -> CLDone lastPos
_ -> CLTick (done, M.empty)
Just (uncurry (stepCart w) -> (p, c), waiting') ->
case M.lookup p (waiting' <> done) of
Nothing -> CLTick (waiting' , M.insert p c done)
Just _ -> CLCrash (_getSP p) (M.delete p waiting', M.delete p done )Now, we can write our consumers. These will be fed the results of stepCarts
as they are produced. However, the a parameters will actually be the "next
results", in a way:
-- | Get the result of the first crash.
firstCrash :: CartLog (Maybe Point) -> Maybe Point
firstCrash (CLCrash p _) = Just p -- this is it, chief
firstCrash (CLTick p) = p -- no, we have to go deeper
firstCrash (CLDone _ ) = Nothing -- we reached the end of the line, no crash.
-- | Get the final point.
lastPoint :: CartLog Point -> Point
lastPoint (CLCrash _ p) = p -- we have to go deeper
lastPoint (CLTick p) = p -- even deeper
lastPoint (CLDone p ) = p -- we're hereAnd now:
day13a :: World -> Carts -> Maybe Point
day13a w c = (firstCrash `hylo` stepCarts w) (c, M.empty)
day13b :: World -> Carts -> Point
day13b w c = (lastPoint `hylo` stepCarts w) (c, M.empty)The magic of hylo is that, as firstCrash and lastPoint "demand" new
values or points, hylo will ask stepCarts w for them. So, stepCarts w is
iterated as many times as firstCrash and lastPoint needs.
>> Day 13a
benchmarking...
time 7.862 ms (7.760 ms .. 7.998 ms)
0.998 R² (0.996 R² .. 1.000 R²)
mean 7.825 ms (7.780 ms .. 7.892 ms)
std dev 151.0 μs (100.3 μs .. 223.5 μs)
>> Day 13b
benchmarking...
time 13.63 ms (13.55 ms .. 13.70 ms)
1.000 R² (1.000 R² .. 1.000 R²)
mean 13.56 ms (13.52 ms .. 13.62 ms)
std dev 123.4 μs (90.91 μs .. 180.1 μs)
>> Day 14a
benchmarking...
time 383.5 μs (382.8 μs .. 384.3 μs)
1.000 R² (0.999 R² .. 1.000 R²)
mean 388.6 μs (386.5 μs .. 391.6 μs)
std dev 8.666 μs (5.369 μs .. 12.27 μs)
variance introduced by outliers: 14% (moderately inflated)
* parsing and formatting times excluded
>> Day 14b
benchmarking...
time 158.7 ms (156.8 ms .. 160.2 ms)
1.000 R² (0.999 R² .. 1.000 R²)
mean 159.2 ms (158.8 ms .. 160.4 ms)
std dev 994.7 μs (167.4 μs .. 1.479 ms)
variance introduced by outliers: 12% (moderately inflated)
* parsing and formatting times excluded
Top / Prompt / Code / Standalone
This one feels complex at first (a generate-check-generate-check loop)...if you take a generate-check loop, you also have to be sure to make sure you check the case of 1 or 2 added digits.
However, it becomes much simpler if you separate the act of generation and checking as two different things. Luckily, with Haskell, this is fairly easy with lazily linked lists.
chocolatePractice :: [Int]
chocolatePractice = 3 : 7 : go 0 1 (Seq.fromList [3,7])
where
go !p1 !p2 !tp = newDigits ++ go p1' p2' tp'
where
sc1 = tp `Seq.index` p1
sc2 = tp `Seq.index` p2
newDigits = digitize $ sc1 + sc2
tp' = tp <> Seq.fromList newDigits
p1' = (p1 + sc1 + 1) `mod` length tp'
p2' = (p2 + sc2 + 1) `mod` length tp'
digitize :: Int -> [Int]
digitize ((`divMod` 10)->(x,y))
| x == 0 = [y]
| otherwise = [x,y]We use go to lazily generate new items as they are demanded. Once the user
consumes all of the newDigits asks for more, go will be asked to generate
new digits. The important thing is that this is demand-driven.
We keep track of the current tape using Seq from Data.Sequence for its O(1)
appends and O(log) indexing -- the two things we do the most. We could also
get away with pre-allocation with vectors for amortized O(1) suffix appends and
O(1) indexing, as well.
Note that chocolatePractice is effectively the same for every per-user input
data. It's just a (lazily generated) list of all of the chocolate practice digits.
Part 1 then is just a drop then a take:
day14a :: Int -> [Int]
day14a n = take 10 (drop n chocolatePractice)Part 2, we can use isPrefixOf from Data.List and check every tails until
we get one that does have our digit list as a prefix:
substrLoc :: [Int] -> [Int] -> Maybe Int
substrLoc xs = length
. takeWhile (not . (xs `isPrefixOf`))
. tails
day14b :: [Int] -> [Int]
day14b xs = xs `substrLoc` cholcatePracticeNote that chocolatePractice is essentially just a futumorphism, so this whole
thing can be stated in terms of a chronomorphism. I don't know if there would
be any advantage in doing so. But it's interesting to me that I solved Day 13
using a hylomorphism, and now Day 14 using what is essentially a chronomorphism
... so maybe recursion-schemes is the killer app for Advent of Code? :)
A note on benchmarks -- it's very difficult to benchmark Day 14, because I
couldn't get ghc to stop memoizing chocolatePractice. This means my repeated
benchmarks kept on re-using the stored list.
However, using time, I timed Part 1 to about 180ms, and Part 2 to 10s.
>> Day 15a
benchmarking...
time 2.538 s (2.496 s .. 2.567 s)
1.000 R² (1.000 R² .. 1.000 R²)
mean 2.534 s (2.527 s .. 2.541 s)
std dev 8.059 ms (554.1 μs .. 11.28 ms)
variance introduced by outliers: 19% (moderately inflated)
>> Day 15b
benchmarking...
time 13.27 s (13.21 s .. 13.37 s)
1.000 R² (1.000 R² .. 1.000 R²)
mean 13.26 s (13.24 s .. 13.27 s)
std dev 13.45 ms (5.983 ms .. 18.75 ms)
variance introduced by outliers: 19% (moderately inflated)
Top / Prompt / Code / Standalone
Today was fun because I got to re-use some techniques I discussed in a blog
post I've written in the past: Send More Money: List and
StateT. I talk about using StateT over [] to do
implement prolog-inspired constraint satisfaction searches while taking
advantage of laziness.
First of all, our types. I'll be using the vector-sized library with
finite-typelits to help us do safe indexing. A Vector n a is a vector
of n as, and a Finite n is a legal index into such a vector. For
example, a Vector 4 Int is a vector of 4 Ints, and Finite 4 is 0, 1, 2,
or 3.
import Data.Vector.Sized (Vector)
import Data.Finite (Finite)
type Reg = Vector 4 Int
data Instr a = I { _iOp :: a
, _iInA :: Finite 4
, _iInB :: Finite 4
, _iOut :: Finite 4
}
deriving (Show, Functor)
data Trial = T { _tBefore :: Reg
, _tInstr :: Instr (Finite 16)
, _tAfter :: Reg
}
deriving Show
data OpCode = OAddR | OAddI
| OMulR | OMulI
| OBanR | OBanI
| OBorR | OBorI
| OSetR | OSetI
| OGtIR | OGtRI | OGtRR
| OEqIR | OEqRI | OEqRR
deriving (Show, Eq, Ord, Enum, Bounded)We can leave Instr parameterized over the opcode type so that we can use it
with Finite 16 initially, and OpCode later.
We do need to implement the functionality of each op, which we can do by
pattern matching on an OpCode. We use some lens functionality to simplify
some of the editing of indices, but we could also just manually modify indices.
runOp :: Instr OpCode -> Reg -> Reg
runOp I{..} = case _iOp of
OAddR -> \r -> r & V.ix _iOut .~ r ^. V.ix _iInA + r ^. V.ix _iInB
OAddI -> \r -> r & V.ix _iOut .~ r ^. V.ix _iInA + fromIntegral _iInB
OMulR -> \r -> r & V.ix _iOut .~ r ^. V.ix _iInA * r ^. V.ix _iInB
OMulI -> \r -> r & V.ix _iOut .~ r ^. V.ix _iInA * fromIntegral _iInB
OBanR -> \r -> r & V.ix _iOut .~ r ^. V.ix _iInA .&. r ^. V.ix _iInB
OBanI -> \r -> r & V.ix _iOut .~ r ^. V.ix _iInA .&. fromIntegral _iInB
OBorR -> \r -> r & V.ix _iOut .~ r ^. V.ix _iInA .|. r ^. V.ix _iInB
OBorI -> \r -> r & V.ix _iOut .~ r ^. V.ix _iInA .|. fromIntegral _iInB
OSetR -> \r -> r & V.ix _iOut .~ r ^. V.ix _iInA
OSetI -> \r -> r & V.ix _iOut .~ fromIntegral _iInA
OGtIR -> \r -> r & V.ix _iOut . enum .~ (fromIntegral _iInA > r ^. V.ix _iInB )
OGtRI -> \r -> r & V.ix _iOut . enum .~ (r ^. V.ix _iInA > fromIntegral _iInB)
OGtRR -> \r -> r & V.ix _iOut . enum .~ (r ^. V.ix _iInA > r ^. V.ix _iInB )
OEqIR -> \r -> r & V.ix _iOut . enum .~ (fromIntegral _iInA == r ^. V.ix _iInB )
OEqRI -> \r -> r & V.ix _iOut . enum .~ (r ^. V.ix _iInA == fromIntegral _iInB)
OEqRR -> \r -> r & V.ix _iOut . enum .~ (r ^. V.ix _iInA == r ^. V.ix _iInB )Now, from a Trial, we can get a set of OpCodes that are plausible
candidates if the output matches the expected output for a given OpCode, for
the given input.
plausible :: Trial -> Set OpCode
plausible T{..} = S.fromList (filter tryTrial [OAddR ..])
where
tryTrial :: OpCode -> Bool
tryTrial o = runOp (_tInstr { _iOp = o }) _tBefore == _tAfterPart 1 is, then, just counting the trials with three or more plausible candidates:
day16a :: [Trial] -> Int
day16a = length . filter ((>= 3) . S.size . plausible)Part 2 is where we can implement our constraint satisfaction search. Following
this blog post, we can write a search using StateT (Set OpCode) []. Our state will be the OpCodes that we have already used. We
fill up a vector step-by-step, by picking only OpCodes that have not been
used yet:
fillIn :: Set OpCode -> StateT (Set OpCode) [] OpCode
fillIn candidates = do
unseen <- gets (candidates `S.difference`) -- filter only unseen candidates
pick <- lift $ toList unseen -- branch on all unseen candidates
modify $ S.insert pick -- in this branch, 'pick' is seen
pure pick -- return our pick for the branchNow, if we have a map of Finite 16 (op code numbers) to their candidates (a
Map (Finite 16) (Set OpCode)), we can populate all legal
configurations. We'll use Vector 16 OpCode to represent our configuration:
0 will represent the first item, 1 will represent the second, etc. We can
use V.generate :: (Finite n -> m a) -> m (Vector n a), and run our fillIn
action for every Finite n.
fillVector
:: Map (Finite 16) (Set OpCode)
-> StateT (Set OpCode) [] (Vector 16 OpCode)
fillVector candmap = V.generateM $ \i -> do
Just cands <- pure $ M.lookup i candmap
fillIn cands
fromClues
:: Map (Finite 16) (Set OpCode)
-> Maybe (Vector 16 OpCode)
fromClues m = listToMaybe $ evalStateT (fillVector m) S.emptyIf this part is confusing, the blog post explains how
StateT and [], together, give you this short-circuting search behavior!
So our Part 2 is using fromClues from all of the candidates (making sure to
do a set intersection if we get more than one clue for an opcode number), and a
foldl' over our instruction list:
day16b :: [Trial] -> [Instr (Finite 16)] -> Int
day16b ts = V.head . foldl' step (V.replicate 0)
where
candmap = M.fromListWith S.intersection
$ [ (_iOp (_tInstr t), plausible t)
| t <- ts
]
Just opMap = fromClues candmap
step r i = runOp i' r
where
i' = (opMap `V.index`) <$> i>> Day 16a
benchmarking...
time 5.526 ms (5.496 ms .. 5.567 ms)
0.999 R² (0.999 R² .. 1.000 R²)
mean 5.536 ms (5.500 ms .. 5.579 ms)
std dev 102.7 μs (75.91 μs .. 144.8 μs)
>> Day 16b
benchmarking...
time 214.7 ms (213.9 ms .. 215.6 ms)
1.000 R² (1.000 R² .. 1.000 R²)
mean 214.5 ms (214.1 ms .. 214.9 ms)
std dev 537.6 μs (326.9 μs .. 791.3 μs)
variance introduced by outliers: 14% (moderately inflated)
>> Day 17a
benchmarking...
time 34.08 ms (33.67 ms .. 34.43 ms)
1.000 R² (0.999 R² .. 1.000 R²)
mean 33.86 ms (33.69 ms .. 34.03 ms)
std dev 364.3 μs (254.4 μs .. 530.7 μs)
* parsing and formatting times excluded
>> Day 17b
benchmarking...
time 31.61 ms (30.86 ms .. 32.58 ms)
0.998 R² (0.996 R² .. 1.000 R²)
mean 30.99 ms (30.71 ms .. 31.35 ms)
std dev 711.7 μs (512.6 μs .. 952.2 μs)
* parsing and formatting times excluded
>> Day 18a
benchmarking...
time 19.05 ms (18.91 ms .. 19.21 ms)
1.000 R² (0.999 R² .. 1.000 R²)
mean 18.98 ms (18.87 ms .. 19.05 ms)
std dev 213.9 μs (163.1 μs .. 303.9 μs)
>> Day 18b
benchmarking...
time 2.273 s (2.138 s .. 2.491 s)
0.999 R² (0.998 R² .. NaN R²)
mean 2.241 s (2.214 s .. 2.260 s)
std dev 29.24 ms (16.74 ms .. 41.24 ms)
variance introduced by outliers: 19% (moderately inflated)
>> Day 19a
benchmarking...
time 335.8 ms (313.7 ms .. 358.0 ms)
0.999 R² (0.998 R² .. 1.000 R²)
mean 338.9 ms (335.7 ms .. 344.5 ms)
std dev 5.320 ms (100.3 μs .. 6.466 ms)
variance introduced by outliers: 19% (moderately inflated)
>> Day 19b
benchmarking...
time 3.873 s (3.857 s .. 3.912 s)
1.000 R² (1.000 R² .. 1.000 R²)
mean 3.889 s (3.882 s .. 3.897 s)
std dev 9.604 ms (3.697 ms .. 12.62 ms)
variance introduced by outliers: 19% (moderately inflated)
Top / Prompt / Code / Standalone
Like Day 4, this one is made pretty simple with parser combinators! :D
Just for clarity, we will tokenize the stream first -- but it's not strictly necessary.
data Dir = DN | DE | DS | DW
deriving (Show, Eq, Ord)
data RegTok = RTStart
| RTDir Dir
| RTRParen
| RTOr
| RTLParen
| RTEnd
deriving (Show, Eq, Ord)
parseToks :: String -> [RegTok]
parseToks = mapMaybe $ \case
'^' -> Just RTStart
'N' -> Just $ RTDir DN
'E' -> Just $ RTDir DE
'W' -> Just $ RTDir DW
'S' -> Just $ RTDir DS
'|' -> Just RTOr
'(' -> Just RTRParen
')' -> Just RTLParen
'$' -> Just RTEnd
_ -> NothingNow, to write our parser! We will parse our [RegTok] stream into a set of
edges.
import Linear (V2(..))
import qualified Text.Parsec as P
-- V2 Int = (Int, Int), essentially
type Point = V2 Int
data Edge = E Point Point
deriving (Show, Eq, Ord)
-- | Make an edge. Normalizes so we can compare for uniqueness.
mkEdge :: Point -> Point -> Edge
mkEdge x y
| x <= y = E x y
| otherwise = E y x
-- | Parse a stream of `RegTok`. We have a State of the "current point".
type Parser = P.Parsec [RegTok] PointWe either have a "normal step", or a "branching step". The entire way, we accumulate a set of all edges.
tok :: RegTok -> Parser ()
tok t = P.try $ guard . (== t) =<< P.anyToken
-- | `anySteps` is many normal steps or branch steps. Each of these gives an
-- edge, so we union all of their edges together.
anySteps :: Parser (Set Edge)
anySteps = fmap S.unions . P.many $
P.try normalStep P.<|> branchStep
-- | `normalStep` is a normal step without any branching. It is an `RTDir`
-- token, followed by `anySteps`. We add the newly discovered edge to the
-- edges in `anySteps`.
normalStep :: Parser (Set Edge)
normalStep = do
currPos <- P.getState
RTDir d <- P.anyToken
let newPos = currPos + case d of
DN -> V2 0 (-1)
DE -> V2 1 0
DS -> V2 0 1
DW -> V2 (-1) 0
P.setState newPos
S.insert (mkEdge currPos newPos) <$> anySteps
-- | `branchStep` is many `anySteps`, each separated by an `RTOr` token. It is
-- located between `RTRParen` and `RTLParen`.
branchStep :: Parser (Set Edge)
branchStep = (tok RTRParen `P.between` tok RTLParen) $ do
initPos <- P.getState
fmap S.unions . (`P.sepBy` tok RTOr) $ do
P.setState initPos
anyStepsOur final regexp parser is just anySteps seperated by the start and end
tokens:
buildEdges :: Parser (Set Edge)
buildEdges = (tok RTStart `P.between` tok RTEnd) anyStepsNow that we have successfully parsed the "regexp" into a set of edges, we need to follow all of the edges into all of the rooms. We can do this using recursive descent.
neighbs :: Point -> [Point]
neighbs p = (p +) <$> [ V2 0 (-1), V2 1 0, V2 0 1, V2 (-1) 0 ]
roomDistances :: Set Edge -> [Int]
roomDistances es = go 0 S.empty (V2 0 0)
where
go :: Int -> Set Point -> Point -> [Int]
go n seen p = (n :) $
concatMap (go (n + 1) (S.insert p seen)) allNeighbs
where
allNeighbs = filter ((`S.member` es) . mkEdge p)
. filter (`S.notMember` seen)
$ neighbs pWe have to make sure to keep track of the "already seen" rooms. On my first attempt, I forgot to do this!
Anyway, here's Part 1 and Part 2:
day20a :: String -> Int
day20a inp = maximum (roomDistances edges)
where
Right edges = P.runParser buildEdges (V2 0 0) ""
(parseToks inp)
day20b :: String -> Int
day20b inp = length . filter (>= 1000) $ roomDistances edges
where
Right edges = P.runParser buildEdges (V2 0 0) ""
(parseToks inp)>> Day 20a
benchmarking...
time 25.45 ms (25.20 ms .. 25.69 ms)
0.999 R² (0.998 R² .. 1.000 R²)
mean 25.59 ms (25.34 ms .. 26.05 ms)
std dev 716.3 μs (416.3 μs .. 1.107 ms)
>> Day 20b
benchmarking...
time 371.5 ms (362.3 ms .. 378.7 ms)
1.000 R² (1.000 R² .. 1.000 R²)
mean 370.9 ms (369.3 ms .. 372.4 ms)
std dev 1.803 ms (1.174 ms .. 2.123 ms)
variance introduced by outliers: 19% (moderately inflated)
>> Day 21a
benchmarking...
time 57.54 μs (57.44 μs .. 57.60 μs)
1.000 R² (1.000 R² .. 1.000 R²)
mean 57.49 μs (57.43 μs .. 57.56 μs)
std dev 233.9 ns (202.5 ns .. 274.9 ns)
>> Day 21b
benchmarking...
time 208.3 ms (205.3 ms .. 212.4 ms)
1.000 R² (0.999 R² .. 1.000 R²)
mean 206.9 ms (206.1 ms .. 208.1 ms)
std dev 1.363 ms (883.3 μs .. 1.747 ms)
variance introduced by outliers: 14% (moderately inflated)
>> Day 22a
benchmarking...
time 3.793 ms (3.757 ms .. 3.819 ms)
0.999 R² (0.999 R² .. 1.000 R²)
mean 3.648 ms (3.612 ms .. 3.678 ms)
std dev 100.6 μs (84.43 μs .. 124.6 μs)
variance introduced by outliers: 12% (moderately inflated)
* parsing and formatting times excluded
>> Day 22b
benchmarking...
time 270.5 ms (267.8 ms .. 273.8 ms)
1.000 R² (1.000 R² .. 1.000 R²)
mean 269.1 ms (268.2 ms .. 269.9 ms)
std dev 1.087 ms (795.9 μs .. 1.390 ms)
variance introduced by outliers: 16% (moderately inflated)
* parsing and formatting times excluded
>> Day 23a
benchmarking...
time 6.961 ms (6.914 ms .. 7.005 ms)
1.000 R² (0.999 R² .. 1.000 R²)
mean 6.936 ms (6.892 ms .. 6.989 ms)
std dev 128.0 μs (95.11 μs .. 161.2 μs)
>> Day 23b
benchmarking...
time 43.67 ms (42.03 ms .. 44.73 ms)
0.995 R² (0.987 R² .. 1.000 R²)
mean 46.00 ms (45.26 ms .. 47.56 ms)
std dev 2.120 ms (1.196 ms .. 3.400 ms)
variance introduced by outliers: 13% (moderately inflated)
>> Day 24a
benchmarking...
time 11.73 ms (11.70 ms .. 11.77 ms)
1.000 R² (1.000 R² .. 1.000 R²)
mean 11.71 ms (11.70 ms .. 11.73 ms)
std dev 42.57 μs (33.50 μs .. 56.41 μs)
>> Day 24b
benchmarking...
time 216.0 ms (215.6 ms .. 216.3 ms)
1.000 R² (1.000 R² .. 1.000 R²)
mean 215.9 ms (215.7 ms .. 216.1 ms)
std dev 268.3 μs (109.6 μs .. 392.9 μs)
variance introduced by outliers: 14% (moderately inflated)
>> Day 25a
benchmarking...
time 24.47 ms (24.26 ms .. 24.74 ms)
0.998 R² (0.993 R² .. 1.000 R²)
mean 24.82 ms (24.59 ms .. 25.27 ms)
std dev 720.8 μs (432.4 μs .. 1.024 ms)
* parsing and formatting times excluded