Day 18: Ram Run
Megathread guidelines
- Keep top level comments as only solutions, if you want to say something other than a solution put it in a new post. (replies to comments can be whatever)
- You can send code in code blocks by using three backticks, the code, and then three backticks or use something such as https://topaz.github.io/paste/ if you prefer sending it through a URL
FAQ
- What is this?: Here is a post with a large amount of details: https://programming.dev/post/6637268
- Where do I participate?: https://adventofcode.com/
- Is there a leaderboard for the community?: We have a programming.dev leaderboard with the info on how to join in this post: https://programming.dev/post/6631465
3 points
Haskell
solution
import Control.Arrow
import Control.Monad
import Control.Monad.RWS
import Control.Monad.Trans.Maybe
import Data.Array (inRange)
import Data.Char
import Data.Set qualified as S
import Text.ParserCombinators.ReadP hiding (get)
parse = fst . last . readP_to_S (endBy ((,) <$> num <*> (char ',' *> num)) $ char '\n')
where
num = read <$> munch1 isDigit
bounds = ((0, 0), (70, 70))
bfs :: MaybeT (RWS (S.Set (Int, Int)) () (S.Set (Int, Int), [(Int, (Int, Int))])) Int
bfs = do
(seen, (c, x) : xs) <- get
modify . second $ const xs
isCorrupt <- asks (S.member x)
when (not (x `S.member` seen) && not isCorrupt && inRange bounds x) $
modify (S.insert x *** (++ ((succ c,) <$> neighbors x)))
if x == snd bounds
then return c
else bfs
neighbors (x, y) = [(succ x, y), (pred x, y), (x, succ y), (x, pred y)]
findPath = fst . flip (evalRWS (runMaybeT bfs)) (mempty, [(0, (0, 0))]) . S.fromList
part1 = findPath . take 1024
search corrupt = go 0 (length corrupt)
where
go l r = case (findPath $ take (pred m) corrupt, findPath $ take m corrupt) of
(Just _, Just _) -> go m r
(Just _, Nothing) -> Just $ pred m
(Nothing, Nothing) -> go l m
where
m = (l + r) `div` 2
part2 = liftM2 fmap (!!) search
main = getContents >>= print . (part1 &&& part2) . parse
3 points
*
Haskell
Not really happy with performance, binary search would speed this up a bunch, takes about 1.3 seconds.
Update: Binary search got it to 960 ms.
Code
import Data.Maybe
import qualified Data.Set as S
type Coord = (Int, Int)
parse :: String -> [Coord]
parse = map (read . ('(' :) . (++ ")")) . takeWhile (not . null) . lines
shortest :: Coord -> [Coord] -> Maybe Int
shortest (x0, y0) corrupted' = go $ S.singleton (x0 - 1, y0 - 1)
where
corrupted = S.fromList corrupted'
inside (x, y)
| x < 0 = False
| y < 0 = False
| x0 <= x = False
| y0 <= y = False
| otherwise = True
grow cs = S.filter inside $ S.unions $ cs :
[ S.mapMonotonic (\(x, y) -> (x + dx, y + dy)) cs
| (dx, dy) <- [(-1, 0), (0, -1), (0, 1), (1, 0)]
]
go visited
| (0, 0) `S.member` visited = Just 0
| otherwise = case grow visited S.\\ corrupted of
visited'
| S.size visited == S.size visited' -> Nothing
| otherwise -> succ <$> go visited'
main :: IO ()
main = do
rs <- parse <$> getContents
let size = (71, 71)
print $ fromJust $ shortest size $ take 1024 rs
putStrLn $ init $ tail $ show $ last $ zipWith const (reverse rs) $
takeWhile (isNothing . shortest size) $ iterate init rs
Faster (binary search)
import Data.Maybe
import qualified Data.Set as S
type Coord = (Int, Int)
parse :: String -> [Coord]
parse = map (read . ('(' :) . (++ ")")) . takeWhile (not . null) . lines
shortest :: Coord -> [Coord] -> Maybe Int
shortest (x0, y0) corrupted' = go $ S.singleton (x0 - 1, y0 - 1)
where
corrupted = S.fromList corrupted'
inside (x, y)
| x < 0 = False
| y < 0 = False
| x0 <= x = False
| y0 <= y = False
| otherwise = True
grow cs = S.filter inside $ S.unions $ cs :
[ S.mapMonotonic (\(x, y) -> (x + dx, y + dy)) cs
| (dx, dy) <- [(-1, 0), (0, -1), (0, 1), (1, 0)]
]
go visited
| (0, 0) `S.member` visited = Just 0
| otherwise = case grow visited S.\\ corrupted of
visited'
| S.size visited == S.size visited' -> Nothing
| otherwise -> succ <$> go visited'
solve2 :: Coord -> [Coord] -> Coord
solve2 r0 corrupted = go 0 $ length corrupted
where
go a z
| succ a == z = corrupted !! a
| otherwise =
let x = (a + z) `div` 2
in case shortest r0 $ take x corrupted of
Nothing -> go a x
Just _ -> go x z
main :: IO ()
main = do
rs <- parse <$> getContents
let size = (71, 71)
print $ fromJust $ shortest size $ take 1024 rs
putStrLn $ init $ tail $ show $ solve2 size rs
2 points
Javascript
Reused my logic from Day 16. For part two I manually changed the bytes (i on line 271) to narrow in on a solution faster, but this solution should solve it eventually.
https://blocks.programming.dev/Zikeji/c8fdef54f78c4fb6a79cf1dc5551ff4d
2 points
Haskell
I did an easy optimization for part 2, but it’s not too slow without.
Solution
import Control.Monad
import Data.Ix
import Data.List
import Data.Map qualified as Map
import Data.Maybe
import Data.Set (Set)
import Data.Set qualified as Set
readInput :: String -> [(Int, Int)]
readInput = map readCoords . lines
where
readCoords l = let (a, _ : b) = break (== ',') l in (read a, read b)
findRoute :: (Int, Int) -> Set (Int, Int) -> Maybe [(Int, Int)]
findRoute goal blocked = go Set.empty (Map.singleton (0, 0) [])
where
go seen paths
| Map.null paths = Nothing
| otherwise =
(paths Map.!? goal)
`mplus` let seen' = Set.union seen (Map.keysSet paths)
paths' =
(`Map.withoutKeys` seen')
. foldl' (flip $ uncurry Map.insert) Map.empty
. concatMap (\(p, path) -> (,p : path) <$> step p)
$ Map.assocs paths
in go seen' paths'
step (x, y) = do
(dx, dy) <- [(0, -1), (0, 1), (-1, 0), (1, 0)]
let p' = (x + dx, y + dy)
guard $ inRange ((0, 0), goal) p'
guard $ p' `Set.notMember` blocked
return p'
dropAndFindRoutes goal skip bytes =
let drops = drop skip $ zip bytes $ drop 1 $ scanl' (flip Set.insert) Set.empty bytes
in zip (map fst drops) $ scanl' go (findRoute goal (snd $ head drops)) $ tail drops
where
go route (p, blocked) = do
r <- route
if p `elem` r then findRoute goal blocked else route
main = do
input <- readInput <$> readFile "input18"
let routes = dropAndFindRoutes (70, 70) 1024 input
print $ length <$> (snd . head) routes
print $ fst <$> find (isNothing . snd) routes
2 points
*
Dart
I knew keeping my search code from day 16 would come in handy, I just didn’t expect it to be so soon.
For Part 2 it finds that same path (laziness on my part), then does a simple binary chop to home in on the last valid path. (was then searches for the first block that will erm block that path, and re-runs the search after that block has dropped, repeating until blocked. Simple but okay. )
90 lines, half of which is my copied search method. Runs in a couple of seconds which isn’t great, but isn’t bad. Binary chop dropped it to 200ms.
import 'dart:math';
import 'package:collection/collection.dart';
import 'package:more/more.dart';
var d4 = <Point<num>>[Point(0, 1), Point(0, -1), Point(1, 0), Point(-1, 0)];
solve(List<String> lines, int count, Point end, bool inPart1) {
var blocks = (lines
.map((e) => e.split(',').map(int.parse).toList())
.map((p) => Point<num>(p[0], p[1]))).toList();
var blocksSofar = blocks.take(count).toSet();
var start = Point(0, 0);
Map<Point, num> fNext(Point here) => {
for (var d in d4
.map((d) => d + here)
.where((e) =>
e.x.between(start.x, end.x) &&
e.y.between(start.y, end.y) &&
!blocksSofar.contains(e))
.toList())
d: 1
};
int fHeur(Point here) => 1;
bool fAtEnd(Point here) => here == end;
var cost = aStarSearch<Point>(start, fNext, fHeur, fAtEnd);
if (inPart1) return cost.first;
var lo = count, hi = blocks.length;
while (lo <= hi) {
var mid = (lo + hi) ~/ 2;
blocksSofar = blocks.take(mid).toSet();
cost = aStarSearch<Point>(start, fNext, fHeur, fAtEnd);
(cost.first > 0) ? lo = mid + 1 : hi = mid - 1;
}
var p = blocks[lo - 1];
return '${p.x},${p.y}';
}
part1(lines, count, end) => solve(lines, count, end, true);
part2(lines, count, end) => solve(lines, count, end, false);
That search method
/// Returns cost to destination, plus list of routes to destination.
/// Does Dijkstra/A* search depending on whether heuristic returns 1 or
/// something better.
(num, List<List<T>>) aStarSearch<T>(T start, Map<T, num> Function(T) fNext,
int Function(T) fHeur, bool Function(T) fAtEnd,
{multiplePaths = false}) {
var cameFrom = SetMultimap<T, T>.fromEntries([MapEntry(start, start)]);
var ends = <T>{};
var front = PriorityQueue<T>((a, b) => fHeur(a).compareTo(fHeur(b)))
..add(start);
var cost = <T, num>{start: 0};
while (front.isNotEmpty) {
var here = front.removeFirst();
if (fAtEnd(here)) {
ends.add(here);
continue;
}
var ns = fNext(here);
for (var n in ns.keys) {
var nCost = cost[here]! + ns[n]!;
if (!cost.containsKey(n) || nCost < cost[n]!) {
cost[n] = nCost;
front.add(n);
cameFrom.removeAll(n);
cameFrom[n].add(here);
}
if (multiplePaths && cost[n] == nCost) cameFrom[n].add(here);
}
}
Iterable<List<T>> routes(T h) sync* {
if (h == start) {
yield [h];
return;
}
for (var p in cameFrom[h]) {
yield* routes(p).map((e) => e + [h]);
}
}
if (ends.isEmpty) return (-1, []);
var minCost = ends.map((e) => cost[e]!).min;
ends = ends.where((e) => cost[e]! == minCost).toSet();
return (minCost, ends.fold([], (s, t) => s..addAll(routes(t).toList())));
}
