advent22/src/advent22.hs

   1 -- import Debug.Trace
   2
   3 import Data.Text (Text)
   4 -- import qualified Data.Text as T
   5 import qualified Data.Text.IO as TIO
   6
   7 import Data.Attoparsec.Text hiding (take)
   8 -- import Data.Attoparsec.Combinator
   9 import Control.Applicative
  10 -- import Control.Applicative.Combinators
  11
  12 import qualified Data.Set as S
  13 import qualified Data.IntMap.Strict as M
  14 import qualified Data.Sequence as Q
  15 import Data.Sequence (Seq (Empty, (:<|), (:|>)), (<|), (|>))
  16
  17 import Data.Foldable (toList)
  18 import Data.Hashable (hash)
  19
  20
  21 type Deck = Q.Seq Int
  22 type Game = (Deck, Deck)
  23
  24 data Player = P1 | P2 deriving (Show, Eq)
  25
  26 type Cache = M.IntMap (S.Set Game)
  27
  28
  29 main :: IO ()
  30 main =
  31   do  text <- TIO.readFile "data/advent22.txt"
  32       let decks = successfulParse text
  33       -- print decks
  34       -- print $ play decks
  35       print $ part1 decks
  36       print $ part2 decks
  37
  38 part1 decks = score $ winningDeck $ play decks
  39 part2 decks = score $ snd $ playRecursive decks M.empty
  40
  41 play = until finished playRound
  42
  43 finished :: Game -> Bool
  44 finished (Empty, _)     = True
  45 finished (_,     Empty) = True
  46 finished (_,     _)     = False
  47
  48 playRound :: Game -> Game
  49 playRound ((x :<| xs), (y :<| ys))
  50   | x < y     = (xs,           ys |> y |> x)
  51   | otherwise = (xs |> x |> y, ys)
  52
  53 winningDeck (Empty, ys) = ys
  54 winningDeck (xs,    _)  = xs
  55
  56
  57 score :: Deck -> Int
  58 score = Q.foldrWithIndex (\i c s -> s + (i + 1) * c) 0 . Q.reverse
  59
  60
  61 playRecursive :: Game -> Cache -> (Player, Deck)
  62 playRecursive (Empty, ys) _ = (P2, ys)
  63 playRecursive (xs, Empty) _ = (P1, xs)
  64 playRecursive g@(x :<| xs, y :<| ys) seen
  65   | g `inCache` seen = (P1, x :<| xs)
  66   | (lengthAtLeast x xs) && (lengthAtLeast y ys) = playRecursive subG seen'
  67   | otherwise = playRecursive compareG seen'
  68   where seen' = enCache g seen
  69         (subWinner, _) = playRecursive (Q.take x xs, Q.take y ys) seen'
  70         subG = updateDecks subWinner g
  71         compareWinner = if x < y then P2 else P1
  72         compareG = updateDecks compareWinner g
  73
  74
  75 updateDecks P1 (x :<| xs, y :<| ys) = (xs |> x |> y, ys)
  76 updateDecks P2 (x :<| xs, y :<| ys) = (xs, ys |> y |> x)
  77
  78 lengthAtLeast n s = Q.length s >= n
  79
  80
  81 hashGame (xs, ys) =
  82   hash ( toList $ Q.take 2 xs
  83        , toList $ Q.take 2 ys
  84        -- , Q.length xs
  85        -- , Q.length ys
  86        )
  87
  88 inCache :: Game -> Cache -> Bool
  89 inCache game cache = case (M.lookup h cache) of
  90   Just games -> game `S.member` games
  91   Nothing -> False
  92   where h = hashGame game
  93
  94 enCache :: Game -> Cache -> Cache
  95 enCache game cache = case (M.lookup h cache) of
  96   Just games -> M.insert h (S.insert game games) cache
  97   Nothing -> M.insert h (S.singleton game) cache
  98   where h = hashGame game
  99
 100
 101 -- Parse the input file
 102
 103 decksP = (,) <$> deckP <* (many endOfLine) <*> deckP
 104
 105 headerP = string "Player " *> decimal *> ":" *> endOfLine
 106
 107 deckP = Q.fromList <$> (headerP *> (decimal `sepBy` endOfLine))
 108
 109 successfulParse :: Text -> Game
 110 successfulParse input =
 111   case parseOnly decksP input of
 112     Left  _err -> (Q.empty, Q.empty) -- TIO.putStr $ T.pack $ parseErrorPretty err
 113     Right decks -> decks