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
This post has been voted on by the SteemSTEM curation team and voting trail in collaboration with @curie.
If you appreciate the work we are doing then consider voting both projects for witness by selecting stem.witness and curie!
For additional information please join us on the SteemSTEM discord and to get to know the rest of the community!
I couldn't recall what the identity function is, which is why I used (+0) instead. It's
id.@markgritter : Adding #steemSTEM tag will bring more visibility to curators. I know you got steemstem votes in past without tagging. But I am just saying that there is a chance that curators miss your quality content. And thats why I am suggesting this. :)