Advent of Code day 13 [spoilers]
Day 13 is a simulation of carts on tracks. The track layout is given by an ASCII diagram, like this one:
/->-\ | | /----\ | /-+--+-\ | | | | | v | \-+-/ \-+--/ \------/
I decided it would be better to separate the carts into a different data structure, rather than simulating them "inline" on the track diagram. So when we parse the track, we need to replace all the cart markers by the underlying track. (Fortunately, none of the carts start on an intersection, so this is fairly easy.)
Cart definitions. Note that
Right are constructors already in the Haskell prelude (in fact I used the data type they belong to later.) So I had to come up with a different name. Cart equality is based on position only so that I can sort (to obey the move ordering specified) and use equality checks for collisions.
data Direction = North | South | East | West deriving (Show,Eq) data Turn = TurnRight | Straight | TurnLeft deriving (Show,Eq) data Cart = Cart Int Int Direction Turn deriving (Show) instance Eq Cart where (==) (Cart x y _ _ ) (Cart x' y' _ _ ) = (x == x') && (y == y') instance Ord Cart where compare (Cart x y _ _) (Cart x' y' _ _) | y == y' = compare x x' | otherwise = compare y y'
The tracks will be a 2-D array. You can't make a
UArray (unboxed array) of a
UArray--- oops! So there are two different
Array implementations being used here:
type Tracks = Array Int (UArray Int Char)
Functions to identify the track and the carts, and replace the carts with track elements:
track '-' = True track '|' = True track '\\' = True track '/' = True track '+' = True track ' ' = True track _ = False cart '>' = Just East cart '<' = Just West cart 'v' = Just South cart '^' = Just North cart _ = Nothing cartRepl '>' = '-' cartRepl '<' = '-' cartRepl 'v' = '|' cartRepl '^' = '|'
Parsing is pretty simple, we can parse a row by checking character by character to see if it's a track element or a cart, and build up a list of carts. All the complexity here is due to the need to record cart locations as we're parsing. I thought about taking a second pass over the array to do this instead, but then I'd need to modify the array instead of just getting it right the first time.
parseRow :: Int -> [Char] -> ([Cart],UArray Int Char) parseRow y cs = parseChar 0 cs   where parseChar x  rs ts = (rs, listArray (0,x-1) ts) :: ([Cart],UArray Int Char) parseChar x (c:cs) rs ts | track c = parseChar (x+1) cs rs ( ts ++ [c] ) parseChar x (c:cs) rs ts | isJust . cart $ c = let cart' = Cart x y (fromJust . cart $ c) TurnLeft tracks' = ts ++ [cartRepl c] in parseChar (x+1) cs (cart':rs) tracks' parseInput :: String -> ([Cart],Tracks) parseInput txt = (carts, listArray (0,numRows-1) rows) where allCartsAndRows = map (uncurry parseRow) (zip [0..] (lines txt)) carts = concat (map fst allCartsAndRows) rows = map snd allCartsAndRows numRows = (length rows)
Moving a cart is just pattern-matching:
nextY :: Direction -> Int -> Int nextY North = subtract 1 nextY South = (+1) nextY East = (+0) nextY West = (+0) nextX :: Direction -> Int -> Int nextX North = (+0) nextX South = (+0) nextX East = (+1) nextX West = subtract 1 move :: Cart -> Cart move (Cart x y d t) = Cart (nextX d x) (nextY d y) d t
Turing a cart at a junction or corner is just more pattern-matching. Some of these cases could be cleaned up a bit (we don't actually need four
Straight checks), but this made it easier to check I'd gotten everything:
turn :: Char -> Cart -> Cart turn '|' c = c turn '-' c = c turn '/' (Cart x y North t) = Cart x y East t turn '/' (Cart x y South t) = Cart x y West t turn '/' (Cart x y East t) = Cart x y North t turn '/' (Cart x y West t) = Cart x y South t turn '\\' (Cart x y North t) = Cart x y West t turn '\\' (Cart x y South t) = Cart x y East t turn '\\' (Cart x y East t) = Cart x y South t turn '\\' (Cart x y West t) = Cart x y North t turn '+' (Cart x y North TurnLeft) = Cart x y West Straight turn '+' (Cart x y North Straight) = Cart x y North TurnRight turn '+' (Cart x y North TurnRight) = Cart x y East TurnLeft turn '+' (Cart x y South TurnLeft) = Cart x y East Straight turn '+' (Cart x y South Straight) = Cart x y South TurnRight turn '+' (Cart x y South TurnRight) = Cart x y West TurnLeft turn '+' (Cart x y East TurnLeft) = Cart x y North Straight turn '+' (Cart x y East Straight) = Cart x y East TurnRight turn '+' (Cart x y East TurnRight) = Cart x y South TurnLeft turn '+' (Cart x y West TurnLeft) = Cart x y South Straight turn '+' (Cart x y West Straight) = Cart x y West TurnRight turn '+' (Cart x y West TurnRight) = Cart x y North TurnLeft
So, to update a cart's state we need to move it to a new location, and then turn it based on the track at that location:
charAtCart :: Tracks -> Cart -> Char charAtCart t (Cart x y _ _ ) = ( t ! y ) ! x timeStep :: Tracks -> Cart -> Cart timeStep ts c = let c' = (move c) in turn (charAtCart ts c') c'
While it would be nice to just run timeStep over an entire list of
Cart and then check for collisions, this doesn't work because of situations like:
If both carts move first, then we check for collisions, the carts will quantum-mechanically tunnel through each other. What I decided was to represent each time step as a union type, either a list of carts, or a single cart that collided:
type Collision = Cart type Tick = Either [Cart] Collision
Then the function to update a
Tick can check cart by cart for a collision, and change to the
Right type if so. The
Left type is the list of carts when no collision has yet occurred.
tick :: Tracks -> Tick -> Tick tick ts (Right x) = (Right x) tick ts (Left rs) = moveCarts (sort rs)  where moveCarts  rs = (Left rs) moveCarts (a:as) rs = let r = timeStep ts a in if r `elem` (as ++ rs) then (Right r) else moveCarts as (r:rs)
It's a little unfortunate we have to check both previous carts that already moved, as well as carts that have yet to moved, but I couldn't think of a way to rule them out. The check could be made more efficient if we had a lot of carts to work through, but the number is modest.
Putting it all together, we use
isRight to check for the first element of the infinite list generated by
iterate that is a collision state:
firstCollision tracks carts = find (isRight . snd) timeline where timeline = zip [0..] (iterate (tick tracks) (Left carts))
"tick tracks left carts" sounds like a tongue twister.
Part 2 asks us to have carts disappear when they collide instead of ending the simulation, and report on the last cart left. We can modify
tick pretty easily to do that, and abandon the union type we've been using:
tick2 :: Tracks -> [Cart] -> [Cart] tick2 ts rs = moveCarts (sort rs)  where moveCarts  rs = rs moveCarts (a:as) rs = let r = timeStep ts a in if r `elem` (as ++ rs) then moveCarts (delete r as) (delete r rs) else moveCarts as (r:rs) lastCart tracks carts = find (null . tail . snd) timeline where timeline = zip [0..] (iterate (tick2 tracks) carts)
Full source code: https://github.com/mgritter/aoc2018/blob/master/day13/day13.hs