advent21/Main.hs

   1 -- Writeup at https://work.njae.me.uk/2021/12/23/advent-of-code-2021-day-20/
   2
   3 import Debug.Trace
   4
   5
   6 import Data.Text ()
   7 import qualified Data.Text.IO as TIO
   8 import Data.Attoparsec.Text hiding (take, takeWhile)
   9 import Control.Applicative
  10
  11 -- import Control.Monad.State.Strict
  12 -- import Control.Monad.Reader
  13 -- import Control.Monad.Writer
  14 -- import Control.Monad.RWS.Strict
  15 -- import Control.Monad.Loops
  16
  17 import qualified Data.Map.Strict as M
  18 import Data.Map.Strict ((!))
  19 import Data.List
  20 import qualified Data.MultiSet as MS
  21
  22 data Player = Player1 | Player2 deriving (Eq, Ord, Show)
  23
  24 data PlayerState = PlayerState
  25   { position :: Int
  26   , score :: Int
  27   } deriving (Eq, Ord, Show)
  28
  29 data Game = Game
  30   { players :: M.Map Player PlayerState
  31   , current :: Player
  32   , rolls :: Int
  33   } deriving (Eq, Ord)
  34
  35 type Games = MS.MultiSet Game
  36 type Dice = MS.MultiSet Int
  37 type Winners = MS.MultiSet Player
  38
  39
  40 instance Show Game where
  41
  42   show game = "{" ++ (showPlayer Player1) ++ (showActive) ++ (showPlayer Player2) ++ "}"
  43     where showPlayer p = (show $ position $ (players game) ! p) ++ "," ++ (show $ score $ (players game) ! p)
  44           showActive = if (current game) == Player1 then "<" else ">"
  45
  46
  47 main :: IO ()
  48 main =
  49   do  text <- TIO.readFile "data/advent21.txt"
  50       let game = successfulParse text
  51       print $ part1 game
  52       print $ part2 game
  53
  54 part1 game = scoreGame finalGame
  55   where finalGame = head $ dropWhile (not . finished 1000) $ scanl' gameStep game detDice
  56         detDice = map (\n -> sum ([d `mod1` 100 | d <- [n..(n+2)]]::[Int])) [1, 4..]
  57
  58 part2 game = max (Player1 `MS.occur` winners) (Player2 `MS.occur` winners)
  59   where games0 = MS.singleton game
  60         winners0 = MS.empty
  61         winners = nonDetGameSimulation 21 games0 diracDice winners0
  62
  63 finished :: Int -> Game -> Bool
  64 finished threshold game = any (>= threshold) $ map score $ M.elems (players game)
  65
  66 scoreGame :: Game -> Int
  67 scoreGame game = (rolls game) * losingScore
  68   where losingScore = minimum $ map score $ M.elems (players game)
  69
  70 diracDice :: Dice
  71 diracDice = MS.fromList [a + b + c | a <- [1..3], b <- [1..3], c <- [1..3]]
  72
  73 gameStep :: Game -> Int -> Game
  74 gameStep game theseRolls = game'
  75   where activePlayer = (players game) ! (current game)
  76         pos = position activePlayer
  77         sc = score activePlayer
  78         pos' = (pos + theseRolls) `mod1` 10
  79         sc' = sc + pos'
  80         activePlayer' = PlayerState {position = pos', score = sc'}
  81         current' = nextPlayer (current game)
  82         players' = M.insert (current game) activePlayer' (players game)
  83         game' = Game { players = players'
  84                      , current = current'
  85                      , rolls = rolls game + 3
  86                      }
  87
  88 nonDetGameSimulation :: Int -> Games -> Dice -> Winners -> Winners
  89 nonDetGameSimulation winThreshold games0 dice winners0
  90   -- | trace ((show games0) ++ "; " ++ (show winners0)) False = undefined
  91   -- | trace (show winners0) False = undefined
  92   | MS.null games0 = winners0
  93   | otherwise = nonDetGameSimulation winThreshold games dice winners
  94   where games' = nonDetGameStep games0 dice
  95         (winGames, games) = MS.partition (finished winThreshold) games'
  96         p1Wins = MS.size $ MS.filter (\g -> current g == Player2) winGames
  97         p2Wins = MS.size $ MS.filter (\g -> current g == Player1) winGames
  98         winners = MS.insertMany Player2 p2Wins $ MS.insertMany Player1 p1Wins winners0
  99
 100 nonDetGameStep :: Games -> Dice -> Games
 101 nonDetGameStep games dice = MS.foldOccur (nonDetGameStep1 dice) MS.empty games
 102 -- nonDetGameStep games dice
 103   -- | trace ("G0 >" ++ (show games) ++ "-" ++ (show dice)) False = undefined
 104   -- | otherwise = MS.foldOccur (nonDetGameStep1 games) MS.empty dice
 105
 106 nonDetGameStep1 :: Dice -> Game -> MS.Occur -> Games -> Games
 107 nonDetGameStep1 dice game gnum acc = MS.foldOccur (nonDetGameStep2 game gnum) acc dice
 108 -- nonDetGameStep1 game dice dnum acc
 109   -- | trace ("G1 >" ++ (show game) ++ "-" ++ (show dice) ++ ": " ++ (show gnum)) False = undefined
 110   -- | otherwise = MS.foldOccur (nonDetGameStep2 dice dnum) acc game
 111
 112 nonDetGameStep2 :: Game -> MS.Occur -> Int -> MS.Occur -> Games -> Games
 113 nonDetGameStep2 game gnum roll dnum acc = MS.insertMany game' (gnum * dnum) acc
 114 -- nonDetGameStep2 dice dnum game gnum acc
 115   -- | trace ("G2 >" ++ (show game) ++ "-" ++ (show dice) ++ ": " ++ (show gnum) ++ "," ++ (show dnum)) False = undefined
 116   -- | otherwise = MS.insertMany game' (gnum * dnum) acc
 117   where game' = gameStep game roll
 118
 119
 120 nextPlayer :: Player -> Player
 121 nextPlayer Player1 = Player2
 122 nextPlayer Player2 = Player1
 123
 124 mod1 :: Int -> Int -> Int
 125 mod1 a b = ((a - 1) `mod` b) + 1
 126
 127
 128
 129 -- Parsing
 130
 131 playerP = ("1" *> pure Player1) <|> ("2" *> pure Player2)
 132
 133 playerStateP = playerify <$> ("Player " *> playerP) <*> (" starting position: " *> decimal)
 134   where playerify name pos = (name, PlayerState {position = pos, score = 0})
 135
 136 gameP = gamify <$> playerStateP `sepBy` endOfLine
 137   where gamify ps = Game {rolls = 0, current = Player1, players = M.fromList ps}
 138
 139
 140 -- successfulParse :: Text -> (Integer, [Maybe Integer])
 141 successfulParse input =
 142   case parseOnly gameP input of
 143     Left  _err ->  Game {rolls=0, current=Player1, players=M.empty} -- TIO.putStr $ T.pack $ parseErrorPretty err
 144     Right game -> game
 145