src/advent13/advent13.hs

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