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 Left and 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