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
  48
  49 -- type GameState = State Game
  50
  51
  52 main :: IO ()
  53 main =
  54   do  text <- TIO.readFile "data/advent21.txt"
  55       let game = successfulParse text
  56       print $ part1 game
  57       print $ part2 game
  58
  59 part1 game = scoreGame finalGame
  60   where finalGame = head $ dropWhile (not . finished 1000) $ scanl' gameStep game detDice
  61         detDice = map (\n -> sum ([d `mod1` 100 | d <- [n..(n+2)]]::[Int])) [1, 4..]
  62
  63 part2 game = max (Player1 `MS.occur` winners) (Player2 `MS.occur` winners)
  64   where games0 = MS.singleton game
  65         winners0 = MS.empty
  66         winners = nonDetGameSimulation 21 games0 diracDice winners0
  67
  68 finished :: Int -> Game -> Bool
  69 finished threshold game = any (>= threshold) $ map score $ M.elems (players game)
  70
  71 scoreGame :: Game -> Int
  72 scoreGame game = (rolls game) * losingScore
  73   where losingScore = minimum $ map score $ M.elems (players game)
  74
  75 diracDice :: Dice
  76 diracDice = MS.fromList [a + b + c | a <- [1..3], b <- [1..3], c <- [1..3]]
  77
  78 gameStep :: Game -> Int -> Game
  79 gameStep game theseRolls = game'
  80   where activePlayer = (players game) ! (current game)
  81         pos = position activePlayer
  82         sc = score activePlayer
  83         pos' = (pos + theseRolls) `mod1` 10
  84         sc' = sc + pos'
  85         activePlayer' = PlayerState {position = pos', score = sc'}
  86         current' = nextPlayer (current game)
  87         players' = M.insert (current game) activePlayer' (players game)
  88         game' = Game { players = players'
  89                      , current = current'
  90                      , rolls = rolls game + 3
  91                      }
  92
  93 nonDetGameSimulation :: Int -> Games -> Dice -> Winners -> Winners
  94 nonDetGameSimulation winThreshold games0 dice winners0
  95   -- | trace ((show games0) ++ "; " ++ (show winners0)) False = undefined
  96   -- | trace (show winners0) False = undefined
  97   | MS.null games0 = winners0
  98   | otherwise = nonDetGameSimulation winThreshold games dice winners
  99   where games' = nonDetGameStep games0 dice
 100         (winGames, games) = MS.partition (finished winThreshold) games'
 101         p1Wins = MS.size $ MS.filter (\g -> current g == Player2) winGames
 102         p2Wins = MS.size $ MS.filter (\g -> current g == Player1) winGames
 103         winners = MS.insertMany Player2 p2Wins $ MS.insertMany Player1 p1Wins winners0
 104
 105 nonDetGameStep :: Games -> Dice -> Games
 106 nonDetGameStep games dice = MS.foldOccur (nonDetGameStep1 dice) MS.empty games
 107 -- nonDetGameStep games dice
 108   -- | trace ("G0 >" ++ (show games) ++ "-" ++ (show dice)) False = undefined
 109   -- | otherwise = MS.foldOccur (nonDetGameStep1 games) MS.empty dice
 110
 111 nonDetGameStep1 :: Dice -> Game -> MS.Occur -> Games -> Games
 112 nonDetGameStep1 dice game gnum acc = MS.foldOccur (nonDetGameStep2 game gnum) MS.empty dice
 113 -- nonDetGameStep1 game dice dnum acc
 114   -- | trace ("G1 >" ++ (show game) ++ "-" ++ (show dice) ++ ": " ++ (show gnum)) False = undefined
 115   -- | otherwise = MS.foldOccur (nonDetGameStep2 dice dnum) acc game
 116
 117 nonDetGameStep2 :: Game -> MS.Occur -> Int -> MS.Occur -> Games -> Games
 118 nonDetGameStep2 game gnum roll dnum acc = MS.insertMany game' (gnum * dnum) acc
 119 -- nonDetGameStep2 dice dnum game gnum acc
 120   -- | trace ("G2 >" ++ (show game) ++ "-" ++ (show dice) ++ ": " ++ (show gnum) ++ "," ++ (show dnum)) False = undefined
 121   -- | otherwise = MS.insertMany game' (gnum * dnum) acc
 122   where game' = gameStep game roll
 123
 124
 125 nextPlayer :: Player -> Player
 126 nextPlayer Player1 = Player2
 127 nextPlayer Player2 = Player1
 128
 129 mod1 :: Int -> Int -> Int
 130 mod1 a b = ((a - 1) `mod` b) + 1
 131
 132
 133
 134 -- Parsing
 135
 136 playerP = ("1" *> pure Player1) <|> ("2" *> pure Player2)
 137
 138 playerStateP = playerify <$> ("Player " *> playerP) <*> (" starting position: " *> decimal)
 139   where playerify name pos = (name, PlayerState {position = pos, score = 0})
 140
 141 gameP = gamify <$> playerStateP `sepBy` endOfLine
 142   where gamify ps = Game {rolls = 0, current = Player1, players = M.fromList ps}
 143
 144
 145 -- successfulParse :: Text -> (Integer, [Maybe Integer])
 146 successfulParse input =
 147   case parseOnly gameP input of
 148     Left  _err ->  Game {rolls=0, current=Player1, players=M.empty} -- TIO.putStr $ T.pack $ parseErrorPretty err
 149     Right game -> game
 150