src/advent13/advent13.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2
   3 import Prelude hiding (Left, Right)
   4 import Data.List
   5 import Data.Tuple (swap)
   6 import qualified Data.Map.Strict as M
   7 import Data.Map.Strict ((!))
   8
   9 -- import Debug.Trace
  10
  11 type Coord = (Int, Int) -- x, y
  12 data Cell = Horizontal | Vertical | TopLeft | TopRight | Junction deriving (Show, Eq)
  13 data Direction = Up | Right | Down | Left deriving (Show, Eq, Ord, Enum, Bounded)
  14 data Decision = Anticlockwise | Straight | Clockwise deriving (Show, Eq, Ord, Enum, Bounded)
  15 data Cart = Cart Direction Decision deriving (Eq, Show)
  16 type Layout = M.Map Coord Cell
  17 type Carts = M.Map Coord Cart
  18
  19 main :: IO ()
  20 main = do
  21     text <- readFile "data/advent13.txt"
  22     let (layout, carts) = parse text
  23     putStrLn $ showCoord $ part1 carts layout
  24     putStrLn $ showCoord $ part2 carts layout
  25
  26 part1 :: Carts -> Layout -> Coord
  27 part1 carts layout = collisionSite
  28     where (collisionSite, _, _, _) = propogateUntilCollision (orderedCarts carts) layout carts
  29
  30 part2 :: Carts -> Layout -> Coord
  31 part2 carts layout = propogateUntilOne (orderedCarts carts) layout carts
  32
  33 showCoord :: Coord -> String
  34 showCoord (x, y) = show x ++ "," ++ show y
  35
  36
  37 -- Parsing
  38 parse :: String -> (Layout, Carts)
  39 parse text = foldl' parseRow (M.empty, M.empty) $ zip [0..] (lines text)
  40
  41 parseRow (layout, carts) (y, row) = foldl' parseCellWithY (layout, carts) $ zip [0..] row
  42     where parseCellWithY = parseCell y
  43
  44 parseCell y (layout, carts) (x, cell) =
  45     let here = (x, y)
  46     in case cell of
  47             '-'  -> (M.insert here Horizontal layout, carts)
  48             '|'  -> (M.insert here Vertical layout, carts)
  49             '\\' -> (M.insert here TopLeft layout, carts)
  50             '/'  -> (M.insert here TopRight layout, carts)
  51             '+'  -> (M.insert here Junction layout, carts)
  52             '^'  -> (M.insert here Vertical layout, M.insert here (Cart Up Anticlockwise) carts)
  53             'v'  -> (M.insert here Vertical layout, M.insert here (Cart Down Anticlockwise) carts)
  54             '<'  -> (M.insert here Horizontal layout, M.insert here (Cart Left Anticlockwise) carts)
  55             '>'  -> (M.insert here Horizontal layout, M.insert here (Cart Right Anticlockwise) carts)
  56             _    -> (layout, carts)
  57
  58
  59 -- Moving
  60
  61 -- first argument is the carts left to move this tick.
  62 propogateUntilCollision :: [Coord] -> Layout -> Carts -> (Coord, Coord, [Coord], Carts)
  63 -- propogateUntilCollision cs _ carts | trace ("pUC " ++ show cs ++ " " ++ show carts) False = undefined
  64 -- finished this tick
  65 propogateUntilCollision [] layout carts =
  66     if M.size carts <= 1
  67     then (survivingCoord, survivingCoord, [], carts) -- empty coords list asserts finished a tick with only one cart remaining.
  68     else propogateUntilCollision (orderedCarts carts) layout carts -- start the next tick
  69     where survivingCoord = head $ M.keys carts
  70 -- not finished this tick, so move this cart then move the rest
  71 propogateUntilCollision (c:cs) layout carts =
  72     if c' `M.member` carts
  73     then (c', c, cs, carts)
  74     else propogateUntilCollision cs layout carts'
  75     where cart = carts!c
  76           (c', cart') = moveOnce c cart layout
  77           carts' = M.insert c' cart' $ M.delete c carts
  78
  79 orderedCarts :: Carts -> [Coord]
  80 orderedCarts carts = sortOn swap $ M.keys carts
  81
  82 -- move a cart, without getting as far as collision detection
  83 moveOnce :: Coord -> Cart -> Layout -> (Coord, Cart)
  84 moveOnce coord (Cart direction decision) layout = (coord', (Cart direction'' decision'))
  85     where coord' = takeStep direction coord
  86           direction' = (curve direction (layout!coord'))
  87           (direction'', decision') = junctionTurn (layout!coord') direction' decision
  88
  89 -- keep moving carts until only one left
  90 -- move carts until there's a collision; remove those carts then carry on
  91 propogateUntilOne :: [Coord] -> Layout -> Carts -> Coord
  92 propogateUntilOne coords layout carts =
  93     if null coords' -- only when finished a tick and only one cart remaining.
  94     then c1
  95     else propogateUntilOne coords'' layout carts''
  96     where (c1, c2, coords', carts') = propogateUntilCollision coords layout carts
  97           carts'' = M.delete c1 $ M.delete c2 carts'
  98           coords'' = filter (/= c1) $ filter (/= c2) coords'
  99
 100 -- Move in the current direction
 101 takeStep :: Direction -> Coord -> Coord
 102 takeStep Up (x, y) = (x, y-1)
 103 takeStep Down (x, y) = (x, y+1)
 104 takeStep Left (x, y) = ( x-1, y)
 105 takeStep Right (x, y) = (x+1, y)
 106
 107 curve :: Direction -> Cell -> Direction
 108 curve Up TopLeft = Left
 109 curve Down TopLeft = Right
 110 curve Left TopLeft = Up
 111 curve Right TopLeft = Down
 112 curve Up TopRight = Right
 113 curve Down TopRight = Left
 114 curve Left TopRight = Down
 115 curve Right TopRight = Up
 116 curve d _ = d
 117
 118 junctionTurn :: Cell -> Direction -> Decision -> (Direction, Decision)
 119 junctionTurn Junction direction Anticlockwise = (predW direction, Straight)
 120 junctionTurn Junction direction Straight      = (direction,       Clockwise)
 121 junctionTurn Junction direction Clockwise     = (succW direction, Anticlockwise)
 122 junctionTurn _        direction decision      = (direction, decision)
 123
 124
 125 -- | a `succ` that wraps
 126 succW :: (Bounded a, Enum a, Eq a) => a -> a
 127 succW dir | dir == maxBound = minBound
 128           | otherwise = succ dir
 129
 130 -- | a `pred` that wraps
 131 predW :: (Bounded a, Enum a, Eq a) => a -> a
 132 predW dir | dir == minBound = maxBound
 133           | otherwise = pred dir
 134