From 15e9b61fe7cb57ac62f8afa82f802f3e911de3cf Mon Sep 17 00:00:00 2001 From: justin Date: Sat, 16 Nov 2024 22:20:28 -0800 Subject: [PATCH] 2018 --- 2018/AOC2018.hs | 50 +++++++ 2018/AOC2018/Common/Elfcode.hs | 264 +++++++++++++++++++++++++++++++++ 2018/AOC2018/Day01.hs | 43 ++++++ 2018/AOC2018/Day02.hs | 78 ++++++++++ 2018/AOC2018/Day03.hs | 103 +++++++++++++ 2018/AOC2018/Day04.hs | 121 +++++++++++++++ 2018/AOC2018/Day05.hs | 104 +++++++++++++ 2018/AOC2018/Day06.hs | 105 +++++++++++++ 2018/AOC2018/Day07.hs | 166 +++++++++++++++++++++ 2018/AOC2018/Day08.hs | 60 ++++++++ 2018/AOC2018/Day09.hs | 78 ++++++++++ 2018/AOC2018/Day10.hs | 79 ++++++++++ 2018/AOC2018/Day11.hs | 143 ++++++++++++++++++ 2018/AOC2018/Day12.hs | 109 ++++++++++++++ 2018/AOC2018/Day13.hs | 142 ++++++++++++++++++ 2018/AOC2018/Day14.hs | 56 +++++++ 2018/AOC2018/Day15.hs | 255 +++++++++++++++++++++++++++++++ 2018/AOC2018/Day16.hs | 178 ++++++++++++++++++++++ 2018/AOC2018/Day17.hs | 133 +++++++++++++++++ 2018/AOC2018/Day18.hs | 107 +++++++++++++ 2018/AOC2018/Day19.hs | 81 ++++++++++ 2018/AOC2018/Day20.hs | 137 +++++++++++++++++ 2018/AOC2018/Day21.hs | 118 +++++++++++++++ 2018/AOC2018/Day22.hs | 126 ++++++++++++++++ 2018/AOC2018/Day23.hs | 144 ++++++++++++++++++ 2018/AOC2018/Day24.hs | 213 ++++++++++++++++++++++++++ 2018/AOC2018/Day25.hs | 44 ++++++ advent-of-code.cabal | 73 +++++++++ app/aoc2018.hs | 5 + bench/aoc2018-bench.hs | 5 + test/aoc2018-test.hs | 5 + 31 files changed, 3325 insertions(+) create mode 100644 2018/AOC2018.hs create mode 100644 2018/AOC2018/Common/Elfcode.hs create mode 100644 2018/AOC2018/Day01.hs create mode 100644 2018/AOC2018/Day02.hs create mode 100644 2018/AOC2018/Day03.hs create mode 100644 2018/AOC2018/Day04.hs create mode 100644 2018/AOC2018/Day05.hs create mode 100644 2018/AOC2018/Day06.hs create mode 100644 2018/AOC2018/Day07.hs create mode 100644 2018/AOC2018/Day08.hs create mode 100644 2018/AOC2018/Day09.hs create mode 100644 2018/AOC2018/Day10.hs create mode 100644 2018/AOC2018/Day11.hs create mode 100644 2018/AOC2018/Day12.hs create mode 100644 2018/AOC2018/Day13.hs create mode 100644 2018/AOC2018/Day14.hs create mode 100644 2018/AOC2018/Day15.hs create mode 100644 2018/AOC2018/Day16.hs create mode 100644 2018/AOC2018/Day17.hs create mode 100644 2018/AOC2018/Day18.hs create mode 100644 2018/AOC2018/Day19.hs create mode 100644 2018/AOC2018/Day20.hs create mode 100644 2018/AOC2018/Day21.hs create mode 100644 2018/AOC2018/Day22.hs create mode 100644 2018/AOC2018/Day23.hs create mode 100644 2018/AOC2018/Day24.hs create mode 100644 2018/AOC2018/Day25.hs create mode 100644 app/aoc2018.hs create mode 100644 bench/aoc2018-bench.hs create mode 100644 test/aoc2018-test.hs diff --git a/2018/AOC2018.hs b/2018/AOC2018.hs new file mode 100644 index 0000000..996b0da --- /dev/null +++ b/2018/AOC2018.hs @@ -0,0 +1,50 @@ +{-# OPTIONS_GHC -Wno-dodgy-exports #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} + +-- | +-- Module : AOC2018 +-- Copyright : (c) Justin Le 2021 +-- License : BSD3 +-- +-- Maintainer : justin@jle.im +-- Stability : experimental +-- Portability : non-portable +-- +-- Gather together all challenges and collect them into a single map. +module AOC2018 ( + module AOC, + challengeBundle2018, +) +where + +import AOC.Discover +import AOC.Run +import AOC.Run.Interactive +import AOC2018.Day01 as AOC +import AOC2018.Day02 as AOC +import AOC2018.Day03 as AOC +import AOC2018.Day04 as AOC +import AOC2018.Day05 as AOC +import AOC2018.Day06 as AOC +import AOC2018.Day07 as AOC +import AOC2018.Day08 as AOC +import AOC2018.Day09 as AOC +import AOC2018.Day10 as AOC +import AOC2018.Day11 as AOC +import AOC2018.Day12 as AOC +import AOC2018.Day13 as AOC +import AOC2018.Day14 as AOC +import AOC2018.Day15 as AOC +import AOC2018.Day16 as AOC +import AOC2018.Day17 as AOC +import AOC2018.Day18 as AOC +import AOC2018.Day19 as AOC +import AOC2018.Day20 as AOC +import AOC2018.Day21 as AOC +import AOC2018.Day22 as AOC +import AOC2018.Day23 as AOC +import AOC2018.Day24 as AOC +import AOC2018.Day25 as AOC + +challengeBundle2018 :: ChallengeBundle +challengeBundle2018 = CB 2018 $ mkChallengeMap $$(solutionList) diff --git a/2018/AOC2018/Common/Elfcode.hs b/2018/AOC2018/Common/Elfcode.hs new file mode 100644 index 0000000..7d521bf --- /dev/null +++ b/2018/AOC2018/Common/Elfcode.hs @@ -0,0 +1,264 @@ +module AOC2018.Common.Elfcode ( + Mem, + IMem, + ECProg, + Instr (..), + OpCode (..), + runOp, + execOp, + runECProg, + evalECProg, + execECProg, + traceECProg, + traceECProg_, + + -- * Optimizers + optimizeEC, + Peephole, + peep, + currPeepPos, + + -- * Parsing + parseElfcode, + elfcodeParser, +) where + +import Control.Applicative +import Control.Monad +import Control.Monad.Primitive +import qualified Control.Monad.ST as STS +import qualified Control.Monad.ST.Lazy as STL +import Control.Monad.Writer +import Data.Bits +import Data.Char +import Data.Finite +import Data.Foldable +import Data.Maybe +import qualified Data.Vector as UV +import qualified Data.Vector.Unboxed.Mutable.Sized as MV +import qualified Data.Vector.Unboxed.Sized as V +import Data.Void +import qualified Text.Megaparsec as P +import qualified Text.Megaparsec.Char as P +import Text.Megaparsec.Char.Lexer (decimal) +import qualified Text.Parsec as Pa + +type Mem s = MV.MVector 6 s Int +type IMem = V.Vector 6 Int + +type ECProg = UV.Vector Instr + +data Instr = I + { _iOp :: OpCode + , _iInA :: Int + , _iInB :: Int + , _iOut :: Finite 6 + } + deriving (Show, Eq, Ord) + +data OpCode + = OAddR + | OAddI + | OMulR + | OMulI + | OBanR + | OBanI + | OBorR + | OBorI + | OSetR + | OSetI + | OGtIR + | OGtRI + | OGtRR + | OEqIR + | OEqRI + | OEqRR + | ODivR + | ODivI + | OModR + | ONoOp + | OOutR + | OOutI + deriving (Show, Eq, Ord, Enum, Bounded) + +execOp :: (PrimMonad m, PrimState m ~ s) => Instr -> Mem s -> m (Maybe Int) +execOp I{..} = case _iOp of + OAddR -> rrOp (+) + OAddI -> riOp (+) + OMulR -> rrOp (*) + OMulI -> riOp (*) + OBanR -> rrOp (.&.) + OBanI -> riOp (.&.) + OBorR -> rrOp (.|.) + OBorI -> riOp (.|.) + OSetR -> riOp const + OSetI -> \m -> Nothing <$ MV.write m _iOut _iInA + OGtIR -> irOp $ \x y -> if x > y then 1 else 0 + OGtRI -> riOp $ \x y -> if x > y then 1 else 0 + OGtRR -> rrOp $ \x y -> if x > y then 1 else 0 + OEqIR -> irOp $ \x y -> if x == y then 1 else 0 + OEqRI -> riOp $ \x y -> if x == y then 1 else 0 + OEqRR -> rrOp $ \x y -> if x == y then 1 else 0 + ODivR -> rrOp div + ODivI -> riOp div + OModR -> rrOp mod + ONoOp -> \_ -> pure Nothing + OOutR -> \m -> Just <$> MV.read m _iOut + OOutI -> \_ -> pure $ Just (fromIntegral _iOut) + where + rrOp f m = do + x <- MV.read m (fromIntegral _iInA) + y <- MV.read m (fromIntegral _iInB) + Nothing <$ MV.write m _iOut (f x y) + riOp f m = (Nothing <$) . MV.write m _iOut . (`f` _iInB) =<< MV.read m (fromIntegral _iInA) + irOp f m = (Nothing <$) . MV.write m _iOut . f _iInA =<< MV.read m (fromIntegral _iInB) + +runOp :: Instr -> IMem -> (Maybe Int, IMem) +runOp i v = STS.runST $ do + mv <- V.thaw v + res <- execOp i mv + (res,) <$> V.freeze mv + +runECProg :: + Finite 6 -> + ECProg -> + IMem -> + ([Int], IMem) +runECProg iPtr p v = STL.runST $ do + mv <- STL.strictToLazyST $ V.thaw v + let go = do + i <- STL.strictToLazyST $ MV.read mv iPtr + case p UV.!? i of + Nothing -> pure [] + Just instr -> do + out <- + STL.strictToLazyST $ + execOp instr mv <* MV.modify mv (+ 1) iPtr + (maybeToList out ++) <$> go + res <- go + (res,) <$> STL.strictToLazyST (V.freeze mv) + +execECProg :: + Finite 6 -> + ECProg -> + IMem -> + IMem +execECProg iPtr p v = STS.runST $ do + mv <- V.thaw v + let go = do + i <- MV.read mv iPtr + forM_ (p UV.!? i) $ \instr -> do + _ <- execOp instr mv + MV.modify mv (+ 1) iPtr + go + go + V.freeze mv + +evalECProg :: + Finite 6 -> + ECProg -> + IMem -> + [Int] +evalECProg iPtr p = fst . runECProg iPtr p + +traceECProg :: + Finite 6 -> + ECProg -> + IMem -> + [(Maybe Int, IMem)] +traceECProg iPtr p v = STL.runST $ do + mv <- STL.strictToLazyST $ V.thaw v + let go = do + i <- STL.strictToLazyST $ MV.read mv iPtr + case p UV.!? i of + Nothing -> pure [] + Just instr -> do + res <- + STL.strictToLazyST $ + (,) + <$> execOp instr mv + <*> V.freeze mv + <* MV.modify mv (+ 1) iPtr + (res :) <$> go + go + +traceECProg_ :: + Finite 6 -> + ECProg -> + IMem -> + [IMem] +traceECProg_ iPtr p = map snd . traceECProg iPtr p + +type Peephole = Pa.Parsec [Instr] () + +optimizeEC :: + [Peephole [Instr]] -> + ECProg -> + ECProg +optimizeEC os = UV.fromList . go . toList + where + go m0 = case Pa.parse (optimizers os) "" m0 of + Left _ -> m0 + Right m1 + | m0 == m1 -> m0 + | otherwise -> go m1 + +currPeepPos :: Peephole Int +currPeepPos = subtract 1 . Pa.sourceLine <$> Pa.getPosition + +peep :: + -- | expected A + Maybe Int -> + -- | expected B + Maybe Int -> + -- | expected C + Maybe (Finite 6) -> + Peephole Instr +peep eA eB eC = Pa.tokenPrim show (\p _ _ -> Pa.incSourceLine p 1) $ \i@I{..} -> do + forM_ eA $ guard . (== _iInA) + forM_ eB $ guard . (== _iInB) + forM_ eC $ guard . (== _iOut) + pure i + +optimizers :: + [Peephole [Instr]] -> + Peephole [Instr] +optimizers os = + concat + <$> P.many + ( Pa.choice (Pa.try <$> os) + <|> ((: []) <$> peep Nothing Nothing Nothing) + ) + +parseElfcode :: String -> Maybe (Finite 6, ECProg) +parseElfcode = P.parseMaybe elfcodeParser + +type Parser = P.Parsec Void String + +elfcodeParser :: Parser (Finite 6, ECProg) +elfcodeParser = + (,) + <$> (P.string "#ip " `P.between` P.newline) parseFinite + <*> (UV.fromList . catMaybes <$> (lineParser `P.sepEndBy1` P.space)) + where + lineParser = + P.try (Just <$> instrParser) + <|> Nothing <$ (P.char '#' *> P.many (P.noneOf "\n")) + +instrParser :: Parser Instr +instrParser = + I + <$> parseOpCode + <* P.space1 + <*> decimal + <* P.space1 + <*> decimal + <* P.space1 + <*> parseFinite + <* P.skipMany (P.satisfy (/= '\n')) + where + parseOpCode = P.choice . flip map [OAddR ..] $ \o -> + o <$ P.try (P.string (map toLower . drop 1 . show $ o)) + +parseFinite :: Parser (Finite 6) +parseFinite = maybe (fail "number out of range") pure . packFinite =<< decimal diff --git a/2018/AOC2018/Day01.hs b/2018/AOC2018/Day01.hs new file mode 100644 index 0000000..e2f2298 --- /dev/null +++ b/2018/AOC2018/Day01.hs @@ -0,0 +1,43 @@ +-- | +-- Module : AOC2018.Day01 +-- Copyright : (c) Justin Le 2018 +-- License : BSD3 +-- +-- Maintainer : justin@jle.im +-- Stability : experimental +-- Portability : non-portable +-- +-- Day 1! See "AOC.Solver" for the types used in this module! +module AOC2018.Day01 (day01a, day01b) where + +import AOC.Common (firstRepeated) +import AOC.Solver ((:~>) (..)) +import Text.Read (readMaybe) + +-- | We need this because 'read' can't handle positive signs in front of +-- numbers. +parseItem :: String -> Maybe Int +parseItem = readMaybe . filter (/= '+') + +-- | Here we have a basic sum of numbers. +day01a :: [Int] :~> Int +day01a = + MkSol + { sParse = traverse parseItem . lines + , sShow = show + , sSolve = Just . sum + } + +-- | Here we compute a running sum on an infinitely repeated list of +-- inputs, and then use 'firstRepeated' to get the first repeated item in +-- the list of running sums. +day01b :: [Int] :~> Int +day01b = + MkSol + { sParse = traverse parseItem . lines + , sShow = show + , sSolve = + firstRepeated -- > get first repeated sum + . scanl (+) 0 -- > compute running sum + . cycle -- > infinitely cycle input + } diff --git a/2018/AOC2018/Day02.hs b/2018/AOC2018/Day02.hs new file mode 100644 index 0000000..8be4191 --- /dev/null +++ b/2018/AOC2018/Day02.hs @@ -0,0 +1,78 @@ +-- | +-- Module : AOC2018.Day02 +-- Copyright : (c) Justin Le 2018 +-- License : BSD3 +-- +-- Maintainer : justin@jle.im +-- Stability : experimental +-- Portability : non-portable +-- +-- Day 2. See "AOC.Solver" for the types used in this module! +module AOC2018.Day02 ( + day02a, + day02b, +) where + +import AOC.Common (freqs, perturbations) +import AOC.Solver ((:~>) (..)) +import Control.Monad (guard) +import Data.Containers.ListUtils (nubOrd) +import Data.List (find) +import qualified Data.Map as M +import qualified Data.Set as S +import Witherable (catMaybes) + +-- | We compute a frequency map of all of the characters in a string, and +-- then get all of the frequencies that happened for each line. +-- +-- Then we build a frequency map of the frequencies! +day02a :: [String] :~> Int +day02a = + MkSol + { sParse = Just . lines + , sShow = show + , sSolve = + mulTwoThree -- > lookup how many times + -- 2 and 3 occurred, and + -- multiply + . freqs -- > build a frequency map of + -- all seen frequencies + . concatMap -- > get the frequency map of + (nubOrd . M.elems . freqs) -- each string, and then + -- combine all of the + -- frequencies into a big + -- list of frequencies + } + where + mulTwoThree m = (*) <$> M.lookup 2 m <*> M.lookup 3 m + +-- | The main work is in 'firstNeighbor', which looks thorugh a list of +-- items and finds the first item whose neighbor was already seen. +-- +-- Then we take the two "almost matching" strings and filter out all of the +-- characters that aren't the same, using 'zipWith' and 'catMaybes'. +day02b :: [String] :~> String +day02b = + MkSol + { sParse = Just . lines + , sShow = id + , sSolve = + fmap (uncurry onlySame) + . firstNeighbor + } + where + onlySame xs = catMaybes . zipWith (\x y -> x <$ guard (x == y)) xs + +-- | Find the first string in a list that is a neighbor of a previous +-- string. +firstNeighbor :: [String] -> Maybe (String, String) +firstNeighbor = go S.empty + where + go seen (x : xs) = case find (`S.member` seen) (neighbors x) of + Just n -> Just (x, n) + Nothing -> go (x `S.insert` seen) xs + go _ [] = Nothing + +-- | Get all one-character neighbors of a given string +neighbors :: String -> [String] +neighbors = perturbations (const ['a' .. 'z']) diff --git a/2018/AOC2018/Day03.hs b/2018/AOC2018/Day03.hs new file mode 100644 index 0000000..b22721c --- /dev/null +++ b/2018/AOC2018/Day03.hs @@ -0,0 +1,103 @@ +-- | +-- Module : AOC2018.Day03 +-- Copyright : (c) Justin Le 2018 +-- License : BSD3 +-- +-- Maintainer : justin@jle.im +-- Stability : experimental +-- Portability : non-portable +-- +-- Day 3. See "AOC.Solver" for the types used in this module! +module AOC2018.Day03 ( + day03a, + day03b, +) where + +import AOC.Common (clearOut, firstJust, freqs) +import AOC.Solver ((:~>) (..)) +import Control.Monad (guard) +import Data.Char (isDigit) +import Data.Ix (range) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (mapMaybe) +import Linear (V2 (..)) +import Text.Read (readMaybe) + +-- | x and y +type Coord = V2 Int + +-- | Claim ID and rectangle +data Claim = C + { _cId :: Int + , _cRect :: Rect + } + +-- | Start , and size +data Rect = R + { _rStart :: Coord + , _rSize :: Coord + } + +-- | Attempt to parse a line into @(Int, Rect)@ (a claim ID #, and the +-- rectangle claimed) +parseLine :: String -> Maybe Claim +parseLine = + mkLine + . mapMaybe readMaybe + . words + . clearOut (not . isDigit) + where + mkLine [i, x0, y0, w, h] = Just $ C i (R (V2 x0 y0) (V2 w h)) + mkLine _ = Nothing + +-- | Get a list of all coordinates within a given rectangle specification +tiles :: Rect -> [Coord] +tiles (R start size) = range (start, start + size - 1) + +-- | Generate a frequency map of tiles to number of claims at that tile +layTiles :: [Rect] -> Map Coord Int +layTiles = freqs . concatMap tiles + +-- | Lends itself pretty well to a functional approach. +-- +-- 1. Lay the tiles. +-- 2. Get all the frequencies at each time +-- 3. Filter for the frequencies greater than 2 +-- 4. Count them +day03a :: [Rect] :~> Int +day03a = + MkSol + { sParse = traverse (fmap _cRect . parseLine) . lines + , sShow = show + , sSolve = + Just + . length -- > how many? + . filter (>= 2) -- > only frequencies >= 2 + . M.elems -- > get all frequencies + . layTiles -- > lay the tiles + } + +-- | Once we lay our tiles, we find the first claim that has no overlaps. +day03b :: [Claim] :~> Int +day03b = + MkSol + { sParse = traverse parseLine . lines + , sShow = show + , sSolve = \ts -> + let tilesClaimed = layTiles (_cRect <$> ts) -- > get all tiles claimed frequency map + in firstJust (noOverlap tilesClaimed) ts -- > find the ID that is not overlapping + } + +-- | Given a map of tiles claimed (and how many are claiming that spot) and +-- a claim ID and rectangle, check if all of the claim's rectangles are +-- alone in the map (are claimed by only one claim). +-- +-- If yes, return the ID of the claim. +noOverlap :: + Map Coord Int -> + Claim -> + Maybe Int +noOverlap tilesClaimed C{..} = _cId <$ guard (all isAlone (tiles _cRect)) + where + isAlone c = M.lookup c tilesClaimed == Just 1 diff --git a/2018/AOC2018/Day04.hs b/2018/AOC2018/Day04.hs new file mode 100644 index 0000000..4d524a1 --- /dev/null +++ b/2018/AOC2018/Day04.hs @@ -0,0 +1,121 @@ +-- | +-- Module : AOC2018.Day04 +-- Copyright : (c) Justin Le 2018 +-- License : BSD3 +-- +-- Maintainer : justin@jle.im +-- Stability : experimental +-- Portability : non-portable +-- +-- Day 4. See "AOC.Solver" for the types used in this module! +module AOC2018.Day04 ( + day04a, + day04b, +) where + +import AOC.Common (clearOut, freqs, maximumVal, maximumValBy) +import AOC.Solver ((:~>) (..)) +import AOC.Util (eitherToMaybe) +import Control.Applicative (many) +import Data.Char (isAlphaNum) +import Data.Finite (Finite, packFinite) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Ord (comparing) +import qualified Text.Parsec as P +import Text.Read (readMaybe) + +type Minute = Finite 60 + +-- | Map of minutes to times slept at that minute +type TimeCard = Map Minute Int + +-- | Rudimentary time tuple +data Time = T + { _tYear :: Integer + , _tMonth :: Integer + , _tDay :: Integer + , _tHour :: Finite 24 + , _tMinute :: Minute + } + deriving (Show, Eq, Ord) + +-- | A guard ID. It's a newtype to prevent us from accidentally mixing up +-- all of the integer types involved. +newtype Guard = G {_gId :: Int} + deriving (Show, Eq, Ord) + +-- | A logged action +data Action + = AShift Guard + | ASleep + | AWake + deriving (Show, Eq, Ord) + +-- | Parse a stream of @('Time', 'Action')@ events +type Parser = P.Parsec [(Time, Action)] () + +-- | From a stream of @('Time', 'Action')@ events, accumulate a map of +-- guards to time cards. +buildTimeCards :: Map Time Action -> Maybe (Map Guard TimeCard) +buildTimeCards = eitherToMaybe . P.parse fullLog "" . M.toList + where + -- \| A log is many guard shifts. The result is a frequency map of all + -- of the guards' accumulated minutes. + fullLog :: Parser (Map Guard TimeCard) + fullLog = fmap freqs . M.fromListWith (++) <$> many guardShift + -- \| A shift is a guard chagen with many naps. Returns the minues + -- slept, with the guard ID. + guardShift :: Parser (Guard, [Minute]) + guardShift = do + (_, AShift g) <- P.anyToken + napMinutes <- concat <$> many (P.try nap) + pure (g, napMinutes) + -- \| A nap is a sleep then a wake. Return the minutes slept. + nap :: Parser [Minute] + nap = do + (T _ _ _ _ m0, ASleep) <- P.anyToken + (T _ _ _ _ m1, AWake) <- P.anyToken + pure [m0 .. m1 - 1] + +day04a :: Map Time Action :~> Int +day04a = + MkSol + { sParse = fmap M.fromList . traverse parseLine . lines + , sShow = show + , sSolve = \logs -> do + timeCards <- buildTimeCards logs + (worstGuard, timeCard) <- maximumValBy (comparing sum) timeCards + (worstMinute, _) <- maximumVal timeCard + pure $ _gId worstGuard * fromIntegral worstMinute + } + +day04b :: Map Time Action :~> Int +day04b = + MkSol + { sParse = fmap M.fromList . traverse parseLine . lines + , sShow = show + , sSolve = \logs -> do + timeCards <- buildTimeCards logs + let worstMinutes :: Map Guard (Minute, Int) + worstMinutes = M.mapMaybe maximumVal timeCards + (worstGuard, (worstMinute, _)) <- maximumValBy (comparing snd) worstMinutes + pure $ _gId worstGuard * fromIntegral worstMinute + } + +parseLine :: String -> Maybe (Time, Action) +parseLine str = do + [y, mo, d, h, mi] <- traverse readMaybe timeStamp + t <- T y mo d <$> packFinite h <*> packFinite mi + a <- case rest of + "falls" : "asleep" : _ -> Just ASleep + "wakes" : "up" : _ -> Just AWake + "Guard" : n : _ -> AShift . G <$> readMaybe n + _ -> Nothing + pure (t, a) + where + (timeStamp, rest) = + splitAt 5 + . words + . clearOut (not . isAlphaNum) + $ str diff --git a/2018/AOC2018/Day05.hs b/2018/AOC2018/Day05.hs new file mode 100644 index 0000000..1bd57a6 --- /dev/null +++ b/2018/AOC2018/Day05.hs @@ -0,0 +1,104 @@ +-- | +-- Module : AOC2018.Day05 +-- Copyright : (c) Justin Le 2018 +-- License : BSD3 +-- +-- Maintainer : justin@jle.im +-- Stability : experimental +-- Portability : non-portable +-- +-- Day 5. See "AOC.Solver" for the types used in this module! +-- +-- Note that this is slow in the current version of "Data.Group.Free" on +-- hackage. See https://github.com/mstksg/free-algebras/tree/freegroup2 +-- for a version that is efficient. +-- +-- See for an +-- explaination. +module AOC2018.Day05 ( + day05a, + day05b, +) where + +import AOC.Common (deleteFinite) +import AOC.Solver ((:~>) (..)) +import Data.Algebra.Free (foldMapFree, returnFree) +import Data.Char (isLower, ord, toLower) +import Data.Finite (Finite, finites, packFinite) +import Data.Group (invert) +import Data.Group.Free (FreeGroupL) +import qualified Data.Group.Free as G + +-- | One of the generators from the full alphabet +type Elem = Finite 26 + +charElem :: + Char -> + Maybe (Either Elem Elem) -- left if lower, right if upper +charElem c + | isLower c = Left <$> i + | otherwise = Right <$> i + where + i = packFinite (fromIntegral (ord (toLower c) - ord 'a')) + +inject :: + Char -> + FreeGroupL Elem +inject = foldMap (either returnFree (invert . returnFree)) . charElem + +day05a :: FreeGroupL Elem :~> Int +day05a = + MkSol + { sParse = Just . foldMap inject + , sShow = show + , sSolve = Just . length . G.toList + } + +day05b :: FreeGroupL Elem :~> Int +day05b = + MkSol + { sParse = Just . foldMap inject + , sShow = show + , sSolve = \xs -> + Just $ + minimum + [ length . G.toList $ foldMapFree (ghomo c) xs + | c <- finites + ] + } + where + -- \| Delete a letter from the group + ghomo :: Elem -> Elem -> FreeGroupL (Finite 25) + ghomo c = foldMap returnFree . deleteFinite c + +-- ------------- + +-- | Old Methods +-- ------------- + +-- anti :: Char -> Char -> Bool +-- anti x y = toLower x == toLower y && x /= y + +-- cons :: Char -> String -> String +-- x `cons` (y:xs) +-- | anti x y = xs +-- | otherwise = x:y:xs +-- x `cons` [] = [x] + +-- day05a :: String :~> Int +-- day05a = MkSol +-- { sParse = Just +-- , sShow = show +-- , sSolve = Just . length . foldr cons [] +-- } + +-- day05b :: String :~> Int +-- day05b = MkSol +-- { sParse = Just +-- , sShow = show +-- , sSolve = \xs -> Just $ minimum [ length $ foldr cons [[] (remove c xs) +-- | c <- ['a' .. 'z'] +-- ] +-- } +-- where +-- remove c = filter $ (/= c) . toLower diff --git a/2018/AOC2018/Day06.hs b/2018/AOC2018/Day06.hs new file mode 100644 index 0000000..2f9f6e9 --- /dev/null +++ b/2018/AOC2018/Day06.hs @@ -0,0 +1,105 @@ +-- | +-- Module : AOC2018.Day06 +-- Copyright : (c) Justin Le 2018 +-- License : BSD3 +-- +-- Maintainer : justin@jle.im +-- Stability : experimental +-- Portability : non-portable +-- +-- Day 6. See "AOC.Solver" for the types used in this module! +module AOC2018.Day06 ( + day06a, + day06b, +) where + +import AOC.Common (clearOut, freqs) +import AOC.Common.Point (Point, boundingBox, mannDist) +import AOC.Solver (dyno_, (:~>) (..)) +import Control.Monad (guard, (<=<)) +import Data.Char (isDigit) +import Data.Functor ((<&>)) +import Data.Ix (range) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map as M +import qualified Data.Set as S +import Linear (V2 (..)) +import Text.Read (readMaybe) +import Witherable (catMaybes, mapMaybe) + +type Box = V2 Point + +bbPoints :: Box -> [Point] +bbPoints (V2 mins maxs) = range (mins, maxs) + +labelVoronoi :: + -- | set of sites + NonEmpty Point -> + -- | point to label + Point -> + -- | the label, if unique + Maybe Point +labelVoronoi sites p = do + (closestSite, _) :| [] <- + Just + . NE.head + . NE.groupWith1 snd + . NE.sortWith snd + $ dists + pure closestSite + where + dists = sites <&> \site -> (site, mannDist p site) + +day06a :: NonEmpty Point :~> Int +day06a = + MkSol + { sParse = (NE.nonEmpty <=< traverse parseLine) . lines + , sShow = show + , sSolve = \sites -> + Just $ + let bb = boundingBox sites + voron = + catMaybes + . M.fromSet (labelVoronoi sites) + . S.fromList + . bbPoints + $ bb + edges = + S.fromList + . mapMaybe (\(point, site) -> site <$ guard (onEdge bb point)) + . M.toList + $ voron + in maximum . freqs . M.filter (`S.notMember` edges) $ voron + } + where + onEdge :: Box -> Point -> Bool + onEdge (V2 xMin yMin `V2` V2 xMax yMax) (V2 x y) = + x `elem` [xMin, xMax] + || y `elem` [yMin, yMax] + +day06b :: NonEmpty Point :~> Int +day06b = + MkSol + { sParse = (NE.nonEmpty <=< traverse parseLine) . lines + , sShow = show + , sSolve = \sites -> + Just + . length + . filter ((< dyno_ "lim" 10000) . (`totalDist` sites)) + . bbPoints + . boundingBox + $ sites + } + where + totalDist p = sum . fmap (mannDist p) + +parseLine :: String -> Maybe Point +parseLine = + (packUp =<<) + . traverse readMaybe + . words + . clearOut (not . isDigit) + where + packUp [x, y] = Just $ V2 x y + packUp _ = Nothing diff --git a/2018/AOC2018/Day07.hs b/2018/AOC2018/Day07.hs new file mode 100644 index 0000000..418127b --- /dev/null +++ b/2018/AOC2018/Day07.hs @@ -0,0 +1,166 @@ +-- | +-- Module : AOC2018.Day07 +-- Copyright : (c) Justin Le 2018 +-- License : BSD3 +-- +-- Maintainer : justin@jle.im +-- Stability : experimental +-- Portability : non-portable +-- +-- Day 7. See "AOC.Solver" for the types used in this module! +module AOC2018.Day07 ( + day07a, + day07b, +) where + +import AOC.Solver (dyno_, (:~>) (..)) +import Control.Lens +import Control.Monad.RWS (MonadReader (..), MonadState (..), MonadWriter (..), runRWS) +import Data.Bifunctor (second) +import Data.Char (isUpper, ord) +import Data.Foldable (find, fold, forM_, toList) +import Data.List (sortOn) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import Data.Map (Map) +import qualified Data.Map as M +import Data.Semigroup (Sum (..)) +import Data.Set (Set) +import qualified Data.Set as S +import Data.Set.NonEmpty (NESet) +import qualified Data.Set.NonEmpty as NES +import Data.Tuple (swap) +import Numeric.Natural (Natural) +import Witherable (mapMaybe) + +parseAll :: String -> Maybe (Map Char (Set Char)) +parseAll = + fmap (M.fromListWith (<>) . (map . second) S.singleton) + . traverse parseLine + . lines + +parseLine :: String -> Maybe (Char, Char) +parseLine = pack . filter isUpper + where + pack [_, a, b] = Just (a, b) + pack _ = Nothing + +makeDeps :: (Ord a, Ord b) => Map a (Set b) -> Map b (NESet a) +makeDeps = + M.fromListWith (<>) + . map (second NES.singleton . swap) + . concatMap (traverse toList) + . M.toList + +findRoots :: Ord a => Map a (Set a) -> Set a +findRoots mp = cs `S.difference` targs + where + cs = M.keysSet mp + targs = S.unions $ toList mp + +lexicoTopo :: Ord a => Map a (Set a) -> [a] +lexicoTopo childs = go (makeDeps childs) (findRoots childs) + where + go deps active = flip foldMap (find (`M.notMember` deps) active) $ \c -> + let newDeps = mapMaybe (NES.nonEmptySet . NES.delete c) deps + newActive = + maybe id (<>) (M.lookup c childs) + . S.delete c + $ active + in c : go newDeps newActive + +day07a :: Map Char (Set Char) :~> String +day07a = + MkSol + { sParse = parseAll + , sShow = id + , sSolve = Just . lexicoTopo + } + +data Env a = Env + { _envCap :: Int + , _envWaiter :: a -> Natural + } + +makeLenses ''Env + +data Scheduler a = MkSched + { _schedQueue :: !(Set a) + , _schedActive :: !(Map a Natural) + } + +makeClassy ''Scheduler + +buildSleigh :: + forall a m. + ( Ord a + , MonadState (Scheduler a) m + , MonadReader (Env a) m + , MonadWriter (Sum Natural) m + ) => + Map a (Set a) -> + m () +buildSleigh childs = go (findRoots childs) (makeDeps childs) + where + go :: Set a -> Map a (NESet a) -> m () + go toAdd deps = do + popped <- stepScheduler toAdd + forM_ (NES.nonEmptySet popped) $ \popped' -> + let newDeps = mapMaybe (NES.nonEmptySet . (`NES.difference` popped')) deps + newToAdd = + S.filter (`M.notMember` newDeps) + . foldMap (fold . (`M.lookup` childs)) + $ popped' + in go newToAdd newDeps + +day07b :: Map Char (Set Char) :~> Natural +day07b = + MkSol + { sParse = parseAll + , sShow = show + , sSolve = \mp -> + Just $ + let env = + Env + { _envCap = dyno_ "cap" 5 + , _envWaiter = + fromIntegral + . (+ 1) + . (+ dyno_ "wait" 60) + . subtract (ord 'A') + . ord + } + in getSum . view _3 . runRWS (buildSleigh mp) env $ emptyScheduler + } + +-- | Scheduler Implementation +emptyScheduler :: Scheduler a +emptyScheduler = MkSched S.empty M.empty + +stepScheduler :: + ( Ord a + , HasScheduler s a + , MonadState s m + , MonadReader (Env a) m + , MonadWriter (Sum Natural) m + ) => + Set a -> + m (Set a) -- if empty, it means scheduler is exhausted +stepScheduler new = do + cap <- view envCap + waiter <- view envWaiter + schedQueue <>= new + numToAdd <- uses schedActive $ (cap -) . M.size + toAdd <- schedQueue %%= S.splitAt numToAdd + active <- schedActive <<>= M.fromSet waiter toAdd + case NE.groupWith snd . sortOn snd $ M.toList active of + [] -> pure S.empty + toPop@((_, popTime) :| _) : stillActive -> do + schedActive + .= ( M.map (subtract popTime) + . M.fromDistinctAscList + . concatMap toList + $ stillActive + ) + tell $ Sum popTime + pure $ S.fromDistinctAscList . map fst . toList $ toPop diff --git a/2018/AOC2018/Day08.hs b/2018/AOC2018/Day08.hs new file mode 100644 index 0000000..23b3534 --- /dev/null +++ b/2018/AOC2018/Day08.hs @@ -0,0 +1,60 @@ +-- | +-- Module : AOC2018.Day08 +-- Copyright : (c) Justin Le 2018 +-- License : BSD3 +-- +-- Maintainer : justin@jle.im +-- Stability : experimental +-- Portability : non-portable +-- +-- Day 8. See "AOC.Solver" for the types used in this module! +module AOC2018.Day08 ( + day08a, + day08b, +) where + +import AOC.Common (TokStream, parseTokStream_) +import AOC.Solver ((:~>) (..)) +import Control.Lens (ix, (^?)) +import Control.Monad (replicateM) +import Data.Maybe (mapMaybe) +import Data.Void (Void) +import qualified Text.Megaparsec as P +import Text.Read (readMaybe) + +type Parser = P.Parsec Void (TokStream Int) + +sum1 :: Parser Int +sum1 = do + numChild <- P.anySingle + numMeta <- P.anySingle + childs <- sum <$> replicateM numChild sum1 + metas <- sum <$> replicateM numMeta P.anySingle + pure $ childs + metas + +day08a :: [Int] :~> Int +day08a = + MkSol + { sParse = traverse readMaybe . words + , sShow = show + , sSolve = parseTokStream_ sum1 + } + +sum2 :: Parser Int +sum2 = do + numChild <- P.anySingle + numMeta <- P.anySingle + childs <- replicateM numChild sum2 + metas <- replicateM numMeta P.anySingle + pure $ + if null childs + then sum metas + else sum . mapMaybe (\i -> childs ^? ix (i - 1)) $ metas + +day08b :: [Int] :~> Int +day08b = + MkSol + { sParse = traverse readMaybe . words + , sShow = show + , sSolve = parseTokStream_ sum2 + } diff --git a/2018/AOC2018/Day09.hs b/2018/AOC2018/Day09.hs new file mode 100644 index 0000000..ff71d20 --- /dev/null +++ b/2018/AOC2018/Day09.hs @@ -0,0 +1,78 @@ +-- | +-- Module : AOC2018.Day09 +-- Copyright : (c) Justin Le 2018 +-- License : BSD3 +-- +-- Maintainer : justin@jle.im +-- Stability : experimental +-- Portability : non-portable +-- +-- Day 9. See "AOC.Solver" for the types used in this module! +module AOC2018.Day09 ( + day09a, + day09b, +) where + +import AOC.Solver ((:~>) (..)) +import Control.Lens (ix, (+~)) +import Data.Bifunctor (second) +import Data.Function ((&)) +import Data.List (foldl') +import Data.List.PointedList.Circular (PointedList (..)) +import qualified Data.List.PointedList.Circular as PL +import Data.Maybe (fromJust, mapMaybe) +import qualified Data.Vector.Unboxed as V +import Text.Read (readMaybe) + +place :: + -- | number to place + Int -> + -- | tape + PointedList Int -> + -- | resulting tape, and scored points + (Int, PointedList Int) +place x l + | x `mod` 23 == 0 = + let l' = PL.moveN (-7) l + toAdd = _focus l' + in (toAdd + x, fromJust (PL.deleteRight l')) + | otherwise = + (0, (PL.insertLeft x . PL.moveN 2) l) + +run :: + -- | number of players + Int -> + -- | Max # of piece + Int -> + V.Vector Int +run numPlayers maxPiece = + fst + . foldl' go (V.replicate numPlayers 0, PL.singleton 0) + $ zip players toInsert + where + go (!scores, !tp) (!p, !i) = (scores & ix p +~ pts, tp') + where + (pts, tp') = place i tp + players = (`mod` numPlayers) <$> [0 ..] + toInsert = [1 .. maxPiece] + +day09a :: (Int, Int) :~> Int +day09a = + MkSol + { sParse = parse + , sShow = show + , sSolve = Just . V.maximum . uncurry run + } + +day09b :: _ :~> _ +day09b = + MkSol + { sParse = parse + , sShow = show + , sSolve = Just . V.maximum . uncurry run . second (* 100) + } + +parse :: String -> Maybe (Int, Int) +parse xs = case mapMaybe readMaybe (words xs) of + [p, n] -> Just (p, n) + _ -> Nothing diff --git a/2018/AOC2018/Day10.hs b/2018/AOC2018/Day10.hs new file mode 100644 index 0000000..0dfe797 --- /dev/null +++ b/2018/AOC2018/Day10.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE QuasiQuotes #-} + +-- | +-- Module : AOC2018.Day10 +-- Copyright : (c) Justin Le 2018 +-- License : BSD3 +-- +-- Maintainer : justin@jle.im +-- Stability : experimental +-- Portability : non-portable +-- +-- Day 10. See "AOC.Solver" for the types used in this module! +module AOC2018.Day10 ( + day10a, + day10b, + centralize, +) where + +import AOC.Common (clearOut) +import AOC.Common.Point (parseLettersSafe) +import AOC.Solver ((:~>) (..)) +import Data.Char (isDigit) +import Data.Maybe (fromMaybe) +import Data.Semigroup (Sum (..)) +import Data.Set (Set) +import qualified Data.Set as S +import Linear (V2 (..)) +import qualified Linear as L + +type Point = V2 Double +type Lattice = V2 Int + +-- | Shift so that centroid is at zero +centralize :: [Point] -> [Point] +centralize ps = map (subtract mean) ps + where + (Sum tot, Sum len) = foldMap (\x -> (Sum x, Sum 1)) ps + mean = tot L.^/ len + +-- | Multiply and find trace +traceMul :: [Point] -> [Point] -> Double +traceMul xs ys = sum $ zipWith L.dot xs ys + +findWord :: + -- | velocities + [Point] -> + -- | points + [Point] -> + -- | points in word, and # of iterations + (Set Lattice, Int) +findWord (centralize -> vs) (centralize -> xs) = + (S.fromList ((map . fmap) round final), round t) + where + t = negate $ traceMul xs vs / traceMul vs vs + final = zipWith (\v x -> x + t L.*^ v) vs xs + +day10a :: ([Point], [Point]) :~> Set Lattice +day10a = + MkSol + { sParse = fmap unzip . traverse parsePoint . lines + , sShow = fromMaybe "" . parseLettersSafe + , sSolve = Just . fst . uncurry findWord + } + +day10b :: ([Point], [Point]) :~> Int +day10b = + MkSol + { sParse = fmap unzip . traverse parsePoint . lines + , sShow = show + , sSolve = Just . snd . uncurry findWord + } + +parsePoint :: String -> Maybe (Point, Point) +parsePoint xs = case map read . words . clearOut p $ xs of + [x, y, vx, vy] -> Just (V2 vx vy, V2 x y) + _ -> Nothing + where + p '-' = False + p c = not $ isDigit c diff --git a/2018/AOC2018/Day11.hs b/2018/AOC2018/Day11.hs new file mode 100644 index 0000000..4df5dac --- /dev/null +++ b/2018/AOC2018/Day11.hs @@ -0,0 +1,143 @@ +-- | +-- Module : AOC2018.Day11 +-- Copyright : (c) Justin Le 2018 +-- License : BSD3 +-- +-- Maintainer : justin@jle.im +-- Stability : experimental +-- Portability : non-portable +-- +-- Day 11. See "AOC.Solver" for the types used in this module! +module AOC2018.Day11 ( + day11a, + day11b, +) where + +import AOC.Common (meanVar) +import AOC.Common.Point (Point) +import AOC.Solver ((:~>) (..)) +import Control.DeepSeq (force) +import qualified Control.Foldl as F +import Data.Foldable (maximumBy) +import Data.Ix (range) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (catMaybes) +import Data.Ord (comparing) +import Data.Profunctor (dimap) +import qualified Data.Set as S +import Linear (V2 (..)) +import qualified Statistics.Distribution as D +import qualified Statistics.Distribution.Binomial as D +import qualified Statistics.Distribution.Normal as D +import Text.Read (readMaybe) + +powerLevel :: Int -> Point -> Int +powerLevel sid (V2 x y) = hun ((rid * y + sid) * rid) - 5 + where + hun = (`mod` 10) . (`div` 100) + rid = x + 10 + +findMaxThree :: Map Point Int -> Point +findMaxThree mp = + fst + . maximumBy (comparing snd) + . map (\x -> (x, go x)) + $ range (V2 1 1, V2 298 298) + where + go p = + sum + [ mp M.! (p + shift) + | shift <- range (V2 0 0, V2 2 2) + ] + +mkMap :: Int -> Map Point Int +mkMap i = M.fromSet (powerLevel i) . S.fromList $ range (V2 1 1, V2 300 300) + +day11a :: Int :~> Point +day11a = + MkSol + { sParse = readMaybe + , sShow = \(V2 x y) -> show x ++ "," ++ show y + , sSolve = Just . findMaxThree . mkMap + } + +day11b :: Int :~> (Point, Int) +day11b = + MkSol + { sParse = readMaybe + , sShow = \(V2 x y, s) -> show x ++ "," ++ show y ++ "," ++ show s + , sSolve = Just . findMaxAny . mkMap + } + +findMaxAny :: Map Point Int -> (Point, Int) +findMaxAny mp = fst $ go 1 + where + go n + | goOn > 0.001 = maximumBy (comparing snd) [((pMax, n), oMax), go (n + 1)] + | otherwise = ((pMax, n), oMax) + where + -- & traceShow (n, oMax, goOn) + + (pMax, oMax) = + maximumBy + (comparing snd) + [ (p, fromIntegral (fromSAT sat p n)) + | p <- range (V2 1 1, V2 (300 - n + 1) (300 - n + 1)) + ] + goOn = + sum + [ probGreaterThan oMax n' + | n' <- [n + 1 .. 300] + ] + !sat = summedAreaTable mp + σ :: Double + σ = sqrt $ ((4 + 5) ** 2) / 12 -- stdev of uniform distribution between -5 and 4 + probGreaterThan o n + | prob2 == 0 = 0 + | otherwise = probIn2 + where + n' = fromIntegral n + distr2 = D.normalDistr (-(n' ** 2) * 0.5) (n' * σ) + prob2 = D.complCumulative distr2 o + numIn2 = + ( (300 `div` n) ^ (2 :: Int) -- we compensate for dependence + + (300 - n + 1) ^ (2 :: Int) + ) + `div` 2 + probIn2 = 1 - D.probability (D.binomial numIn2 prob2) 0 + +-- this is technically not a bernoulli process, +-- because our items are dependent. but we fudge this +-- by tweaking the number of trials + +fromSAT :: Map Point Int -> Point -> Int -> Int +fromSAT sat (subtract (V2 1 1) -> p) n = + sum . catMaybes $ + [ M.lookup p sat + , M.lookup (p + V2 n n) sat + , negate <$> M.lookup (p + V2 0 n) sat + , negate <$> M.lookup (p + V2 n 0) sat + ] + +summedAreaTable :: Map Point Int -> Map Point Int +summedAreaTable mp = force sat + where + sat = M.mapWithKey go mp + go p0 v = + (+ v) . sum . catMaybes $ + [ negate <$> M.lookup (p0 - V2 1 1) sat + , M.lookup (p0 - V2 1 0) sat + , M.lookup (p0 - V2 0 1) sat + ] + +-- | Debug: find the variance of the map at every square size +_chunkyVars :: Map Point Int -> Map Int Double +_chunkyVars mp = flip M.fromSet (S.fromList [1 .. 300]) $ \n -> + F.fold + (dimap fromIntegral snd meanVar) + [ fromSAT sat p n + | p <- range (V2 1 1, V2 (300 - n + 1) (300 - n + 1)) + ] + where + !sat = summedAreaTable mp diff --git a/2018/AOC2018/Day12.hs b/2018/AOC2018/Day12.hs new file mode 100644 index 0000000..9a818ec --- /dev/null +++ b/2018/AOC2018/Day12.hs @@ -0,0 +1,109 @@ +-- | +-- Module : AOC2018.Day12 +-- Copyright : (c) Justin Le 2018 +-- License : BSD3 +-- +-- Maintainer : justin@jle.im +-- Stability : experimental +-- Portability : non-portable +-- +-- Day 12. See "AOC.Solver" for the types used in this module! +module AOC2018.Day12 ( + day12a, + day12b, +) where + +import AOC.Common ((!!!)) +import AOC.Solver ((:~>) (..)) +import Data.Bifunctor (bimap) +import Data.Finite (Finite, finites) +import qualified Data.Map as M +import Data.Set (Set) +import qualified Data.Set as S + +type Ctx = Set (Finite 5) +type Pos = Int + +step :: + Set Ctx -> + Set Pos -> + Set Pos +step ctxs w0 = + S.fromDistinctAscList + . filter go + $ [S.findMin w0 - 2 .. S.findMax w0 + 2] + where + go i = neighbs `S.member` ctxs + where + neighbs = S.fromDistinctAscList . flip filter finites $ \j -> + (i - 2 + fromIntegral j) `S.member` w0 + +findLoop :: + Set Ctx -> + Set Pos -> + (Int, Int, Int) -- time to loop, loop size, loop incr +findLoop ctxs w0 = go (M.singleton w0 (0, 0)) 1 w0 + where + go !seen !i !w = case M.lookup w'Norm seen of + Nothing -> go (M.insert w'Norm (mn, i) seen) (i + 1) w' + Just (seenMn, seenI) -> (seenI, i - seenI, mn - seenMn) + where + w' = step ctxs w + (mn, w'Norm) = normalize w' + normalize w = (mn, S.map (subtract mn) w) + where + mn = S.findMin w + +stepN :: + Int -> + Set Pos -> + Set Ctx -> + Set Pos +stepN n w ctx = + goN extra + . S.map (+ (loopIncr * looped)) + . goN ttl + $ w + where + goN m = (!!! m) . iterate (step ctx) + (ttl, loopSize, loopIncr) = findLoop ctx w + (looped, extra) = (n - ttl) `divMod` loopSize + +day12a :: (Set Pos, Set Ctx) :~> Int +day12a = + MkSol + { sParse = Just . bimap makeState makeCtxs . span (/= '\n') + , sShow = show + , sSolve = \(w, ctx) -> Just . sum $ iterate (step ctx) w !!! 20 + } + +day12b :: (Set Pos, Set Ctx) :~> Int +day12b = + MkSol + { sParse = Just . bimap makeState makeCtxs . span (/= '\n') + , sShow = show + , sSolve = Just . sum . uncurry (stepN 50000000000) + } + +makeState :: String -> Set Pos +makeState = + M.keysSet + . M.filter (== '#') + . M.fromList + . zip [0 ..] + . filter (`elem` "#.") + +makeCtxs :: String -> Set Ctx +makeCtxs = + M.keysSet + . M.filter id + . M.fromList + . map + ( bimap parseLine head + . splitAt 5 + . map (== '#') + . filter (`elem` "#.") + ) + . lines + where + parseLine = S.fromList . map fst . filter snd . zip finites diff --git a/2018/AOC2018/Day13.hs b/2018/AOC2018/Day13.hs new file mode 100644 index 0000000..d6dcdc0 --- /dev/null +++ b/2018/AOC2018/Day13.hs @@ -0,0 +1,142 @@ +-- | +-- Module : AOC2018.Day13 +-- Copyright : (c) Justin Le 2018 +-- License : BSD3 +-- +-- Maintainer : justin@jle.im +-- Stability : experimental +-- Portability : non-portable +-- +-- Day 13. See "AOC.Solver" for the types used in this module! +module AOC2018.Day13 ( + day13a, + day13b, +) where + +import AOC.Common.Point (Point, ScanPoint (..), parseAsciiMap) +import AOC.Solver ((:~>) (..)) +import Control.Lens (makeLenses, over, (^.)) +import Data.Bifunctor (second) +import Data.Functor.Foldable (hylo) +import Data.Map (Map) +import qualified Data.Map as M +import Linear (V2 (..)) + +data Turn + = -- | a forward-slash mirror @/@ + TurnNW + | -- | a backwards-slash mirror @\\@ + TurnNE + | -- | a four-way intersection + TurnInter + deriving stock (Eq, Show, Ord) + +data Dir = DN | DE | DS | DW + deriving stock (Eq, Show, Ord, Enum, Bounded) + +data Cart = C + { _cDir :: Dir + , _cTurns :: Int + } + deriving stock (Eq, Show) + +makeLenses ''Cart + +type World = Map Point Turn +type Carts = Map ScanPoint Cart + +-- | Step a single cart through the world. +stepCart :: World -> ScanPoint -> Cart -> (ScanPoint, Cart) +stepCart w (SP p) c = (SP p', maybe id turner (M.lookup p' w) c) + where + p' = + p + case c ^. cDir of + DN -> V2 0 (-1) + DE -> V2 1 0 + DS -> V2 0 1 + DW -> V2 (-1) 0 + turner = \case + TurnNW -> over cDir $ \case DN -> DE; DE -> DN; DS -> DW; DW -> DS + TurnNE -> over cDir $ \case DN -> DW; DW -> DN; DS -> DE; DE -> DS + TurnInter -> over cTurns (+ 1) . over cDir (turnWith (c ^. cTurns)) + turnWith i = case i `mod` 3 of + 0 -> turnLeft + 1 -> id + _ -> turnLeft . turnLeft . turnLeft + turnLeft DN = DW + turnLeft DE = DN + turnLeft DS = DE + turnLeft DW = DS + +-- | One of the ways a single step of the simulation can go. +data CartLog a + = -- | A crash, at a given point + CLCrash Point a + | -- | No crashes, just a normal timestep + CLTick a + | -- | Only one car left, at a given point + CLDone Point + deriving stock (Show, Functor) + +-- | Given a (waiting, done) queue, emit a 'CartLog' event with an updated +-- (waiting, done) queue. +stepCarts :: + World -> + (Carts, Carts) -> + CartLog (Carts, Carts) +stepCarts w (waiting, done) = case M.minViewWithKey waiting of + Nothing -> case M.minViewWithKey done of + Just ((SP lastPos, _), M.null -> True) -> CLDone lastPos + _ -> CLTick (done, M.empty) + Just (uncurry (stepCart w) -> (p, c), waiting') -> + case M.lookup p (waiting' <> done) of + Nothing -> CLTick (waiting', M.insert p c done) + Just _ -> CLCrash (_getSP p) (M.delete p waiting', M.delete p done) + +-- | Given a folding function, simulate on events emitted by 'stepCarts'. +simulateWith :: + (CartLog a -> a) -> + World -> + Carts -> + a +simulateWith f w c = (f `hylo` stepCarts w) (c, M.empty) + +day13a :: (World, Carts) :~> Point +day13a = + MkSol + { sParse = Just . parseWorld + , sShow = \(V2 x y) -> show x ++ "," ++ show y + , sSolve = uncurry (simulateWith firstCrash) + } + where + firstCrash (CLCrash p _) = Just p + firstCrash (CLTick p) = p + firstCrash (CLDone _) = Nothing + +day13b :: (World, Carts) :~> Point +day13b = + MkSol + { sParse = Just . parseWorld + , sShow = \(V2 x y) -> show x ++ "," ++ show y + , sSolve = Just . uncurry (simulateWith lastPoint) + } + where + lastPoint (CLCrash _ p) = p + lastPoint (CLTick p) = p + lastPoint (CLDone p) = p + +parseWorld :: String -> (World, Carts) +parseWorld = + second (M.mapKeys SP) + . M.mapEither (second (`C` 0)) + . parseAsciiMap go + where + go = \case + '/' -> Just . Left $ TurnNW + '\\' -> Just . Left $ TurnNE + '+' -> Just . Left $ TurnInter + 'v' -> Just . Right $ DS + '^' -> Just . Right $ DN + '>' -> Just . Right $ DE + '<' -> Just . Right $ DW + _ -> Nothing diff --git a/2018/AOC2018/Day14.hs b/2018/AOC2018/Day14.hs new file mode 100644 index 0000000..4f76bd2 --- /dev/null +++ b/2018/AOC2018/Day14.hs @@ -0,0 +1,56 @@ +module AOC2018.Day14 ( + day14a, + day14b, +) where + +import AOC.Solver ((:~>) (..)) +import Data.List (isPrefixOf, tails) +import Data.Maybe (mapMaybe) +import qualified Data.Sequence as Seq +import Text.Read (readMaybe) + +digitize :: Int -> [Int] +digitize ((`divMod` 10) -> (x, y)) + | x == 0 = [y] + | otherwise = [x, y] + +-- | This is our lazily generated stream of chocolate practice numbers! +-- Items will be demanded as users ask for them. +-- +-- Note that this is independent of the input numbers, so it can be +-- generated in advance and shared by all inputs. +-- +-- (This is actually a futumorphism, but don't tell anyone) +chocolatePractice :: [Int] +chocolatePractice = 3 : 7 : go 0 1 (Seq.fromList [3, 7]) + where + go !p1 !p2 !tp = newDigits ++ go p1' p2' tp' + where + sc1 = tp `Seq.index` p1 + sc2 = tp `Seq.index` p2 + newDigits = digitize $ sc1 + sc2 + tp' = tp <> Seq.fromList newDigits + p1' = (p1 + sc1 + 1) `mod` length tp' + p2' = (p2 + sc2 + 1) `mod` length tp' + +day14a :: Int :~> [Int] +day14a = + MkSol + { sParse = readMaybe + , sShow = concatMap show + , sSolve = Just . take 10 . (`drop` chocolatePractice) + } + +substrLoc :: [Int] -> [Int] -> Int +substrLoc xs = + length + . takeWhile (not . (xs `isPrefixOf`)) + . tails + +day14b :: [Int] :~> Int +day14b = + MkSol + { sParse = Just . mapMaybe (readMaybe . (: [])) + , sShow = show + , sSolve = Just . (`substrLoc` chocolatePractice) + } diff --git a/2018/AOC2018/Day15.hs b/2018/AOC2018/Day15.hs new file mode 100644 index 0000000..3d0a2e7 --- /dev/null +++ b/2018/AOC2018/Day15.hs @@ -0,0 +1,255 @@ +-- | +-- Module : AOC2018.Day15 +-- Copyright : (c) Justin Le 2018 +-- License : BSD3 +-- +-- Maintainer : justin@jle.im +-- Stability : experimental +-- Portability : non-portable +-- +-- Day 15. See "AOC.Solver" for the types used in this module! +module AOC2018.Day15 ( + day15a, + day15b, +) where + +import AOC.Common ( + floodFill, + minimumVal, + minimumValBy, + ) +import AOC.Common.Point ( + ScanPoint (..), + asciiGrid, + boundingBox, + cardinalNeighbs, + mannDist, + ) +import AOC.Common.Search (aStar, exponentialFindMin) +import AOC.Solver ((:~>) (..)) +import Control.Lens (ifoldMapOf, makeLenses, (-~), (.~)) +import Control.Monad (guard) +import Data.Coerce (coerce) +import Data.Fix (Fix) +import Data.Function ((&)) +import Data.Functor.Foldable (ana, cata, hylo) +import Data.List (intercalate) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Ord (comparing) +import Data.Semigroup (First (..), Min (..)) +import Data.Set (Set) +import qualified Data.Set as S +import qualified Data.Set.NonEmpty as NES +import Linear (V2 (..)) +import Text.Printf (printf) + +data EType = EGob | EElf + deriving stock (Show, Eq, Ord, Enum, Bounded) + +data Entity = E + { _eType :: EType + , _eHP :: Int + , _eAtk :: Int + } + deriving stock (Show, Eq) + +makeLenses ''Entity + +type World = Set ScanPoint +type Entities = Map ScanPoint Entity + +neighbs :: ScanPoint -> Set ScanPoint +neighbs = S.fromList . coerce cardinalNeighbs + +type Path = [ScanPoint] + +-- | Yes, it's actual literal A*. +actualLiteralAStar :: + World -> + ScanPoint -> + ScanPoint -> + Maybe Path +actualLiteralAStar w p0 dest = + snd + <$> aStar + (mannDist (_getSP dest) . _getSP) + (M.fromSet (const 1) . (`S.intersection` w) . neighbs) + p0 + (== dest) + +stepTo :: + -- | legal points + Set ScanPoint -> + ScanPoint -> + ScanPoint -> + ScanPoint +stepTo w x dest = + maybe (error "stepTo") (snd . getMin) + . foldMap (\n -> Min . (,n) . length <$> actualLiteralAStar w' n dest) + . (`S.intersection` w') + $ neighbs x + where + w' = S.delete x w + +stepEntity :: + World -> + Entities -> + ScanPoint -> + Entity -> + Maybe ScanPoint +stepEntity w es sp e + | sp `M.member` candidates = Just sp -- we already here + | otherwise = stepTo w' sp <$> destination + where + candidates = + M.fromSet + ( maybe (error "paintBucket") length + . actualLiteralAStar fullRange sp + ) + . (`S.intersection` fullRange) + . foldMap neighbs + . M.keysSet + . M.filter ((/= _eType e) . _eType) + $ es + destination = fst <$> minimumVal candidates + w' = w `S.difference` M.keysSet es + fullRange = + floodFill + ((`S.intersection` w') . neighbs) + (S.singleton sp) + +makeAttack :: + World -> + Entities -> + ScanPoint -> + Entity -> + Maybe ScanPoint +makeAttack w es sp e = fst <$> minimumValBy (comparing _eHP) candidates + where + candidates = + M.delete sp + . (`M.restrictKeys` w) + . (`M.restrictKeys` neighbs sp) + . M.filter ((/= _eType e) . _eType) + $ es + +data BattleLog a + = BLTurn (Maybe EType) a -- whether or not there was a kill + | BLRound a + | BLOver Int -- sum of remaining HPs + deriving stock (Show, Eq, Functor) + +damage :: + Int -> + Maybe Entity -> + (Maybe (First EType), Maybe Entity) -- if was killed, and new entity +damage _ Nothing = (Nothing, Nothing) +damage d (Just e) + | _eHP e > d = (Nothing, Just (e & eHP -~ d)) + | otherwise = (Just (First (_eType e)), Nothing) + +stepBattle :: + World -> + (Entities, Entities) -> + BattleLog (Entities, Entities) +stepBattle w (!waiting, !done) = case M.minViewWithKey waiting of + Nothing -> BLRound (done, M.empty) + Just ((p, toMove), waiting') -> + let allEnts = waiting' <> done + in case stepEntity w allEnts p toMove of + Nothing -> + let (allFriends, allEnemies) = flip M.mapEither (waiting <> done) $ \e -> + if _eType toMove == _eType e + then Left (_eHP e) + else Right () + in if M.null allEnemies + then BLOver $ sum allFriends + else BLTurn Nothing (waiting', M.insert p toMove done) + Just p' -> case makeAttack w allEnts p' toMove of + Nothing -> BLTurn Nothing (waiting', M.insert p' toMove done) + Just toAtk -> + let (killed, (waiting'', done')) = + attackBoth (_eAtk toMove) toAtk waiting' + in BLTurn (getFirst <$> killed) (waiting'', M.insert p' toMove done') + where + attackBoth d k wt = + (,) + <$> M.alterF (damage d) k wt + <*> M.alterF (damage d) k done + +getOutcome :: BattleLog (Int, Int) -> (Int, Int) +getOutcome (BLTurn _ !x) = x +getOutcome (BLRound (!n, !s)) = (n + 1, s) +getOutcome (BLOver !s) = (0, s) + +day15a :: (World, Entities) :~> Int +day15a = + MkSol + { sParse = Just . parseWorld + , sShow = show + , sSolve = \(w, e) -> + Just + . uncurry (*) + . hylo getOutcome (stepBattle w) + $ (e, M.empty) + } + +totalVictory :: BattleLog Bool -> Bool +totalVictory (BLTurn (Just EElf) _) = False +totalVictory (BLTurn _ !k) = k +totalVictory (BLRound !k) = k +totalVictory (BLOver _) = True + +day15b :: (World, Entities) :~> Int +day15b = + MkSol + { sParse = Just . parseWorld + , sShow = show + , sSolve = \(w, es) -> + let goodEnough i = blog <$ guard (cata totalVictory blog) + where + blog :: Fix BattleLog + blog = ana (stepBattle w) (powerUp i es, M.empty) + in uncurry (*) . cata getOutcome <$> exponentialFindMin goodEnough 4 + } + where + powerUp :: Int -> Entities -> Entities + powerUp i = fmap $ \e -> + case _eType e of + EElf -> e & eAtk .~ i + EGob -> e + +parseWorld :: String -> (World, Entities) +parseWorld = ifoldMapOf asciiGrid $ \(SP -> p) -> \case + '.' -> (S.singleton p, mempty) + 'G' -> (S.singleton p, M.singleton p (E EGob 200 3)) + 'E' -> (S.singleton p, M.singleton p (E EElf 200 3)) + _ -> mempty + +_displayWorld :: World -> Entities -> String +_displayWorld w es = + unlines + [ row ++ " " ++ intercalate ", " rEs + | y <- [yMin - 1 .. yMax + 1] + , let (row, rEs) = makeRow y + ] + where + V2 xMin yMin `V2` V2 xMax yMax = + boundingBox . NES.unsafeFromSet . S.map _getSP $ w + makeRow y = flip foldMap [xMin - 1 .. xMax + 1] $ \x -> + let p = SP (V2 x y) + inWorld = p `S.member` w + in case M.lookup p es of + Nothing + | inWorld -> (".", []) + | otherwise -> ("#", []) + Just E{..} -> + ( [entChar _eType] + , [printf "%c(%d)" (entChar _eType) _eHP] + ) + entChar EGob = 'G' + entChar EElf = 'E' + +_unused :: () +_unused = (eType .~) `seq` () diff --git a/2018/AOC2018/Day16.hs b/2018/AOC2018/Day16.hs new file mode 100644 index 0000000..43b0b01 --- /dev/null +++ b/2018/AOC2018/Day16.hs @@ -0,0 +1,178 @@ +-- | +-- Module : AOC2018.Day16 +-- Copyright : (c) Justin Le 2018 +-- License : BSD3 +-- +-- Maintainer : justin@jle.im +-- Stability : experimental +-- Portability : non-portable +-- +-- Day 16. See "AOC.Solver" for the types used in this module! +module AOC2018.Day16 ( + day16a, + day16b, + trialParser, +) where + +import AOC.Solver ((:~>) (..)) +import AOC.Util (eitherToMaybe) +import Control.Lens (enum, (.~), (^.)) +import Control.Monad ((<=<)) +import Control.Monad.Combinators (between, sepBy1, sepEndBy1) +import Control.Monad.State (evalStateT, gets, lift, modify) +import Data.Bits ((.&.), (.|.)) +import Data.Finite (Finite, packFinite) +import Data.Foldable (foldl', toList) +import Data.Function ((&)) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (listToMaybe) +import Data.Set (Set) +import qualified Data.Set as S +import Data.Vector.Sized (Vector) +import qualified Data.Vector.Sized as V +import Data.Void (Void) +import GHC.TypeNats (KnownNat) +import qualified Text.Megaparsec as P +import qualified Text.Megaparsec.Char as P +import qualified Text.Megaparsec.Char.Lexer as P + +type Reg = Vector 4 Int + +data Instr a = I + { _iOp :: a + , _iInA :: Finite 4 + , _iInB :: Finite 4 + , _iOut :: Finite 4 + } + deriving stock (Show, Functor) + +data Trial = T + { _tBefore :: Reg + , _tInstr :: Instr (Finite 16) + , _tAfter :: Reg + } + deriving stock (Show) + +data OpCode + = OAddR + | OAddI + | OMulR + | OMulI + | OBanR + | OBanI + | OBorR + | OBorI + | OSetR + | OSetI + | OGtIR + | OGtRI + | OGtRR + | OEqIR + | OEqRI + | OEqRR + deriving stock (Show, Eq, Ord, Enum, Bounded) + +runOp :: Instr OpCode -> Reg -> Reg +runOp I{..} = case _iOp of + OAddR -> \r -> r & V.ix _iOut .~ r ^. V.ix _iInA + r ^. V.ix _iInB + OAddI -> \r -> r & V.ix _iOut .~ r ^. V.ix _iInA + fromIntegral _iInB + OMulR -> \r -> r & V.ix _iOut .~ r ^. V.ix _iInA * r ^. V.ix _iInB + OMulI -> \r -> r & V.ix _iOut .~ r ^. V.ix _iInA * fromIntegral _iInB + OBanR -> \r -> r & V.ix _iOut .~ r ^. V.ix _iInA .&. r ^. V.ix _iInB + OBanI -> \r -> r & V.ix _iOut .~ r ^. V.ix _iInA .&. fromIntegral _iInB + OBorR -> \r -> r & V.ix _iOut .~ r ^. V.ix _iInA .|. r ^. V.ix _iInB + OBorI -> \r -> r & V.ix _iOut .~ r ^. V.ix _iInA .|. fromIntegral _iInB + OSetR -> \r -> r & V.ix _iOut .~ r ^. V.ix _iInA + OSetI -> \r -> r & V.ix _iOut .~ fromIntegral _iInA + OGtIR -> \r -> r & V.ix _iOut . enum .~ (fromIntegral _iInA > r ^. V.ix _iInB) + OGtRI -> \r -> r & V.ix _iOut . enum .~ (r ^. V.ix _iInA > fromIntegral _iInB) + OGtRR -> \r -> r & V.ix _iOut . enum .~ (r ^. V.ix _iInA > r ^. V.ix _iInB) + OEqIR -> \r -> r & V.ix _iOut . enum .~ (fromIntegral _iInA == r ^. V.ix _iInB) + OEqRI -> \r -> r & V.ix _iOut . enum .~ (r ^. V.ix _iInA == fromIntegral _iInB) + OEqRR -> \r -> r & V.ix _iOut . enum .~ (r ^. V.ix _iInA == r ^. V.ix _iInB) + +plausible :: Trial -> Set OpCode +plausible T{..} = S.fromDistinctAscList . filter tryTrial $ [OAddR ..] + where + tryTrial :: OpCode -> Bool + tryTrial o = runOp (_tInstr{_iOp = o}) _tBefore == _tAfter + +day16a :: [Trial] :~> Int +day16a = + MkSol + { sParse = eitherToMaybe . P.parse (trialParser `sepEndBy1` P.newline) "" + , sShow = show + , sSolve = Just . length . filter ((>= 3) . S.size . plausible) + } + +-- | Our search for a unique configuration of op codes. +fromClues :: Map (Finite 16) (Set OpCode) -> Maybe (Vector 16 OpCode) +fromClues m = listToMaybe . flip evalStateT S.empty . V.generateM $ \i -> do + Just poss <- pure $ M.lookup i m + unseen <- gets (poss `S.difference`) + pick <- lift $ toList unseen + modify $ S.insert pick + pure pick + +day16b :: ([Trial], [Instr (Finite 16)]) :~> Int +day16b = + MkSol + { sParse = + eitherToMaybe + . P.parse + ( (,) + <$> (trialParser `sepEndBy1` P.newline) + <* P.some P.newline + <*> (instrParser `sepEndBy1` P.newline) + ) + "" + , sShow = show + , sSolve = \(ts, is) -> do + opMap <- + fromClues . M.fromListWith S.intersection $ + [ (_iOp (_tInstr t), plausible t) + | t <- ts + ] + pure + . V.head + . foldl' (step opMap) (V.replicate 0) + $ is + } + where + step opMap r i = runOp i' r + where + i' = (opMap `V.index`) <$> i + +-- --------- + +-- | Parsing +-- --------- +type Parser = P.Parsec Void String + +trialParser :: Parser Trial +trialParser = + T + <$> (P.string "Before: " `between` P.newline) (parseVec P.decimal) + <*> instrParser + <* P.newline + <*> (P.string "After: " `between` P.newline) (parseVec P.decimal) + where + parseVec = maybe (fail "list has bad size") pure . V.fromList <=< parseList + parseList d = + (P.char '[' `between` P.char ']') $ + d `sepBy1` P.try (P.char ',' *> P.space1) + +instrParser :: Parser (Instr (Finite 16)) +instrParser = + I + <$> parseFinite + <* P.char ' ' + <*> parseFinite + <* P.char ' ' + <*> parseFinite + <* P.char ' ' + <*> parseFinite + where + parseFinite :: KnownNat n => Parser (Finite n) + parseFinite = maybe (fail "number out of range") pure . packFinite =<< P.decimal diff --git a/2018/AOC2018/Day17.hs b/2018/AOC2018/Day17.hs new file mode 100644 index 0000000..d7b2b45 --- /dev/null +++ b/2018/AOC2018/Day17.hs @@ -0,0 +1,133 @@ +{-# OPTIONS_GHC -Wno-unused-imports #-} + +-- | +-- Module : AOC2018.Day17 +-- Copyright : (c) Justin Le 2018 +-- License : BSD3 +-- +-- Maintainer : justin@jle.im +-- Stability : experimental +-- Portability : non-portable +-- +-- Day 17. See "AOC.Solver" for the types used in this module! +module AOC2018.Day17 ( + day17a, + day17b, +) where + +import AOC.Common (clearOut) +import AOC.Common.Point (Point, boundingBox, displayAsciiMap) +import AOC.Solver ((:~>) (..)) +import Control.Lens ((^.)) +import Control.Monad (void, when) +import Control.Monad.State (execState, gets, modify) +import Data.Char (isDigit) +import Data.Foldable (toList) +import Data.Ix (range) +import qualified Data.List.NonEmpty as NE +import Data.Map (Map) +import qualified Data.Map as M +import Data.Semigroup (Max (..), Min (..)) +import Data.Semigroup.Foldable (toNonEmpty) +import Data.Set (Set) +import qualified Data.Set as S +import Data.Set.NonEmpty (NESet) +import qualified Data.Set.NonEmpty as NES +import Linear (V2 (..), _y) + +drainMap :: + -- | clay + Set Point -> + -- | max y + Int -> + -- | starting point + Point -> + -- | map of water, and whether it is draining + Map Point Bool +drainMap cl ylim = flip execState M.empty . pourDown + where + pourDown p + | p ^. _y > ylim = cache p $ pure True + | otherwise = + cache p $ + goIfPossible p pourDown (V2 0 1) >>= \case + True -> pure True + False -> do + isDrain <- + (||) + <$> goIfPossible p (pourSide (-1)) (V2 (-1) 0) + <*> goIfPossible p (pourSide 1) (V2 1 0) + when isDrain $ do + void $ goIfPossible p (clearSide (-1)) (V2 (-1) 0) + void $ goIfPossible p (clearSide 1) (V2 1 0) + pure isDrain + pourSide dx p = + cache p $ + goIfPossible p pourDown (V2 0 1) >>= \case + True -> pure True + False -> goIfPossible p (pourSide dx) (V2 dx 0) + clearSide dx p = + overrideCache p $ + gets (p `M.lookup`) >>= \case + Nothing -> pure True + Just True -> pure True + Just False -> True <$ goIfPossible p (clearSide dx) (V2 dx 0) + goIfPossible p f d + | z `S.member` cl = pure False + | otherwise = f z + where + z = p + d + cache p act = + gets (p `M.lookup`) >>= \case + Just t -> pure t + Nothing -> overrideCache p act + overrideCache p act = do + res <- act + res <$ modify (M.insert p res) + +fillWater :: NESet Point -> Set Point +fillWater cl = + S.filter (\p -> p ^. _y >= yMin && p ^. _y <= yMax) + . M.keysSet + $ drainMap (NES.toSet cl) yMax (V2 500 0) + where + V2 _ yMin `V2` V2 _ yMax = boundingBox $ toNonEmpty cl + +day17a :: NESet Point :~> Int +day17a = + MkSol + { sParse = NES.nonEmptySet . foldMap parseVein . lines + , sShow = show + , sSolve = Just . S.size . fillWater + } + +drainWater :: NESet Point -> Set Point +drainWater cl = + S.filter (\p -> p ^. _y >= yMin && p ^. _y <= yMax) + . M.keysSet + . M.filter not + $ drainMap (NES.toSet cl) yMax (V2 500 0) + where + V2 _ yMin `V2` V2 _ yMax = boundingBox $ toNonEmpty cl + +day17b :: NESet Point :~> Int +day17b = + MkSol + { sParse = NES.nonEmptySet . foldMap parseVein . lines + , sShow = show + , sSolve = Just . S.size . drainWater + } + +parseVein :: String -> Set Point +parseVein ('x' : (map read . words . clearOut (not . isDigit) -> (x : y0 : y1 : _))) = + S.fromList . map (V2 x) $ range (y0, y1) +parseVein ('y' : (map read . words . clearOut (not . isDigit) -> (y : x0 : x1 : _))) = + S.fromList . map (`V2` y) $ range (x0, x1) +parseVein _ = S.empty + +_displayClay :: Set Point -> Set Point -> String +_displayClay cl w = displayAsciiMap '.' terrain + where + terrain = + M.fromSet (const '#') cl + <> M.fromSet (const '*') w diff --git a/2018/AOC2018/Day18.hs b/2018/AOC2018/Day18.hs new file mode 100644 index 0000000..5220afd --- /dev/null +++ b/2018/AOC2018/Day18.hs @@ -0,0 +1,107 @@ +-- | +-- Module : AOC2018.Day18 +-- Copyright : (c) Justin Le 2018 +-- License : BSD3 +-- +-- Maintainer : justin@jle.im +-- Stability : experimental +-- Portability : non-portable +-- +-- Day 18. See "AOC.Solver" for the types used in this module! +module AOC2018.Day18 ( + day18a, + day18b, +) where + +import AOC.Common ((!!!)) +import AOC.Common.Point (Point, fullNeighbs, parseAsciiMap) +import AOC.Solver ((:~>) (..)) +import Control.Lens (folded, lengthOf, only) +import Control.Monad (mfilter) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (mapMaybe) + +data Terrain + = TOpen + | TTree + | TYard + deriving stock (Show, Eq, Ord) + +type World = Map Point Terrain + +stepMap :: World -> World +stepMap mp = M.mapWithKey go mp + where + go :: Point -> Terrain -> Terrain + go p = \case + TOpen + | neighbCount TTree >= 3 -> TTree + | otherwise -> TOpen + TTree + | neighbCount TYard >= 3 -> TYard + | otherwise -> TTree + TYard + | neighbCount TYard >= 1 + && neighbCount TTree >= 1 -> + TYard + | otherwise -> TOpen + where + neighbCount t = + length + . mapMaybe (mfilter (== t) . (`M.lookup` mp)) + . fullNeighbs + $ p + +day18a :: World :~> Int +day18a = + MkSol + { sParse = Just . parseForest + , sShow = show + , sSolve = \m0 -> + Just $ + let mp = iterate stepMap m0 !!! 10 + in lengthOf (folded . only TTree) mp + * lengthOf (folded . only TYard) mp + } + +findLoop :: + World -> + -- | time to loop, loop size + (Int, Int) +findLoop w0 = go 1 (M.singleton w0 0) w0 + where + go !i !seen !w = case M.lookup w' seen of + Nothing -> go (i + 1) (M.insert w' i seen) w' + Just ttl -> (ttl, i - ttl) + where + w' = stepMap w + +stepN :: + Int -> + World -> + World +stepN n m0 = goN extra . goN ttl $ m0 + where + goN i = (!!! i) . iterate stepMap + (ttl, loopSize) = findLoop m0 + extra = (n - ttl) `mod` loopSize + +day18b :: World :~> Int +day18b = + MkSol + { sParse = Just . parseForest + , sShow = show + , sSolve = \m0 -> + Just $ + let mp = stepN 1000000000 m0 + in lengthOf (folded . only TTree) mp + * lengthOf (folded . only TYard) mp + } + +parseForest :: String -> World +parseForest = parseAsciiMap $ \case + '.' -> Just TOpen + '|' -> Just TTree + '#' -> Just TYard + _ -> Nothing diff --git a/2018/AOC2018/Day19.hs b/2018/AOC2018/Day19.hs new file mode 100644 index 0000000..f1fda7a --- /dev/null +++ b/2018/AOC2018/Day19.hs @@ -0,0 +1,81 @@ +-- | +-- Module : AOC2018.Day19 +-- Copyright : (c) Justin Le 2018 +-- License : BSD3 +-- +-- Maintainer : justin@jle.im +-- Stability : experimental +-- Portability : non-portable +-- +-- Day 19. See "AOC.Solver" for the types used in this module! +module AOC2018.Day19 ( + day19a, + day19b, +) where + +import AOC.Solver ((:~>) (..)) +import AOC2018.Common.Elfcode +import Control.Lens (set) +import Control.Monad (mfilter) +import Data.Finite (Finite) +import qualified Data.Vector.Unboxed.Sized as V + +day19a :: (Finite 6, ECProg) :~> Int +day19a = + MkSol + { sParse = parseElfcode + , sShow = show + , sSolve = \(i, p) -> + Just + . V.head + . execECProg i p + $ V.replicate 0 + } + +day19b :: (Finite 6, ECProg) :~> Int +day19b = + MkSol + { sParse = parseElfcode + , sShow = show + , sSolve = \(i, p) -> + Just + . V.head + . execECProg i (optimizeEC [addIfIsFactor i] p) + . set (V.ix 0) 1 + $ V.replicate 0 + } + +addIfIsFactor :: + -- | instruction register + Finite 6 -> + Peephole [Instr] +addIfIsFactor i = do + a <- currPeepPos + let a' = fromIntegral a + I OSetI _ _ n <- peep (Just 1) Nothing Nothing + let n' = fromIntegral n + I OMulR m _ z <- peep Nothing (Just n') Nothing + let z' = fromIntegral z + I OEqRR _ t _ <- peep (Just z') Nothing (Just z) + I OAddR _ _ _ <- peep (Just z') (Just i') (Just i) + I OAddI _ _ _ <- peep (Just i') (Just 1) (Just i) + I OAddR _ o _ <- + mfilter (\I{..} -> fromIntegral _iInB == _iOut) $ + peep (Just m) Nothing Nothing + I OAddI _ _ _ <- peep (Just n') (Just 1) (Just n) + I OGtRR _ _ _ <- peep (Just n') (Just t) (Just z) + I OAddR _ _ _ <- peep (Just i') (Just z') (Just i) + I OSetI _ _ _ <- peep (Just a') Nothing (Just i) + b <- currPeepPos + let t' = fromIntegral t + o' = fromIntegral o + pure . take (b - a) $ + [ I OModR t' m z -- store (t `mod` m) to z + , I OEqRI z' 0 z -- is z zero? + , I OAddR z' i' i -- if yes, jump down + , I OAddI i' 1 i -- otherwise, jump down even more + , I OAddR m o o' -- increment the thing + ] + ++ repeat (I ONoOp 0 0 0) + where + i' = fromIntegral i diff --git a/2018/AOC2018/Day20.hs b/2018/AOC2018/Day20.hs new file mode 100644 index 0000000..fffba86 --- /dev/null +++ b/2018/AOC2018/Day20.hs @@ -0,0 +1,137 @@ +-- | +-- Module : AOC2018.Day20 +-- Copyright : (c) Justin Le 2018 +-- License : BSD3 +-- +-- Maintainer : justin@jle.im +-- Stability : experimental +-- Portability : non-portable +-- +-- Day 20. See "AOC.Solver" for the types used in this module! +module AOC2018.Day20 ( + day20a, + day20b, +) where + +import AOC.Common (TokStream, parseTokStreamT_) +import AOC.Common.Point (Point, cardinalNeighbs) +import AOC.Solver ((:~>) (..)) +import Control.Monad (guard) +import Control.Monad.State (State, evalState, get, put) +import Data.Maybe (mapMaybe) +import Data.Set (Set) +import qualified Data.Set as S +import Data.Void +import Linear (V2 (..)) +import qualified Text.Megaparsec as P + +data Edge = E Point Point + deriving stock (Show, Eq, Ord) + +mkEdge :: Point -> Point -> Edge +mkEdge x y + | x <= y = E x y + | otherwise = E y x + +-- | Parse a stream of 'RegTok'. +type Parser_ = P.ParsecT Void (TokStream RegTok) (State Point) + +data Dir = DN | DE | DS | DW + deriving stock (Eq, Show, Ord, Enum, Bounded) + +data RegTok + = RTStart + | RTDir Dir + | RTRParen + | RTOr + | RTLParen + | RTEnd + deriving stock (Show, Eq, Ord) + +tok :: RegTok -> Parser_ () +tok t = P.try $ guard . (== t) =<< P.anySingle + +-- | From a stream of 'RegTok', parse a set of all edges. +buildEdges :: Parser_ (Set Edge) +buildEdges = (tok RTStart `P.between` tok RTEnd) anySteps + where + anySteps = + fmap S.unions . P.many $ + P.try basicStep P.<|> branchStep + branchStep = (tok RTRParen `P.between` tok RTLParen) $ do + initPos <- get + fmap S.unions . (`P.sepBy` tok RTOr) $ do + put initPos + anySteps + basicStep = do + currPos <- get + RTDir d <- P.anySingle + let newPos = + currPos + case d of + DN -> V2 0 (-1) + DE -> V2 1 0 + DS -> V2 0 1 + DW -> V2 (-1) 0 + put newPos + S.insert (mkEdge currPos newPos) <$> anySteps + +farthestRoom :: Set Edge -> Int +farthestRoom es = go 0 S.empty (V2 0 0) + where + go :: Int -> Set Point -> Point -> Int + go n seen p + | null allNeighbs = n + | otherwise = maximum $ go (n + 1) (S.insert p seen) <$> allNeighbs + where + allNeighbs = + filter ((`S.member` es) . mkEdge p) + . filter (`S.notMember` seen) + $ cardinalNeighbs p + +day20a :: [RegTok] :~> Int +day20a = + MkSol + { sParse = Just . parseToks + , sShow = show + , sSolve = + fmap farthestRoom + . flip evalState (V2 0 0) + . parseTokStreamT_ buildEdges + } + +roomDistances :: Set Edge -> [Int] +roomDistances es = go 0 S.empty (V2 0 0) + where + go :: Int -> Set Point -> Point -> [Int] + go n seen p = + (n :) $ + concatMap (go (n + 1) (S.insert p seen)) allNeighbs + where + allNeighbs = + filter ((`S.member` es) . mkEdge p) + . filter (`S.notMember` seen) + $ cardinalNeighbs p + +day20b :: [RegTok] :~> Int +day20b = + MkSol + { sParse = Just . parseToks + , sShow = show + , sSolve = + fmap (length . filter (>= 1000) . roomDistances) + . flip evalState (V2 0 0) + . parseTokStreamT_ buildEdges + } + +parseToks :: String -> [RegTok] +parseToks = mapMaybe $ \case + '^' -> Just RTStart + 'N' -> Just $ RTDir DN + 'E' -> Just $ RTDir DE + 'W' -> Just $ RTDir DW + 'S' -> Just $ RTDir DS + '|' -> Just RTOr + '(' -> Just RTRParen + ')' -> Just RTLParen + '$' -> Just RTEnd + _ -> Nothing diff --git a/2018/AOC2018/Day21.hs b/2018/AOC2018/Day21.hs new file mode 100644 index 0000000..998b2c1 --- /dev/null +++ b/2018/AOC2018/Day21.hs @@ -0,0 +1,118 @@ +-- | +-- Module : AOC2018.Day21 +-- Copyright : (c) Justin Le 2018 +-- License : BSD3 +-- +-- Maintainer : justin@jle.im +-- Stability : experimental +-- Portability : non-portable +-- +-- Day 21. See "AOC.Solver" for the types used in this module! +module AOC2018.Day21 ( + day21a, + day21b, +) where + +import AOC.Solver ((:~>) (..)) +import AOC2018.Common.Elfcode ( + ECProg, + IMem, + Instr (..), + OpCode (..), + Peephole, + currPeepPos, + optimizeEC, + parseElfcode, + peep, + traceECProg_, + ) +import Data.Finite (Finite) +import Data.Maybe (listToMaybe, mapMaybe) +import qualified Data.Set as S +import qualified Data.Vector as UV +import qualified Data.Vector.Unboxed.Sized as V + +-- | All the times where the program checks if something is equal to the +-- value in register zero +zeroChecks :: + Finite 6 -> + ECProg -> + [IMem] -> + [Int] +zeroChecks iPtr prog = mapMaybe checksZero + where + checksZero v = + prog UV.!? (v `V.index` iPtr) >>= \case + I OEqIR x 0 _ -> Just x + I OEqRI 0 x _ -> Just x + I OEqRR 0 r _ -> Just $ v `V.index` fromIntegral r + I OEqRR r 0 _ -> Just $ v `V.index` fromIntegral r + _ -> Nothing + +day21a :: (Finite 6, ECProg) :~> Int +day21a = + MkSol + { sParse = parseElfcode + , sShow = show + , sSolve = \(i, optimizeEC [division i] -> p) -> + listToMaybe + . zeroChecks i p + . traceECProg_ i p + $ V.replicate 0 + } + +day21b :: (Finite 6, ECProg) :~> Int +day21b = + MkSol + { sParse = parseElfcode + , sShow = show + , sSolve = \(i, optimizeEC [division i] -> p) -> + listToMaybe + . reverse + . uniqRun + . zeroChecks i p + . traceECProg_ i p + $ V.replicate 0 + } + +uniqRun :: [Int] -> [Int] +uniqRun = go S.empty + where + go _ [] = [] + go seen (x : xs) + | x `S.member` seen = [] + | otherwise = x : go (S.insert x seen) xs + +-- | Peephole optimize a division +division :: + -- | instruction register + Finite 6 -> + Peephole [Instr] +division i = do + a <- currPeepPos + I OSetI _ _ z1 <- peep (Just 0) Nothing Nothing + let z1' = fromIntegral z1 + I OAddI _ _ z2 <- peep (Just z1') (Just 1) Nothing + let z2' = fromIntegral z2 + n <- + peep (Just z2') Nothing (Just z2) >>= \case + I OMulR _ n _ -> pure $ Left n + I OMulI _ n _ -> pure $ Right n + _ -> fail "No match" + I OGtRR _ m _ <- peep (Just z2') Nothing (Just z2) + I OAddR _ _ _ <- peep (Just z2') (Just i') (Just i) + I OAddI _ _ _ <- peep (Just i') (Just 1) (Just i) + I OSetI q _ _ <- peep Nothing Nothing (Just i) + I OAddI _ _ _ <- peep (Just z1') (Just 1) (Just z1) + I OSetI _ _ _ <- peep (Just a) Nothing (Just i) + I OSetR _ _ o <- peep (Just z1') Nothing Nothing + c <- currPeepPos + pure . take (c - a) $ + [ case n of + Left r -> I ODivR m r o + Right x -> I ODivI m x o + , I OSetI q 0 i + ] + ++ repeat (I ONoOp 0 0 0) + where + i' = fromIntegral i diff --git a/2018/AOC2018/Day22.hs b/2018/AOC2018/Day22.hs new file mode 100644 index 0000000..9953cfa --- /dev/null +++ b/2018/AOC2018/Day22.hs @@ -0,0 +1,126 @@ +-- | +-- Module : AOC2018.Day22 +-- Copyright : (c) Justin Le 2018 +-- License : BSD3 +-- +-- Maintainer : justin@jle.im +-- Stability : experimental +-- Portability : non-portable +module AOC2018.Day22 ( + day22a, + day22b, +) where + +import AOC.Common (clearOut) +import AOC.Common.Point (Point, cardinalNeighbs, mannDist) +import AOC.Common.Search (aStar) +import AOC.Solver ((:~>) (..)) +import Data.Char (isDigit) +import Data.Finite (Finite, modulo) +import Data.Hashable (Hashable) +import Data.Ix (range) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (isJust) +import qualified Data.Set as S +import GHC.Generics (Generic) +import Linear (V2 (..)) + +data Terrain + = TRocky + | TWet + | TNarrow + deriving stock (Eq, Ord, Show, Enum) + +erosionLevels :: Int -> Point -> Point -> Map Point (Finite 20183) +erosionLevels d lim targ = eLevs + where + geoIxes = (`M.fromSet` S.fromList (range (V2 0 0, lim))) $ \p@(V2 x y) -> + if + | p == targ -> 0 + | y == 0 -> x * 16807 + | x == 0 -> y * 48271 + | otherwise -> + fromIntegral (eLevs M.! V2 (x - 1) y) + * fromIntegral (eLevs M.! V2 x (y - 1)) + eLevs = modulo . fromIntegral . (+ d) <$> geoIxes + +terrainTypes :: Int -> Point -> Point -> Map Point Terrain +terrainTypes d l = fmap (toEnum . (`mod` 3) . fromIntegral) . erosionLevels d l + +day22a :: (Int, Point) :~> Int +day22a = + MkSol + { sParse = parse22 + , sShow = show + , sSolve = \(d, p) -> Just . sum . fmap fromEnum $ terrainTypes d p p + } + +data Equipment + = EGear + | ETorch + deriving stock (Eq, Ord, Show, Enum, Generic) + deriving anyclass (Hashable) + +type ClimbState = (Maybe Equipment, Point) + +compatible :: Terrain -> Maybe Equipment -> Bool +compatible TRocky = isJust +compatible TWet = (/= Just ETorch) +compatible TNarrow = (/= Just EGear) + +moves :: Map Point Terrain -> ClimbState -> [ClimbState] +moves mp (e0, p0) = filter (uncurry compat) $ es ++ ps + where + es = + [ (e1, p0) + | e1 <- [Nothing, Just EGear, Just ETorch] + , e1 /= e0 + ] + ps = (e0,) <$> cardinalNeighbs p0 + compat e = maybe False (`compatible` e) . (`M.lookup` mp) + +journey :: + Map Point Terrain -> + Point -> + Maybe [ClimbState] +journey mp targ = snd <$> aStar (climbDist t) explode o (== t) + where + explode p = M.fromSet (climbDist1 p) . S.fromList . moves mp $ p + o = (Just ETorch, V2 0 0) + t = (Just ETorch, targ) + +-- | Used as the A* heuristic: best-case-scenario time for arriving at +-- destination with correct tool. +climbDist :: ClimbState -> ClimbState -> Int +climbDist (e0, p0) (e1, p1) + | e0 == e1 = mannDist p0 p1 + | otherwise = mannDist p0 p1 + 7 + +-- | A version of 'climbDist' that works for a single move or equipment +-- swap only. +climbDist1 :: ClimbState -> ClimbState -> Int +climbDist1 (e0, _) (e1, _) + | e0 == e1 = 1 + | otherwise = 7 + +day22b :: (Int, Point) :~> Int +day22b = + MkSol + { sParse = parse22 + , sShow = show + , sSolve = \(d, p) -> + let mp = terrainTypes d (pad p) p + in pathTime <$> journey mp p + } + where + pad (V2 x y) + | x > y = V2 ((x * 5) `div` 4) (y * 2) + | otherwise = V2 (x * 2) ((y * 5) `div` 4) + pathTime = sum . map (uncurry climbDist1) . (zip <*> drop 1) + +parse22 :: String -> Maybe (Int, Point) +parse22 = go . map read . words . clearOut (not . isDigit) + where + go [d, x, y] = Just (d, V2 x y) + go _ = Nothing diff --git a/2018/AOC2018/Day23.hs b/2018/AOC2018/Day23.hs new file mode 100644 index 0000000..17182ed --- /dev/null +++ b/2018/AOC2018/Day23.hs @@ -0,0 +1,144 @@ +-- | +-- Module : AOC2018.Day23 +-- Copyright : (c) Justin Le 2018 +-- License : BSD3 +-- +-- Maintainer : justin@jle.im +-- Stability : experimental +-- Portability : non-portable +-- +-- Day 23. See "AOC.Solver" for the types used in this module! +module AOC2018.Day23 ( + day23a, + day23b, +) where + +import AOC.Common (clearOut) +import AOC.Common.Point (boundingBox, mannDist) +import AOC.Solver ((:~>) (..)) +import Data.Char (isDigit) +import Data.Foldable (foldl', maximumBy, toList) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NE +import Data.Ord (Down (..), comparing) +import Data.OrdPSQ (OrdPSQ) +import qualified Data.OrdPSQ as PSQ +import Data.Semigroup.Foldable (foldMap1) +import Linear (V2 (..), V3 (..)) +import qualified Linear as L +import Witherable (mapMaybe) + +type Point3 = V3 Int +type BoundingBox = V2 Point3 +data Sphere = S + { _sCenter :: !Point3 + , _sRadius :: !Int + } + deriving stock (Show, Eq, Ord) + +day23a :: _ :~> _ +day23a = + MkSol + { sParse = Just . parse23 + , sShow = show + , sSolve = \ps -> + Just + . (`go` map _sCenter ps) + . maximumBy (comparing _sRadius) + $ ps + } + where + go c = length . filter (`inRangeOf` c) + +touchesRegion :: + Sphere -> + BoundingBox -> + Bool +touchesRegion c bb = + any (`inRangeOf` c) (boundingCube bb) + || any (`inRegion` bb) (circleBounds c) + +inRangeOf :: + Point3 -> + Sphere -> + Bool +p `inRangeOf` S c r = mannDist c p <= r + +inRegion :: Point3 -> BoundingBox -> Bool +inRegion p (V2 mn mx) = + all (>= 0) (p - mn) + && all (>= 0) (mx - p) + +splitOctants :: + [Sphere] -> + BoundingBox -> + [(BoundingBox, [Sphere])] +splitOctants ss bb0 = + [ (oct, touching) + | oct <- octants bb0 + , let touching = filter (`touchesRegion` oct) ss + ] + +-- "drilling down" can only make number of drones smaller (or the same), +-- not larger. + +drillDown :: + NonEmpty Sphere -> + Point3 +drillDown ss0 = go (addIn bb0 ss0 PSQ.empty) + where + go :: OrdPSQ BoundingBox (Down Int) (NonEmpty Sphere) -> Point3 + go q0 = case PSQ.minView q0 of + Nothing -> error "ran out of points? this shouldn't happen." + Just (bb@(V2 mn mx), _, ss, q1) + | mn == mx -> mn + | otherwise -> go $ foldl' (flip processNew) q1 (splitOctants (toList ss) bb) + processNew (bb, ss) = case NE.nonEmpty ss of + Nothing -> id + Just ss' -> addIn bb ss' + addIn bb ss = PSQ.insert bb (Down (length ss)) ss + bb0 = boundingBox . foldMap1 (NE.fromList . circleBounds) $ ss0 + +octants :: BoundingBox -> [BoundingBox] +octants (V2 mns mxs) + | mns == mxs = [] + | otherwise = + filter (\(V2 mn mx) -> all (>= 0) (mx - mn)) $ + zipWith + V2 + (boundingCube (V2 mns (mid + 1))) + (boundingCube (V2 mid mxs)) + where + mid = (\x y -> (x + y) `div` 2) <$> mns <*> mxs + +boundingCube :: + BoundingBox -> + [Point3] +boundingCube = traverse (\(V2 mn mx) -> [mn, mx]) . L.transpose + +day23b :: _ :~> _ +day23b = + MkSol + { sParse = Just . parse23 + , sShow = show + , sSolve = fmap (mannDist 0 . drillDown) . NE.nonEmpty + } + +circleBounds :: Sphere -> [Point3] +circleBounds (S c r) = + [ c + d + | b <- + [ V3 r 0 0 + , V3 0 r 0 + , V3 0 0 r + ] + , d <- [b, -b] + ] + +parse23 :: String -> [Sphere] +parse23 = mapMaybe (go . map read . words . clearOut d) . lines + where + d '-' = False + d c = not (isDigit c) + go [x, y, z, r] = Just $ S (V3 x y z) r + go _ = Nothing diff --git a/2018/AOC2018/Day24.hs b/2018/AOC2018/Day24.hs new file mode 100644 index 0000000..f338cd2 --- /dev/null +++ b/2018/AOC2018/Day24.hs @@ -0,0 +1,213 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TransformListComp #-} + +-- | +-- Module : AOC2018.Day24 +-- Copyright : (c) Justin Le 2018 +-- License : BSD3 +-- +-- Maintainer : justin@jle.im +-- Stability : experimental +-- Portability : non-portable +-- +-- Day 24. See "AOC.Solver" for the types used in this module! +module AOC2018.Day24 ( + day24a, + day24b, +) where + +import AOC.Common () +import AOC.Common.Search (exponentialFindMin) +import AOC.Solver ((:~>) (..)) +import AOC.Util (eitherToMaybe) +import Control.Lens (at, ix, non, uses, (.=), (.~)) +import Control.Monad.State (evalState) +import Data.Char (isDigit, isLetter) +import Data.Foldable (fold) +import Data.Function ((&)) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (listToMaybe) +import Data.Ord (Down (..)) +import Data.OrdPSQ (OrdPSQ) +import qualified Data.OrdPSQ as PSQ +import qualified Data.Set as S +import Data.Traversable (forM) +import Data.Void (Void) +import GHC.Exts (sortWith) +import qualified Text.Megaparsec as P +import qualified Text.Megaparsec.Char as P +import Text.Megaparsec.Char.Lexer (decimal) +import Witherable (forMaybe) + +data Resist = RImmune | RWeak + deriving stock (Show, Eq, Ord) + +type Resistance = Map String Resist + +data Team = TImm | TInf + deriving stock (Show, Eq, Ord) + +data Grp = G + { _gHP :: Int + , _gResist :: Resistance + , _gAtk :: Int + , _gAtkType :: String + , _gInitiative :: Down Int + , _gTeam :: Team + } + deriving stock (Show, Eq, Ord) + +type Arena = Map Grp Int + +effPower :: Grp -> Int -> Int +effPower g n = _gAtk g * n + +stab :: Grp -> Grp -> Int +stab g1 g2 = case M.lookup (_gAtkType g1) (_gResist g2) of + Nothing -> 1 + Just RImmune -> 0 + Just RWeak -> 2 + +selectTargets :: + Arena -> + -- | targets + Map Grp Grp +selectTargets a = M.fromList . flip evalState candidates . forMaybe queue $ \g -> do + targ <- uses (at (_gTeam g) . non M.empty) $ \cands -> + listToMaybe + [ h + | (h, n) <- M.toList cands + , let dmg = stab g h + , dmg > 0 + , then + sortWith + by + (Down dmg, Down (effPower h n), _gInitiative h) + ] + forM targ $ \t -> do + ix (_gTeam g) . at t .= Nothing + pure (g, t) + where + queue :: [Grp] + queue = + [ g + | (g, n) <- M.toList a + , then + sortWith + by + (Down (effPower g n), _gInitiative g) + ] + candidates :: Map Team Arena + candidates = flip M.fromSet (S.fromDistinctAscList [TImm, TInf]) $ \t -> + M.filterWithKey (\g _ -> _gTeam g /= t) a + +makeAttacks :: + Map Grp Grp -> + Arena -> + Arena +makeAttacks targs a = go queue0 M.empty + where + go :: + OrdPSQ Grp (Down Int) Int -> + Map Grp Int -> + Arena + go queue finished = case PSQ.minView queue of + Nothing -> finished + Just (g, _, n, queue') -> case M.lookup g targs of + Nothing -> go queue' (M.insert g n finished) + Just targ -> case PSQ.lookup targ queue' of + Nothing -> case M.lookup targ finished of + Nothing -> go queue' (M.insert g n finished) + Just m -> + let totDamg = stab g targ * n * _gAtk g + newM = m - (totDamg `div` _gHP targ) + finished' + | newM > 0 = finished & ix targ .~ newM + | otherwise = M.delete targ finished + in go queue' (M.insert g n finished') + Just (_, m) -> + let totDamg = stab g targ * n * _gAtk g + newM = m - (totDamg `div` _gHP targ) + queue'' + | newM > 0 = queue' & ix targ .~ newM + | otherwise = PSQ.delete targ queue' + in go queue'' (M.insert g n finished) + queue0 :: OrdPSQ Grp (Down Int) Int + queue0 = + PSQ.fromList + [ (g, _gInitiative g, n) + | (g, n) <- M.toList a + ] + +fightBattle :: Arena -> Either Arena (Team, Map Grp Int) +fightBattle a + | a' == a = Left a + | all (== TImm) teams = Right (TImm, a') + | all (== TInf) teams = Right (TInf, a') + | otherwise = fightBattle a' + where + a' = makeAttacks (selectTargets a) a + teams = _gTeam <$> M.keys a' + +day24a :: Arena :~> Int +day24a = + MkSol + { sParse = P.parseMaybe parse24 + , sShow = show + , sSolve = fmap (sum . snd) . eitherToMaybe . fightBattle + } + +day24b :: Arena :~> Int +day24b = + MkSol + { sParse = P.parseMaybe parse24 + , sShow = show + , sSolve = \a -> + let goodEnough i = case fightBattle (boost i a) of + Right (TImm, b) -> Just (sum b) + _ -> Nothing + in exponentialFindMin goodEnough 1 -- note: this might fail for some inputs + } + where + boost :: Int -> Arena -> Arena + boost i = M.mapKeys $ \g -> case _gTeam g of + TImm -> g{_gAtk = _gAtk g + i} + TInf -> g + +type Parser_ = P.Parsec Void String + +parse24 :: Parser_ Arena +parse24 = + M.union + <$> ("Immune System:" *> P.space *> teamParser TImm <* P.space) + <*> ("Infection:" *> P.space *> teamParser TInf) + +teamParser :: Team -> Parser_ Arena +teamParser t = M.fromList <$> (P.try (groupParser t) `P.sepEndBy1` P.newline) + +groupParser :: Team -> Parser_ (Grp, Int) +groupParser _gTeam = do + n <- decimal + P.skipMany (P.satisfy (not . isDigit)) + _gHP <- decimal <* P.space + "hit points" <* P.space + _gResist <- fmap fold . P.optional . P.try $ (P.char '(' `P.between` P.char ')') resistanceParser + P.skipMany (P.satisfy (not . isDigit)) + _gAtk <- decimal <* P.space + _gAtkType <- P.some (P.satisfy isLetter) + P.skipMany (P.satisfy (not . isDigit)) + _gInitiative <- Down <$> decimal + pure (G{..}, n) + +resistanceParser :: Parser_ Resistance +resistanceParser = M.unions <$> (resistSpec `P.sepBy1` (P.char ';' *> P.space)) + where + res = + (RImmune <$ P.try "immune") + P.<|> (RWeak <$ P.try "weak") + resistSpec = do + r <- res <* P.space + "to" <* P.space + ts <- P.some (P.satisfy isLetter) `P.sepBy1` (P.char ',' *> P.space) + pure . M.fromList $ (,r) <$> ts diff --git a/2018/AOC2018/Day25.hs b/2018/AOC2018/Day25.hs new file mode 100644 index 0000000..4df8fe2 --- /dev/null +++ b/2018/AOC2018/Day25.hs @@ -0,0 +1,44 @@ +-- | +-- Module : AOC2018.Day25 +-- Copyright : (c) Justin Le 2018 +-- License : BSD3 +-- +-- Maintainer : justin@jle.im +-- Stability : experimental +-- Portability : non-portable +-- +-- Day 25. See "AOC.Solver" for the types used in this module! +module AOC2018.Day25 ( + day25a, +) where + +import AOC.Common (clearOut) +import AOC.Common.Point (mannDist) +import AOC.Solver ((:~>) (..)) +import Data.Char (isDigit) +import Data.Graph (Graph) +import qualified Data.Graph as G +import Linear (V4 (..)) +import Witherable (mapMaybe) + +constellationGraph :: [V4 Int] -> Graph +constellationGraph xs = g + where + (g, _, _) = G.graphFromEdges (map collect xs) + collect x = ((), x, filter ((<= 3) . mannDist x) xs) + +day25a :: [V4 Int] :~> Int +day25a = + MkSol + { sParse = Just . parse25 + , sShow = show + , sSolve = Just . length . G.scc . constellationGraph + } + +parse25 :: String -> [V4 Int] +parse25 = mapMaybe (go . map read . words . clearOut d) . lines + where + d '-' = False + d c = not (isDigit c) + go [x, y, z, r] = Just $ V4 x y z r + go _ = Nothing diff --git a/advent-of-code.cabal b/advent-of-code.cabal index 43e4b4a..e63b884 100644 --- a/advent-of-code.cabal +++ b/advent-of-code.cabal @@ -199,6 +199,7 @@ common solver-deps , containers , data-default , data-default-class + , data-fix , data-interval , data-memocombinators , deepseq @@ -210,6 +211,7 @@ common solver-deps , finitary , finite-typelits , foldl + , free-algebras , generic-lens , ghc-typelits-natnormalise , graphviz @@ -227,6 +229,7 @@ common solver-deps , nonempty-containers , one-liner-instances , parallel + , parsec , parser-combinators , pointedlist , primitive @@ -238,6 +241,7 @@ common solver-deps , semialign , semigroupoids , split + , statistics , strict-tuple , text , these @@ -255,6 +259,75 @@ common executable-options import: common-options ghc-options: -threaded -rtsopts -with-rtsopts=-N -O2 +-- 2018 + +library aoc2018-lib + import: common-options + import: solver-extensions + import: solver-deps + exposed-modules: + AOC2018 + AOC2018.Common.Elfcode + AOC2018.Day01 + AOC2018.Day02 + AOC2018.Day03 + AOC2018.Day04 + AOC2018.Day05 + AOC2018.Day06 + AOC2018.Day07 + AOC2018.Day08 + AOC2018.Day09 + AOC2018.Day10 + AOC2018.Day11 + AOC2018.Day12 + AOC2018.Day13 + AOC2018.Day14 + AOC2018.Day15 + AOC2018.Day16 + AOC2018.Day17 + AOC2018.Day18 + AOC2018.Day19 + AOC2018.Day20 + AOC2018.Day21 + AOC2018.Day22 + AOC2018.Day23 + AOC2018.Day24 + AOC2018.Day25 + + hs-source-dirs: 2018 + +executable aoc2018 + import: executable-options + main-is: aoc2018.hs + hs-source-dirs: app + build-depends: + , ansi-terminal + , aoc-core + , aoc2018-lib + , base >=4.7 && <5 + +test-suite aoc2018-test + import: executable-options + type: exitcode-stdio-1.0 + main-is: aoc2018-test.hs + hs-source-dirs: test + build-depends: + , ansi-terminal + , aoc-core + , aoc2018-lib + , base >=4.7 && <5 + +benchmark aoc2018-bench + import: executable-options + type: exitcode-stdio-1.0 + main-is: aoc2018-bench.hs + hs-source-dirs: bench + build-depends: + , ansi-terminal + , aoc-core + , aoc2018-lib + , base >=4.7 && <5 + -- 2019 library aoc2019-lib diff --git a/app/aoc2018.hs b/app/aoc2018.hs new file mode 100644 index 0000000..67ad421 --- /dev/null +++ b/app/aoc2018.hs @@ -0,0 +1,5 @@ +import AOC.Main.Runner +import AOC2018 + +main :: IO () +main = mainFor challengeBundle2018 diff --git a/bench/aoc2018-bench.hs b/bench/aoc2018-bench.hs new file mode 100644 index 0000000..29f0631 --- /dev/null +++ b/bench/aoc2018-bench.hs @@ -0,0 +1,5 @@ +import AOC.Main.Bench +import AOC2018 + +main :: IO () +main = benchFor challengeBundle2018 diff --git a/test/aoc2018-test.hs b/test/aoc2018-test.hs new file mode 100644 index 0000000..59d2825 --- /dev/null +++ b/test/aoc2018-test.hs @@ -0,0 +1,5 @@ +import AOC.Main.Spec +import AOC2018 + +main :: IO () +main = specFor challengeBundle2018