<|start_filename|>lib/AdventOfCode.hs<|end_filename|>
module AdventOfCode
  ( loadDay
  , runDay
  , Day(..)
  , module P
  , module S
  ) where

import Text.Parsec as P hiding (State)
import Text.Parsec.String as P
import Search as S
import System.Environment (getArgs)
import Control.Monad (when)

data Day i = Day
  { dayNum :: Int
  , dayParser :: Parser i
  , dayPartA :: i -> IO String
  , dayPartB :: i -> IO String
  }

loadDay :: Day i -> IO i
loadDay d = do
  result <-
    parseFromFile (dayParser d <* eof) ("input/" ++ show (dayNum d) ++ ".txt")
  case result of
    Right input -> return input
    Left e -> error (show e)

runDay :: Day i -> IO ()
runDay d = do
  args <- getArgs
  input <- loadDay d
  when (null args || "a" `elem` args) $
    do putStrLn $ banner "a"
       putStrLn =<< dayPartA d input
  when (null args || "b" `elem` args) $
    do putStrLn $ "\n" ++ banner "b"
       putStrLn =<< dayPartB d input
  where
    banner ab = "==== DAY " ++ show (dayNum d) ++ ab ++ " ====\n"


<|start_filename|>lib/Search.hs<|end_filename|>
-- These are pretty much borrowed verbatim from glguy: see
-- https://github.com/glguy/advent2016/blob/master/lib/Search.hs
module Search
  ( bfs
  , bfsOn
  , astar
  , astarOn
  ) where

import qualified Data.Set as Set
import qualified Data.IntMap as IntMap
import Data.IntMap (IntMap)
import Data.Foldable (foldl')

bfsOn
  :: Ord b
  => (a -> b) -> (a -> [a]) -> a -> [a]
bfsOn rep next start = go Set.empty [start] []
  where
    go _ [] [] = []
    go seen [] ys = go seen (reverse ys) []
    go seen (x:xs) ys
      | rep x `Set.member` seen = go seen xs ys
      | otherwise = x : go (rep x `Set.insert` seen) xs (next x ++ ys)

bfs
  :: Ord a
  => (a -> [a]) -> a -> [a]
bfs = bfsOn id

astar
  :: Ord a
  => (a -> [(a, Int, Int)]) -> a -> [(a, Int)]
astar = astarOn id

astarOn
  :: Ord b
  => (a -> b) -> (a -> [(a, Int, Int)]) -> a -> [(a, Int)]
astarOn rep nexts start = go Set.empty (IntMap.singleton 0 [(0, start)])
  where
    go seen work =
      case pqueueNext work of
        Nothing -> []
        Just ((cost, x), work1)
          | Set.member r seen -> go seen work1
          | otherwise -> (x, cost) : go seen' work2
          where r = rep x
                seen' = Set.insert r seen
                work2 = foldl' addWork work1 (nexts x)
                addWork w (x', stepcost, heuristic) =
                  let cost' = cost + stepcost
                  in cost' `seq` pqueuePush (cost' + heuristic) (cost', x') w

pqueuePush :: Int -> a -> IntMap [a] -> IntMap [a]
pqueuePush k v = IntMap.alter aux k
  where
    aux Nothing = Just [v]
    aux (Just vs) = Just (v : vs)

pqueueNext :: IntMap [a] -> Maybe (a, IntMap [a])
pqueueNext q = do
  ((k, xs), q1) <- IntMap.minViewWithKey q
  case xs of
    [] -> error "Malformed queue"
    [x] -> Just (x, q1)
    x:rest ->
      let q2 = IntMap.insert k rest q1
      in q2 `seq` Just (x, q2)


<|start_filename|>src/Day13.hs<|end_filename|>
module Main where

import AdventOfCode
import Data.Bits (popCount)
import Data.List (nub)
import Data.Tree (Tree)
import qualified Data.Tree as T
import Data.Set (Set)
import qualified Data.Set as S

type Coord = (Int, Int)

puzzleInput = 1350

isOpen :: Coord -> Bool
isOpen (x, y) = even $ bitsSet $ x * x + 3 * x + 2 * x * y + y + y * y + puzzleInput
  where
    bitsSet = popCount

nextPaths :: [Coord] -> [[Coord]]
nextPaths p@(cur:_) = (: p) <$> nextPositions cur
nextPaths _ = undefined

nextPositions :: Coord -> [Coord]
nextPositions (x, y) =
  [ newpos
  | newpos@(x', y') <- [(x + 1, y), (x - 1, y), (x, y + 1), (x, y - 1)]
  , x' >= 0 && y' >= 0
  , isOpen newpos ]

showMap :: Int -> Int -> String
showMap w h = unlines $ showRow <$> [0 .. h]
  where
    showRow y =
      [ if isOpen (x, y)
         then '.'
         else '#'
      | x <- [0 .. w] ]

paths = bfsOn head nextPaths [(1, 1)]

partA = length (head $ dropWhile ((/= (31, 39)) . head) paths) - 1

partB = length $ nub $ concat $ takeWhile ((<= 51) . length) paths

main =
  runDay $
  Day
    13
    (many anyChar)
    (return . show . const partA)
    (return . show . const partB)


<|start_filename|>src/Day14.hs<|end_filename|>
module Main where

import AdventOfCode
import qualified Crypto.Hash as H
import Data.ByteString (ByteString)
import Data.String (fromString)
import Data.List (isInfixOf, tails)
import Control.Arrow ((&&&))

hexMD5 :: String -> String
hexMD5 = show . md5 . fromString
  where
    md5 :: ByteString -> H.Digest H.MD5
    md5 = H.hash

hash :: Int -> String -> Int -> String
hash stretches salt n = iterate hexMD5 (salt ++ show n) !! stretches

keys :: (Int -> String) -> [(Int, String)]
keys hasher = go ((id &&& hasher) <$> [0 ..])
  where
    go (h@(n, s):hs) =
      [ h
      | c <-
         take
           1
           [ x
           | x:y:z:_ <- tails s
           , x == y
           , y == z ]
      , any (replicate 5 c `isInfixOf`) (snd <$> take 1000 hs) ] ++
      go hs

solve stretches = (!! 63) . keys . hash stretches

main =
  runDay $
  Day
    14
    (many1 letter <* newline)
    (return . show . solve 1)
    (return . show . solve 2017)


<|start_filename|>src/Day4.hs<|end_filename|>
module Main where

import AdventOfCode
import Data.List (group, sort, sortBy)

data Room = Room
  { encName :: [String]
  , sectorID :: Int
  , checksum :: String
  } deriving (Show)

real :: Room -> Bool
real room = checksum room == calcChecksum room

decrypt :: Room -> String
decrypt room = unwords $ decryptWord <$> encName room
  where
    decryptWord = map rotateLetter
    rotateLetter l = ([l .. 'z'] ++ ['a' ..]) !! (sectorID room `mod` 26)

calcChecksum :: Room -> String
calcChecksum = take 5 . map snd . sortBy comparison . hist
  where
    hist = map (\s@(c:_) -> (length s, c)) . group . sort . concat . encName
    comparison (l1, c1) (l2, c2) =
      case compare l2 l1 of
        EQ -> compare c1 c2
        x -> x

example = Room ["aaaaa", "bbb", "z", "y", "x"] 123 "abxyz"

example2 = Room ["qzmt", "zixmtkozy", "ivhz"] 343 "abxyz"

parseRoom :: Parser Room
parseRoom =
  Room <$> many1 (many1 letter <* string "-") <*> parseInt <*>
  (string "[" *> many1 letter <* string "]")
  where
    parseInt = read <$> many1 digit

main =
  runDay $
  Day
    4
    (many1 (parseRoom <* newline))
    (return . show . sum . fmap sectorID . filter real)
    (return .
     show . filter (("northpole object storage" ==) . decrypt) . filter real)


<|start_filename|>src/Day20.hs<|end_filename|>
{-# LANGUAGE TupleSections #-}

module Main where

import AdventOfCode
import Data.List (sort)

type IPRange = (Integer, Integer)

rangeLen (a, b) = 1 + (b - a)

parseIP :: Parser IPRange
parseIP = (,) <$> parseInt <*> (char '-' *> parseInt)
  where
    parseInt = read <$> many1 digit

lowest :: [IPRange] -> Integer
lowest = go 1 . combineRanges
  where
    go n [] = n
    go n ((a, _):_)
      | n < a = n
    go _ ((_, b):xs) = go (b + 1) xs

combineRanges :: [IPRange] -> [IPRange]
combineRanges = combine . sort
  where
    combine (r1@(_, b):r2@(a', _):xs)
      | a' > b = r1 : combine (r2 : xs)
    combine ((a, b):(_, b'):xs) = combine ((a, max b b') : xs)
    combine x = x

partA = lowest

partB = (4294967296 -) . sum . map rangeLen . combineRanges

main =
  runDay $
  Day
    20
    (many1 (parseIP <* newline))
    (return . show . partA)
    (return . show . partB)


<|start_filename|>src/Day5.hs<|end_filename|>
module Main where

import AdventOfCode
import Crypto.Hash
import Data.ByteString (ByteString)
import qualified Data.Map as M
import Data.Maybe (catMaybes)
import Data.String (fromString)

hashes :: String -> [String]
hashes seed = hexMD5 . (seed ++) . show <$> [(0 :: Integer) ..]

hexMD5 :: String -> String
hexMD5 = show . md5 . fromString
  where
    md5 :: ByteString -> Digest MD5
    md5 = hash

interesting :: String -> Bool
interesting s = "00000" == take 5 s

interestingHashes :: String -> [String]
interestingHashes seed = filter interesting (hashes seed)

solutionA :: [String] -> String
solutionA hs = take 8 $ (!! 5) <$> hs

solutionB :: [String] -> String
solutionB hs = M.elems $ head $ dropWhile incomplete $ scanl addPair M.empty pairs
  where
    addPair m (p, c) =
      if p `M.member` m
        then m
        else M.insert p c m
    incomplete m = M.keys m /= "01234567"
    pairs = catMaybes $ (posAndChar . drop 5) <$> hs
    posAndChar (p:c:_)
      | p >= '0' && p < '8' = Just (p, c)
    posAndChar _ = Nothing

main =
  runDay $
  Day
    5
    (many1 letter <* newline)
    (return . solutionA . hashes)
    (return . solutionB . hashes)


<|start_filename|>src/Day10.hs<|end_filename|>
module Main where

import AdventOfCode
import Data.Map (Map)
import qualified Data.Map as M
import Control.Monad.State
import Control.Monad.Writer
import Data.List (sort)
import Data.Maybe (fromMaybe)

newtype BotNo =
  BotNo Int
  deriving (Eq, Ord, Show)

newtype OutputNo = OutputNo
  { getOutputNo :: Int
  } deriving (Eq, Ord, Show)

data Receiver
  = BotReceiver BotNo
  | OutputReceiver OutputNo

data Instr
  = PassLowHigh BotNo
                Receiver
                Receiver
  | Input Int
          BotNo

parseInstr :: Parser Instr
parseInstr =
  (Input <$> (string "value " *> number) <*> (string " goes to bot " *> botno)) <|>
  (PassLowHigh <$> (string "bot " *> botno) <*>
   (string " gives low to " *> receiver) <*>
   (string " and high to " *> receiver))
  where
    botno = BotNo <$> number
    number = read <$> many1 digit
    receiver =
      (BotReceiver <$> (string "bot " *> botno)) <|>
      (OutputReceiver . OutputNo <$> (string "output " *> number))

type BotState = WriterT [(OutputNo, Int)] (State (Map BotNo [Int]))

runInstrs :: [Instr] -> BotState ()
runInstrs [] = return ()
runInstrs (Input v b:xs) = putVal b v >> runInstrs xs
runInstrs (p@(PassLowHigh b lo hi):xs) = do
  vals <- getVal b
  case sort vals of
    [v1, v2] -> do
      passVal lo v1
      passVal hi v2
      runInstrs xs
    _ -> runInstrs (xs ++ [p])

passVal :: Receiver -> Int -> BotState ()
passVal (BotReceiver b) v = putVal b v
passVal (OutputReceiver b) v = tell [(b, v)]

getVal :: BotNo -> BotState [Int]
getVal b = (fromMaybe [] . M.lookup b) <$> get

putVal :: BotNo -> Int -> BotState ()
putVal b i = do
  vals <- getVal b
  modify (M.insert b (i : vals))

partA :: [Instr] -> [(BotNo, [Int])]
partA =
  filter (\(_, vs) -> sort vs == [17, 61]) .
  M.toList . flip execState M.empty . runWriterT . runInstrs

partB :: [Instr] -> Int
partB instrs =
  product $ map snd $ filter ((`elem` [0, 1, 2]) . getOutputNo . fst) outputs
  where
    outputs = flip evalState M.empty $ execWriterT (runInstrs instrs)

main =
  runDay $
  Day
    10
    (many1 (parseInstr <* newline))
    (return . show . partA)
    (return . show . partB)


<|start_filename|>src/Day11.hs<|end_filename|>
module Main where

import AdventOfCode
import qualified Data.Set as S
import Data.List (intercalate, find, sort, tails, groupBy)
import Data.Monoid ((<>))
import Data.Function (on)

data Building = Building
  { bLevel :: !Int
  , bItems :: ![(Item, Int)]
  } deriving (Eq, Ord)

data Direction
  = Up
  | Down
  deriving (Eq, Ord, Show)

data ItemType
  = Generator
  | Microchip
  deriving (Eq, Ord)

data Element
  = Thulium
  | Polonium
  | Promethium
  | Ruthenium
  | Cobalt
  | Hydrogen
  | Lithium
  | Elerium
  | Dilithium
  deriving (Eq, Ord, Show)

data Item = Item
  { iType :: !ItemType
  , iElement :: !Element
  } deriving (Eq)

instance Ord Item where
  compare (Item t1 e1) (Item t2 e2) = compare (e1, t1) (e2, t2)

data Step =
  Step !Direction
       ![Item]
  deriving (Show)

instance Show Building where
  show (Building level items) = unlines (showlevel <$> reverse [0 .. 3])
    where
      showlevel n =
        show (n + 1) ++
        (if n == level
           then " > "
           else "   ") ++
        intercalate
          "  "
          [ show i
          | (i, f) <- sort items
          , f == n ]

instance Show Item where
  show (Item Generator e) = "G-" ++ show e
  show (Item Microchip e) = "M-" ++ show e

fingerprint :: Building -> (Int, [[Int]])
fingerprint (Building level items) = (level, sort pairFloors)
  where
    pairFloors = fmap snd <$> groupBy ((==) `on` iElement . fst) (sort items)

bestFrom :: Building -> Maybe (Building, [Step])
bestFrom b = find (complete . fst) (bfsOn (fingerprint . fst) nexts (b, []))

complete :: Building -> Bool
complete (Building _ items) = all ((== 3) . snd) items

isSafe :: Building -> Bool
isSafe (Building _ floors) = all chipIsSafeOnFloor chips
  where
    chips =
      [ (el, fl)
      | (Item Microchip el, fl) <- floors ]
    chipIsSafeOnFloor (el, chipFloor) = null gensHere || el `elem` gensHere
      where
        gensHere =
          [ el'
          | (Item Generator el', f) <- floors
          , f == chipFloor ]

runStep :: Building -> Step -> Building
runStep (Building level floors) (Step dir items) = Building level' floors'
  where
    level' =
      if dir == Up
        then level + 1
        else level - 1
    floors' = maybeMove <$> floors
    maybeMove (i, f) =
      if i `elem` items
        then (i, level')
        else (i, f)

nexts :: (Building, [Step]) -> [(Building, [Step])]
nexts (bldg, steps) =
  [ (bldg', steps ++ [s])
  | s <- possibleSteps bldg
  , let bldg' = runStep bldg s
  , isSafe bldg' ]

possibleSteps :: Building -> [Step]
possibleSteps (Building level floors) =
  Step <$> validDirections <*> onesOrTwos currentItems
  where
    validDirections =
      (if level < 3
         then pure Up
         else mempty) <>
      (if level > 0
         then pure Down
         else mempty)
    currentItems =
      [ i
      | (i, n) <- floors
      , n == level ]

onesOrTwos :: [a] -> [[a]]
onesOrTwos xs =
  [ [x, y]
  | x:ys <- tails xs
  , y <- ys ] <>
  map pure xs

exampleBuilding :: Building
exampleBuilding =
  Building
    0
    [ (Item Microchip Hydrogen, 0)
    , (Item Microchip Lithium, 0)
    , (Item Generator Hydrogen, 1)
    , (Item Generator Lithium, 2)
    ]

buildingA :: Building
buildingA =
  Building
    0
    [ (Item Generator Polonium, 0)
    , (Item Generator Thulium, 0)
    , (Item Microchip Thulium, 0)
    , (Item Generator Promethium, 0)
    , (Item Generator Ruthenium, 0)
    , (Item Microchip Ruthenium, 0)
    , (Item Generator Cobalt, 0)
    , (Item Microchip Cobalt, 0)
    , (Item Microchip Polonium, 1)
    , (Item Microchip Promethium, 1)
    ]

buildingB :: Building
buildingB =
  buildingA
  { bItems =
    bItems buildingA ++
    [ (Item Generator Elerium, 0)
    , (Item Microchip Elerium, 0)
    , (Item Generator Dilithium, 0)
    , (Item Microchip Dilithium, 0)
    ]
  }

solve :: Building -> Maybe Int
solve = fmap (length . snd) . bestFrom

test :: Building -> IO ()
test b = putStrLn $ unlines $ concatMap (\(b', s) -> [b', "", s, ""]) stages
  where
    stages = zip ("" : numberedSteps) (show <$> scanl runStep b steps)
    Just (_, steps) = bestFrom b
    numberedSteps =
      [ show n ++ ": " ++ show s
      | (n, s) <- zip [(1 :: Int) ..] steps ]

main :: IO ()
main =
  runDay $
  Day
    11
    (many anyChar)
    (return . show . const (solve buildingA))
    (return . show . const (solve buildingB))


<|start_filename|>src/Day12.hs<|end_filename|>
module Main where

import AdventOfCode
import Control.Monad.State
import Control.Monad.Reader
import Data.Maybe (fromMaybe)
import Data.Map (Map)
import qualified Data.Map as M

data Reg =
  Reg Char
  deriving (Show)

data Value
  = LitVal Int
  | RegVal Reg
  deriving (Show)

data Instr
  = Copy Value
         Reg
  | JumpNotZero Value
                Int
  | Inc Reg
  | Dec Reg
  deriving (Show)

parseInstr :: Parser Instr
parseInstr =
  (Dec <$> (string "dec " *> reg)) <|> (Inc <$> (string "inc " *> reg)) <|>
  (JumpNotZero <$> (string "jnz " *> val) <*> (string " " *> step)) <|>
  (Copy <$> (string "cpy " *> val) <*> (string " " *> reg))
  where
    reg = Reg <$> letter
    val = (RegVal <$> reg) <|> (LitVal <$> num)
    step = num
    num = do
      sign <- option '+' (char '-')
      digits <- many1 digit
      return $
        (if sign == '-'
           then -1
           else 1) *
        read digits

data SimState = SimState
  { stPos :: Int
  , stRegs :: (Map Char Int)
  }

type Sim = ReaderT [Instr] (State SimState)

run :: Sim ()
run = do
  pos <- gets stPos
  instrs <- ask
  when (pos >= 0 && pos < length instrs) $
    do step <- lift $ runInstr (instrs !! pos)
       modify
         (\st ->
             st
             { stPos = stPos st + step
             })
       run

modifyReg :: Reg -> (Int -> Int) -> State SimState ()
modifyReg r@(Reg n) f = do
  prev <- getReg r
  modify
    (\st ->
        let regs = stRegs st
        in st
           { stRegs = M.insert n (f prev) regs
           })

getReg :: Reg -> State SimState Int
getReg (Reg n) = (fromMaybe 0 . M.lookup n) <$> gets stRegs

getVal :: Value -> State SimState Int
getVal (LitVal v) = return v
getVal (RegVal r) = getReg r

runInstr :: Instr -> State SimState Int
runInstr (Copy val reg) = (getVal val >>= modifyReg reg . const) >> return 1
runInstr (JumpNotZero val step) = do
  v <- getVal val
  return $
    if v /= 0
      then step
      else 1
runInstr (Inc reg) = modifyReg reg (+ 1) >> return 1
runInstr (Dec reg) = modifyReg reg (\i -> i - 1) >> return 1

finalA :: Map Char Int -> [Instr] -> Int
finalA regs =
  (M.! 'a') . stRegs . flip execState (SimState 0 regs) . runReaderT run

partA = finalA M.empty

partB = finalA (M.singleton 'c' 1)

main =
  runDay $
  Day
    12
    (many (parseInstr <* newline))
    (return . show . partA)
    (return . show . partB)


<|start_filename|>src/Day6.hs<|end_filename|>
module Main where

import AdventOfCode
import Data.List (sort, group, transpose)
import Control.Arrow ((&&&))

decode :: ([(Int, Char)] -> (Int, Char)) -> [String] -> String
decode chooser = map ((snd . chooser) . column) . transpose
  where
    column = map (length &&& head) . group . sort

decodeMostFrequent :: [String] -> String
decodeMostFrequent = decode maximum

decodeLeastFrequent :: [String] -> String
decodeLeastFrequent = decode minimum

main =
  runDay $
  Day
    6
    (many1 (many1 letter <* newline))
    (return . decodeMostFrequent)
    (return . decodeLeastFrequent)


<|start_filename|>src/Day8.hs<|end_filename|>
module Main where

import AdventOfCode
import Data.Set (Set)
import qualified Data.Set as S

type PixelSet = Set (Int, Int)

data Screen = Screen
  { sMaxX :: Int
  , sMaxY :: Int
  , sPix :: PixelSet
  }

instance Show Screen where
  show s = unlines $ map showRow [0 .. (sMaxY s - 1)]
    where
      showRow :: Int -> String
      showRow y =
        [ if (x, y) `S.member` sPix s
           then '#'
           else '.'
        | x <- [0 .. (sMaxX s - 1)] ]

initialScreen :: Screen
initialScreen = Screen 50 6 S.empty

modScreen :: Screen -> (PixelSet -> PixelSet) -> Screen
modScreen s f =
  s
  { sPix = f (sPix s)
  }

applyInstruction :: Screen -> Instruction -> Screen
applyInstruction s (Rect w h) = modScreen s (S.union newPix)
  where
    newPix =
      S.fromList
        [ (x, y)
        | x <- [0 .. (w - 1)]
        , y <- [0 .. (h - 1)] ]
applyInstruction s (Rotate Col idx off) = modScreen s (S.map rotateCol)
  where
    rotateCol (x, y) =
      if x == idx
        then (x, (y + off) `mod` sMaxY s)
        else (x, y)
applyInstruction s (Rotate Row idx off) = modScreen s (S.map rotateRow)
  where
    rotateRow (x, y) =
      if y == idx
        then ((x + off) `mod` sMaxX s, y)
        else (x, y)

litPixels :: Screen -> Int
litPixels = length . S.toList . sPix

data Axis
  = Col
  | Row

data Instruction
  = Rect { rectW :: Int
         , rectH :: Int}
  | Rotate { rotAxis :: Axis
           , rotIndex :: Int
           , rotOffset :: Int}

parseInstruction :: Parser Instruction
parseInstruction =
  try (Rect <$> (string "rect " *> number) <*> (string "x" *> number)) <|>
  (string "rotate " *>
   ((Rotate Col <$> (string "column x=" *> number) <*> (string " by " *> number)) <|>
    (Rotate Row <$> (string "row y=" *> number) <*> (string " by " *> number))))
  where
    number = read <$> many1 digit

run :: [Instruction] -> Screen
run = foldl applyInstruction initialScreen

main =
  runDay $
  Day
    8
    (many1 (parseInstruction <* newline))
    (return . show . litPixels . run)
    (return . show . run)


<|start_filename|>src/Day23.hs<|end_filename|>
module Main where

import AdventOfCode
import Control.Monad.State
import Data.Maybe (fromMaybe)
import Data.Map (Map)
import Data.Foldable (toList)
import qualified Data.Map as M
import Data.Sequence (Seq)
import qualified Data.Sequence as Sq

newtype Reg =
  Reg Char
  deriving (Eq, Show)

data Value
  = LitVal !Int
  | RegVal !Reg
  deriving (Eq, Show)

data Instr
  = Copy !Value
         !Reg
  | JumpNotZero !Value
                !Value
  | Inc !Reg
  | Dec !Reg
  | Toggle !Value
  | Mult !Value
         !Value
         !Reg
  | NoOp
  deriving (Eq, Show)

parseInstr :: Parser Instr
parseInstr =
  (Dec <$> (string "dec " *> reg)) <|> (Inc <$> (string "inc " *> reg)) <|>
  (JumpNotZero <$> (string "jnz " *> val) <*> (string " " *> val)) <|>
  (Toggle <$> (string "tgl " *> val)) <|>
  (Copy <$> (string "cpy " *> val) <*> (string " " *> reg))
  where
    reg = Reg <$> letter
    val = (RegVal <$> reg) <|> (LitVal <$> num)
    num = do
      sign <- option '+' (char '-')
      digits <- many1 digit
      return $
        (if sign == '-'
           then -1
           else 1) *
        read digits

data SimState = SimState
  { stPos :: Int
  , stRegs :: Map Char Int
  , stInstrs :: Seq Instr
  }

instance Show SimState where
  show (SimState pos regs instrs) =
    unlines (show regs : toList (Sq.mapWithIndex showins instrs))
    where
      showins n i =
        show n ++
        (if n == pos
           then ">> "
           else "  ") ++
        show i

type Sim = (State SimState)

run :: Sim ()
run = do
  ran <- runNext
  when ran run

runNext :: Sim Bool
runNext = do
  pos <- gets stPos
  nextInstrs <- Sq.take 6 . Sq.drop pos <$> gets stInstrs
  if Sq.null nextInstrs
    then return False
    else do
      step <-
        if nextInstrs == multPattern
          then runMult
          else runInstr (nextInstrs `Sq.index` 0)
      modify
        (\st ->
            st
            { stPos = stPos st + step
            })
      return True

modifyReg :: Reg -> (Int -> Int) -> Sim ()
modifyReg r@(Reg n) f = do
  prev <- getReg r
  modify
    (\st ->
        let regs = stRegs st
        in st
           { stRegs = M.insert n (f prev) regs
           })

getReg :: Reg -> Sim Int
getReg (Reg n) = (fromMaybe 0 . M.lookup n) <$> gets stRegs

getVal :: Value -> Sim Int
getVal (LitVal v) = return v
getVal (RegVal r) = getReg r

runMult :: Sim Int
runMult = do
  void $ runInstr (Mult (RegVal (Reg 'b')) (RegVal (Reg 'd')) (Reg 'a'))
  void $ runInstr (Copy (LitVal 0) (Reg 'c'))
  void $ runInstr (Copy (LitVal 0) (Reg 'd'))
  return 6

multPattern :: Seq Instr
multPattern =
  Sq.fromList
    [ Copy (RegVal (Reg 'b')) (Reg 'c')
    , Inc (Reg 'a')
    , Dec (Reg 'c')
    , JumpNotZero (RegVal (Reg 'c')) (LitVal (-2))
    , Dec (Reg 'd')
    , JumpNotZero (RegVal (Reg 'd')) (LitVal (-5))
    ]

runInstr :: Instr -> Sim Int
runInstr (Copy val reg) = (getVal val >>= modifyReg reg . const) >> return 1
runInstr (JumpNotZero val1 val2) = do
  v <- getVal val1
  v2 <- getVal val2
  return $
    if v /= 0
      then v2
      else 1
runInstr (Inc reg) = modifyReg reg (+ 1) >> return 1
runInstr (Dec reg) = modifyReg reg (\i -> i - 1) >> return 1
runInstr (Toggle val) = do
  offset <- getVal val
  pos <- gets stPos
  toggleInstrAt (pos + offset)
  return 1
runInstr NoOp = return 1
runInstr (Mult val1 val2 reg) = do
  v1 <- getVal val1
  v2 <- getVal val2
  modifyReg reg (const (v1 * v2))
  return 1

toggleInstrAt :: Int -> Sim ()
toggleInstrAt pos =
  modify
    (\s ->
        s
        { stInstrs = Sq.adjust toggleInstr pos (stInstrs s)
        })

toggleInstr :: Instr -> Instr
toggleInstr NoOp = error "toggling no-op"
toggleInstr (Copy val reg) = JumpNotZero val (RegVal reg)
toggleInstr (JumpNotZero val1 (RegVal val2)) = Copy val1 val2
toggleInstr (Inc reg) = Dec reg
toggleInstr (Dec reg) = Inc reg
toggleInstr (Toggle (RegVal reg)) = Inc reg
toggleInstr _ = NoOp

finalA :: Map Char Int -> [Instr] -> Int
finalA regs instrs =
  (M.! 'a') $ stRegs $ execState run (SimState 0 regs (Sq.fromList instrs))

partA :: [Instr] -> Int
partA = finalA (M.singleton 'a' 7)

partB :: [Instr] -> Int
partB = finalA (M.singleton 'a' 12)

main :: IO ()
main = runDay day23

day23 :: Day [Instr]
day23 =
  Day
    23
    (many (parseInstr <* newline))
    (return . show . partA)
    (return . show . partB)


<|start_filename|>src/Day15.hs<|end_filename|>
module Main where

import AdventOfCode

data Disc = Disc
  { dSize :: Int
  , dPos :: Int
  }

partA discs =
  take
    1
    [ t
    | t <- [0 ..]
    , all
       (== 0)
       [ pos + (t + t') `mod` size
       | (Disc size pos, t') <- zip discs [1 ..] ] ]

partB = partA . (++ [Disc 11 0])

exampleDiscs = [Disc 5 4, Disc 2 1]

parseDisc :: Parser Disc
parseDisc =
  Disc <$>
  (string "Disc #" >> number >> string " has " *> number <* string " positions") <*>
  (string "; at time=0, it is at position " *> number <* string ".")
  where
    number = read <$> many1 digit

main =
  runDay $
  Day
    15
    (many1 (parseDisc <* newline))
    (return . show . partA)
    (return . show . partB)


<|start_filename|>src/Day16.hs<|end_filename|>
module Main where

import AdventOfCode

expandData :: String -> String
expandData a = a ++ "0" ++ (dNot <$> reverse a)
  where
    dNot '0' = '1'
    dNot '1' = '0'
    dNot _ = error "bad dNot arg"

fill :: Int -> String -> String
fill len input = checksum rawData
  where
    rawData = take len minExpansion
    minExpansion = head $ dropWhile ((<= len) . length) expansions
    expansions = iterate expandData input

checksum :: String -> String
checksum xs = head $ dropWhile (even . length) $ iterate go xs
  where
    go ys@(a:b:_) =
      (if a == b
         then '1'
         else '0') :
      go (drop 2 ys)
    go _ = []

main =
  runDay $
  Day
    16
    (many (oneOf "01") <* newline)
    (return . fill 272)
    (return . fill 35651584)


<|start_filename|>src/Day2.hs<|end_filename|>
module Main where

import AdventOfCode
import qualified Data.Map as M
import Data.Maybe (fromMaybe)

data Direction
  = U
  | D
  | L
  | R

data Button = Button
  { bNum :: String
  , bPos :: (Int, Int)
  } deriving (Show)

type Grid = (Int, Int) -> Maybe String

makeGrid :: [String] -> Grid
makeGrid gridRows = flip M.lookup gridMap
  where
    gridMap =
      M.fromList
        [ ((x, y), [c])
        | (y, l) <- lines
        , (x, c) <- line l
        , c /= ' ' ]
    lines = zip [0 ..] gridRows
    line = zip [0 ..]

squareGrid = makeGrid ["123", "456", "798"]

diamondGrid = makeGrid ["  1  ", " 234 ", "56789", " ABC ", "  D  "]

maybeButton :: Grid -> (Int, Int) -> Maybe Button
maybeButton grid pos = flip Button pos <$> grid pos

neighbour :: Grid -> Button -> Direction -> Maybe Button
neighbour grid (Button _ (x, y)) U = maybeButton grid (x, y - 1)
neighbour grid (Button _ (x, y)) D = maybeButton grid (x, y + 1)
neighbour grid (Button _ (x, y)) L = maybeButton grid (x - 1, y)
neighbour grid (Button _ (x, y)) R = maybeButton grid (x + 1, y)

move :: Grid -> Button -> Direction -> Button
move grid b d = fromMaybe b $ neighbour grid b d

code :: Grid -> Button -> [[Direction]] -> String
code grid init lines = concatMap bNum $ tail (scanl followLine init lines)
  where
    followLine = foldl (move grid)

parseDirection :: Parser Direction
parseDirection =
  string "U" *> return U <|> string "D" *> return D <|> string "L" *> return L <|>
  string "R" *> return R

main =
  runDay $
  Day
    2
    (many1 (many1 parseDirection <* newline))
    (return . code squareGrid (Button "5" (1, 1)))
    (return . code diamondGrid (Button "5" (0, 2)))


<|start_filename|>src/Day18.hs<|end_filename|>
module Main where

import AdventOfCode
import Data.List (tails)

data Tile
  = Safe
  | Trap
  deriving (Eq)

next :: [Tile] -> [Tile]
next tiles =
  fmap tripleToNext .
  take (length tiles) . fmap (take 3) . tails . cycle . (Safe :) $
  tiles
  where
    tripleToNext :: [Tile] -> Tile
    tripleToNext [Trap, Trap, Safe] = Trap
    tripleToNext [Safe, Trap, Trap] = Trap
    tripleToNext [Trap, Safe, Safe] = Trap
    tripleToNext [Safe, Safe, Trap] = Trap
    tripleToNext _ = Safe

safeInRows n = length . filter (== Safe) . concat . take n . iterate next

partA = safeInRows 40

partB = safeInRows 400000

parseTile = (char '.' *> return Safe) <|> (char '^' *> return Trap)

main =
  runDay $
  Day
    18
    (many1 parseTile <* newline)
    (return . show . partA)
    (return . show . partB)


<|start_filename|>src/Day9.hs<|end_filename|>
module Main where

import AdventOfCode

data Block
  = Repeat Int
           String
           [Block]
  | Plain String
  deriving (Show)

blockLenA :: Block -> Int
blockLenA (Repeat n s _) = n * length s
blockLenA (Plain s) = length s

blockLenB :: Block -> Int
blockLenB (Repeat n _ bs) = n * sum (blockLenB <$> bs)
blockLenB (Plain s) = length s

parseBlock :: Parser Block
parseBlock = try parseRepeat <|> (Plain <$> many1 letter)
  where
    parseRepeat = do
      len <- char '(' *> number <* char 'x'
      mult <- number <* char ')'
      rest <- count len anyChar
      case runP (many parseBlock <* eof) () "block" rest of
        Right subBlocks -> pure $ Repeat mult rest subBlocks
        Left err -> fail (show err)
    number = read <$> many1 digit

main =
  runDay $
  Day
    9
    (many1 parseBlock <* newline)
    (return . show . sum . fmap blockLenA)
    (return . show . sum . fmap blockLenB)


<|start_filename|>src/Day22.hs<|end_filename|>
module Main where

import AdventOfCode
import Data.List (delete)
import Data.Maybe (mapMaybe, fromJust, listToMaybe)
import Data.Map (Map)
import qualified Data.Map as M
import Control.Arrow ((&&&))
import Data.Function (on)

data Pos = Pos
  { px :: !Int
  , py :: !Int
  } deriving (Eq, Show)

instance Ord Pos where
  compare = compare `on` (py &&& px)

data Node = Node
  { nPos :: !Pos
  , nSize :: !Int
  , nUsed :: !Int
  } deriving (Eq, Ord, Show)

parseNode :: Parser Node
parseNode =
  Node <$>
  (Pos <$> (string "/dev/grid/node-x" *> number) <*> (string "-y" *> number)) <*>
  amountCol <*>
  (amountCol <* manyTill anyChar newline)
  where
    number = read <$> many1 digit
    amountCol = many1 space *> number <* char 'T'

viablePairs :: [Node] -> [(Node, Node)]
viablePairs nodes =
  [ (n1, n2)
  | n1 <- nodes
  , n2 <- delete n1 nodes
  , viable n1 n2 ]

viable :: Node -> Node -> Bool
viable n1 n2 = n1 /= n2 && nUsed n1 > 0 && nUsed n1 <= (nSize n2 - nUsed n2)

data Grid = Grid
  { gridNodes :: !(Map Pos Node)
  , gridBottomRight :: !Pos
  , gridGoalData :: !Pos
  } deriving (Eq, Ord)

makeGrid :: [Node] -> Grid
makeGrid nodes = Grid (M.fromList ((nPos &&& id) <$> nodes)) bottomRight topRight
  where
    bottomRight = maximum (nPos <$> nodes)
    topRight = Pos (px bottomRight) 0

findNode :: Grid -> Pos -> Maybe Node
findNode g p = p `M.lookup` gridNodes g

neighbours :: Grid -> Node -> [Node]
neighbours g (Node (Pos x y) _ _) =
  mapMaybe
    (findNode g . uncurry Pos)
    [(x + 1, y), (x - 1, y), (x, y - 1), (x, y + 1)]

origin :: Pos
origin = Pos 0 0

manhattanDistance :: Pos -> Pos -> Int
manhattanDistance (Pos x1 y1) (Pos x2 y2) = abs (x2 - x1) + abs (y2 - y1)

partA :: [Node] -> Int
partA = length . viablePairs

partB :: [Node] -> (State, Int)
partB nodes = head $ filter (reachedOrigin . fst) $ astar (nexts grid) initialState
  where
    reachedOrigin = (origin ==) . sGoalData
    initialState = State (fromJust (findEmpty grid)) (gridGoalData grid)
    grid = makeGrid nodes

findEmpty :: Grid -> Maybe Pos
findEmpty = listToMaybe . fmap nPos . filter ((== 0) . nUsed) . M.elems . gridNodes

data State = State
  { sEmpty :: !Pos
  , sGoalData :: !Pos
  } deriving (Eq, Ord, Show)

nexts :: Grid -> State -> [(State, Int, Int)]
nexts g (State emptypos goalpos) =
  let empty = fromJust (findNode g emptypos)
  in do neighbour <-
          [ n
          | n <- neighbours g empty
          , nUsed n <= nSize empty ]
        let goalpos' =
              if goalpos == nPos neighbour
                then emptypos
                else goalpos
            empty' = nPos neighbour
        return
          ( State empty' goalpos'
          , 1
          , manhattanDistance goalpos' origin + manhattanDistance empty' goalpos' -
            1)

main :: IO ()
main = runDay day22

day22 :: Day [Node]
day22 =
  Day
    22
    (count 2 (manyTill anyChar newline) *> many1 parseNode)
    (return . show . partA)
    (return . show . partB)


<|start_filename|>src/Day21.hs<|end_filename|>
module Main where

import AdventOfCode
import Data.Foldable (toList)
import Data.Monoid ((<>))
import Data.Maybe (fromMaybe)
import Data.Sequence (Seq)
import qualified Data.Sequence as S

data Direction
  = DirLeft
  | DirRight

data Instr
  = SwapPos Int
            Int
  | SwapLetters Char
                Char
  | Rotate Direction
           Int
  | RotatePosition Char
  | Reverse Int
            Int
  | Move Int
         Int

type Password = Seq Char

apply :: Password -> Instr -> Password
apply s (SwapPos x y) =
  S.update x (s `S.index` y) (S.update y (s `S.index` x) s)
apply s (SwapLetters a b) = replacement <$> s
  where
    replacement c
      | c == a = b
      | c == b = a
      | otherwise = c
apply s (Rotate DirLeft n) =
  uncurry (flip (<>)) (S.splitAt (n `mod` S.length s) s)
apply s (Rotate DirRight n) = apply s (Rotate DirLeft (S.length s - n))
apply s (RotatePosition c) = apply s (Rotate DirRight off)
  where
    off =
      1 + nc +
      (if nc >= 4
         then 1
         else 0)
    nc = fromMaybe (error "no such char") $ c `S.elemIndexL` s
apply s (Reverse x y)
  | y >= x =
    let (pre, rest) = S.splitAt x s
        (middle, end) = S.splitAt (y - x + 1) rest
    in pre <> S.reverse middle <> end
apply s (Move x y) = beforeY <> S.take 1 fromX <> fromY
  where
    (beforeX, fromX) = S.splitAt x s
    (beforeY, fromY) = S.splitAt y (beforeX <> S.drop 1 fromX)

unapply :: Password -> Instr -> Password
unapply s (Rotate DirRight n) = apply s $ Rotate DirLeft n
unapply s (Rotate DirLeft n) = apply s $ Rotate DirRight n
unapply s (SwapPos a b) = apply s $ SwapPos b a
unapply s (SwapLetters a b) = apply s $ SwapLetters b a
unapply s r@(RotatePosition _) =
  head
    [ s'
    | n <- [0 .. (length s)]
    , let s' = apply s (Rotate DirLeft n)
    , apply s' r == s ]
unapply s r@(Reverse _ _) = apply s r
unapply s (Move a b) = apply s $ Move b a

partA :: [Instr] -> String
partA = toList . foldl apply (S.fromList "abcdefgh")

partB :: [Instr] -> String
partB = toList . foldl unapply (S.fromList "fbgdceah") . reverse

parseInstr :: Parser Instr
parseInstr =
  try
    (SwapPos <$> (string "swap position " *> num) <*>
     (string " with position " *> num)) <|>
  try
    (SwapLetters <$> (string "swap letter " *> anyChar) <*>
     (string " with letter " *> anyChar)) <|>
  try
    (Rotate <$> (string "rotate " *> direction) <*>
     (string " " *> num <* string " step" <* optional (char 's'))) <|>
  try
    (RotatePosition <$>
     (string "rotate based on position of letter " *> anyChar)) <|>
  try
    (Reverse <$> (string "reverse positions " *> num) <*>
     (string " through " *> num)) <|>
  try
    (Move <$> (string "move position " *> num) <*>
     (string " to position " *> num))
  where
    num = read <$> many1 digit
    direction =
      (string "left" *> pure DirLeft) <|> (string "right" *> pure DirRight)

main =
  runDay $
  Day 21 (many1 (parseInstr <* newline)) (return . partA) (return . partB)


<|start_filename|>src/Day19.hs<|end_filename|>
module Main where

import AdventOfCode
import Data.Sequence (Seq)
import qualified Data.Sequence as S

elves :: (Seq Elf -> Seq Elf) -> Int -> Elf
elves f n = (`S.index` 0) . f $ makeElves n

runElvesA es
  | S.length es >= 2 = runElvesA (S.drop 2 es S.>< S.take 1 es)
runElvesA es = es

runElvesB es
  | S.length es >= 2 =
    runElvesB (beforeSteal S.>< S.drop 1 fromSteal S.>< first)
  where
    (first, rest) = S.splitAt 1 es
    (beforeSteal, fromSteal) = S.splitAt (nSteal - 1) rest
    nSteal = S.length es `div` 2
runElvesB es = es

data Elf = Elf
  { eNum :: !Int
  } deriving (Show)

makeElves n = Elf <$> S.iterateN n (+ 1) 1

main =
  runDay $
  Day
    19
    ((read <$> many1 digit) <* newline)
    (return . show . elves runElvesA)
    (return . show . elves runElvesB)


<|start_filename|>src/Day3.hs<|end_filename|>
module Main where

import AdventOfCode
import Data.List (transpose, splitAt)

data Triangle =
  Triangle Int
           Int
           Int

possible :: Triangle -> Bool
possible (Triangle a b c) =
  all valid $ zip3 sides (drop 1 $ cycle sides) (drop 2 $ cycle sides)
  where
    sides = [a, b, c]
    valid (s1, s2, s3) = s1 + s2 > s3

spaceNumber :: Parser Int
spaceNumber = spaces *> parseInt
  where
    parseInt = read <$> many1 digit

groupsOf :: Int -> [a] -> [[a]]
groupsOf = go []
  where
    go acc _ [] = acc
    go acc n xs = go (before : acc) n after
      where
        (before, after) = splitAt n xs

toTriangle [a, b, c] = Triangle a b c

main =
  runDay $
  Day
    3
    (many1 (count 3 spaceNumber <* newline))
    (return . show . length . filter possible . fmap toTriangle)
    (return .
     show . length . filter possible . fmap toTriangle . groupsOf 3 . concat . transpose)


<|start_filename|>src/Day17.hs<|end_filename|>
module Main where

import AdventOfCode
import qualified Crypto.Hash as H
import Data.ByteString (ByteString)
import Data.String (fromString)

hexMD5 :: String -> String
hexMD5 = show . md5 . fromString
  where
    md5 :: ByteString -> H.Digest H.MD5
    md5 = H.hash

type Pos = (Int, Int)

paths :: String -> (String, Pos) -> [(String, Pos)]
paths seed start = go [start]
  where
    go [] = []
    go (x@(path, pos):xs) = x : go (xs ++ nexts)
      where
        hash = hexMD5 (seed ++ path)
        nexts =
          [ (path ++ [dir], pos')
          | (dir, c) <- zip "UDLR" hash
          , c `elem` "bcdef"
          , pos /= (3, 3)
          , let pos'@(x', y') = move pos dir
          , x' >= 0
          , x' <= 3
          , y' >= 0
          , y' <= 3 ]

move (x, y) 'U' = (x, y - 1)
move (x, y) 'D' = (x, y + 1)
move (x, y) 'L' = (x - 1, y)
move (x, y) 'R' = (x + 1, y)
move _ _ = error "bad move"

solutions = fmap fst . filter (((3, 3) ==) . snd) . flip paths ("", (0, 0))

partA :: String -> String
partA = head . solutions

partB :: String -> Int
partB = length . last . solutions

main =
  runDay $
  Day 17 (many letter <* newline) (return . partA) (return . show . partB)


<|start_filename|>src/Day1.hs<|end_filename|>
{-# LANGUAGE TupleSections #-}

module Main where

import AdventOfCode
import qualified Data.Set as S

data TurnDirection
  = L
  | R

data Instruction = Instruction
  { iDir :: TurnDirection
  , iBlocks :: Blocks
  }

data Direction
  = N
  | E
  | S
  | W
  deriving (Show)

type Blocks = Int

data Position = Position
  { pNetN :: Blocks
  , pNetE :: Blocks
  } deriving (Eq, Ord, Show)

shortestDistance :: Position -> Blocks
shortestDistance (Position n e) = abs n + abs e

move :: Position -> Direction -> Position
move p@(Position n e) N =
  p
  { pNetN = n + 1
  }
move p@(Position n e) S =
  p
  { pNetN = n - 1
  }
move p@(Position n e) E =
  p
  { pNetE = e + 1
  }
move p@(Position n e) W =
  p
  { pNetE = e - 1
  }

rotate :: Direction -> TurnDirection -> Direction
rotate N L = W
rotate E L = N
rotate S L = E
rotate W L = S
rotate d R = rotate (rotate (rotate d L) L) L

parseInstruction :: Parser Instruction
parseInstruction = Instruction <$> parseDirection <*> parseNumber
  where
    parseDirection = try (string "R" *> return R) <|> (string "L" *> return L)
    parseNumber = read <$> many1 digit

parseFile :: String -> IO (Either ParseError [Instruction])
parseFile =
  parseFromFile (sepBy parseInstruction (string ", ") <* newline <* eof)

runInstructions :: [Instruction] -> [Position]
runInstructions instrs = scanl move (Position 0 0) moves
  where
    moves = concatMap expand (zip directions distances)
    expand (dir, dist) = replicate dist dir
    directions = tail $ scanl rotate N (iDir <$> instrs)
    distances = iBlocks <$> instrs

firstDuplicate
  :: Ord a
  => [a] -> Maybe a
firstDuplicate = go S.empty
  where
    go _ [] = Nothing
    go seen (x:xs) =
      if x `S.member` seen
        then Just x
        else go (S.insert x seen) xs

main :: IO ()
main =
  runDay $
  Day
    1
    (sepBy parseInstruction (string ", ") <* newline)
    (return . show . shortestDistance . last . runInstructions)
    (return . show . fmap shortestDistance . firstDuplicate . runInstructions)


<|start_filename|>src/Day24.hs<|end_filename|>
module Main where

import AdventOfCode
import Data.Monoid ((<>))
import Control.Monad (guard)
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe (fromJust)
import Data.Function (on)
import Data.List (find, sort, permutations, minimumBy)
import Control.Arrow ((&&&))

data Pos = Pos
  { px :: Int
  , py :: Int
  } deriving (Eq, Ord, Show)

data Grid = Grid
  { gSquares :: Map Pos Square
  , gGoals :: [(Int, Pos)]
  }

data Square
  = Wall
  | Open
  | Goal Int
  deriving (Eq)

goalPos :: Grid -> Int -> Maybe Pos
goalPos g n = lookup n (gGoals g)

goalPositions :: Grid -> [Pos]
goalPositions = map snd . gGoals

type Path = [Pos]

squareAt :: Grid -> Pos -> Maybe Square
squareAt g p = p `M.lookup` gSquares g

manhattanDist :: Pos -> Pos -> Int
manhattanDist p1 p2 = abs (px p2 - px p1) + abs (py p2 - py p1)

shortestPathFrom :: Grid -> Pos -> Pos -> Maybe Path
shortestPathFrom g start dest =
  fst <$> find ((dest ==) . head . fst) (astarOn head nexts [start])
  where
    nexts path@(x:_) =
      [ (n : path, 1, manhattanDist n dest)
      | n <- openNeighbours g x ]
    nexts _ = error "empty path"

openNeighbours :: Grid -> Pos -> [Pos]
openNeighbours g (Pos x y) = do
  p' <- [Pos (x - 1) y, Pos (x + 1) y, Pos x (y - 1), Pos x (y + 1)]
  let Just s = squareAt g p'
  guard (s /= Wall)
  return p'

makeGrid :: [[Square]] -> Grid
makeGrid sqs = Grid squareMap goals
  where
    goals =
      sort
        [ (n, p)
        | (p, Goal n) <- M.toList squareMap ]
    squareMap =
      M.fromList
        [ (Pos x y, sq)
        | (y, row) <- zip [0 ..] sqs
        , (x, sq) <- zip [0 ..] row ]

parseGrid :: Parser Grid
parseGrid = makeGrid <$> many1 (many1 square <* newline)
  where
    square =
      (char '#' *> pure Wall) <|> (char '.' *> pure Open) <|>
      (Goal . read <$> count 1 digit)

main :: IO ()
main = runDay day24

shortestVariation :: Grid
                  -> ([(Int, Pos)] -> [[(Int, Pos)]])
                  -> ([(Int, Pos)], Int)
shortestVariation g goalVariations =
  minimumBy (compare `on` snd) ((id &&& distance) <$> goalVariations goals)
  where
    distance gs = sum ((fromJust . (`lookup` distances)) <$> zip gs (drop 1 gs))
    goals = gGoals g
    distances =
      [ ((start, dest), length path - 1)
      | start <- goals
      , dest <- goals
      , start /= dest
      , let Just path = shortestPathFrom g (snd start) (snd dest) ]

partA :: Grid -> ([(Int, Pos)], Int)
partA g = shortestVariation g makePaths
  where
    makePaths goals = (take 1 goals ++) <$> permutations (drop 1 goals)

partB :: Grid -> ([(Int, Pos)], Int)
partB g = shortestVariation g makePaths
  where
    makePaths goals =
      (\middle -> first <> middle <> first) <$> permutations (drop 1 goals)
      where
        first = take 1 goals

day24 :: Day Grid
day24 = Day 24 parseGrid (return . show . partA) (return . show . partB)


<|start_filename|>src/Day7.hs<|end_filename|>
{-# LANGUAGE TupleSections #-}

module Main where

import AdventOfCode
import Data.List (partition, isInfixOf)

data Net
  = Super
  | Hyper

newtype IPAddress =
  IPAddress [(Net, String)]

abba :: String -> Bool
abba (a:b:c:d:_)
  | a /= b && a == d && b == c = True
abba (_:xs) = abba xs
abba _ = False

canTLS :: IPAddress -> Bool
canTLS (IPAddress parts) = abbas super && not (abbas hyper)
  where
    abbas = any abba . fmap snd
    (super, hyper) = partition supernet parts
    supernet (Super, _) = True
    supernet _ = False

canSSL :: IPAddress -> Bool
canSSL (IPAddress parts) =
  or
    [ [b, a, b] `isInfixOf` hyper
    | (Super, super) <- parts
    , [a, b, _] <- abas super
    , (Hyper, hyper) <- parts ]

abas :: String -> [String]
abas = go []
  where
    go acc s@(a:b:c:_)
      | a /= b && a == c = go ([a, b, c] : acc) (drop 1 s)
    go acc (_:xs) = go acc xs
    go acc _ = acc

parseIPAddress :: Parser IPAddress
parseIPAddress =
  IPAddress <$>
  many1
    (((Super, ) <$> many1 letter) <|>
     ((Hyper, ) <$> (string "[" *> many1 letter <* string "]")))

main =
  runDay $
  Day
    7
    (many1 (parseIPAddress <* newline))
    (return . show . length . filter canTLS)
    (return . show . length . filter canSSL)
