src/advent09/advent09.hs

   1 {-# LANGUAGE OverloadedStrings, ViewPatterns, PatternSynonyms #-}
   2
   3 import Data.List
   4
   5 import Data.Foldable (toList)
   6
   7 import Data.Text (Text)
   8 import qualified Data.Text.IO as TIO
   9
  10 import Data.Void (Void)
  11
  12 import Text.Megaparsec
  13 import Text.Megaparsec.Char
  14 import qualified Text.Megaparsec.Char.Lexer as L
  15 import qualified Control.Applicative as CA
  16
  17 -- import Data.Map.Strict ((!))
  18 import qualified Data.Map.Strict as M
  19
  20 import qualified Data.Sequence as Q
  21 import Data.Sequence ((<|), (|>), ViewL((:<)), ViewR((:>)) )
  22
  23 -- zipper of left, current, right
  24 data Circle = Circle (Q.Seq Integer) Integer (Q.Seq Integer) deriving (Eq)
  25 type Score = M.Map Integer Integer -- player -> score
  26 data Game = Game Circle Score deriving (Show, Eq)
  27
  28 instance Show Circle where
  29     show (Circle left current right) = (showSide left) ++ " (" ++ (show current) ++ ") " ++ (showSide right)
  30         where showSide s = intercalate " " $ map show $ toList s
  31
  32 main :: IO ()
  33 main = do
  34         text <- TIO.readFile "data/advent09.txt"
  35         let (numberOfPlayers, numberOfMarbles) = successfulParse text
  36         -- let numberOfPlayers = 10
  37         -- let numberOfMarbles = 1618
  38         -- print $ take 5 $ scanl (\c n -> insertAfter n $ stepClockwise c) (createCircle 0) [1..]
  39         -- print $ playGame numberOfPlayers numberOfMarbles
  40         -- print (let p = 10 ; m = 1618 in part1 p m)
  41         -- print (let p = 13 ; m = 7999 in part1 p m)
  42         -- print (let p = 17 ; m = 1104 in part1 p m)
  43         -- print (let p = 21 ; m = 6111 in part1 p m)
  44         -- print (let p = 30 ; m = 5807 in part1 p m)
  45         print $ part1 numberOfPlayers numberOfMarbles
  46         print $ part1 numberOfPlayers (numberOfMarbles * 100)
  47
  48 part1 players marbles = highScore $ playGame players marbles
  49
  50 playGame :: Integer -> Integer -> Game
  51 -- playGame players marbles = scanl makeMove createGame $ zip (cycle [1..players]) [1..marbles]
  52 playGame players marbles = foldl' makeMove createGame $ zip (cycle [1..players]) [1..marbles]
  53
  54 highScore :: Game -> Integer
  55 highScore (Game _ score) = maximum $ M.elems score
  56
  57 createGame :: Game
  58 createGame = Game (createCircle 0) M.empty
  59
  60 createCircle :: Integer -> Circle
  61 createCircle current = Circle Q.empty current Q.empty
  62
  63 currentMarble :: Circle -> Integer
  64 currentMarble (Circle _ m _) = m
  65
  66 stepClockwise :: Circle -> Circle
  67 stepClockwise (Circle left current right)
  68     | (Q.null left) && (Q.null right) = Circle left current right
  69     | (Q.null right) = stepClockwise (Circle Q.empty current left)
  70     | otherwise = Circle (left |> current) r rs
  71     where (r :< rs) = Q.viewl right
  72
  73 stepAntiClockwise :: Circle -> Circle
  74 stepAntiClockwise (Circle left current right)
  75     | (Q.null left) && (Q.null right) = Circle left current right
  76     | (Q.null left) = stepAntiClockwise (Circle right current Q.empty)
  77     | otherwise = Circle ls l (current <| right)
  78     where (ls :> l) = Q.viewr left
  79
  80 insertAfter :: Integer -> Circle -> Circle
  81 insertAfter new (Circle left current right) = Circle (left |> current) new right
  82
  83 removeCurrent :: Circle -> Circle
  84 removeCurrent (Circle left _ right)
  85     | Q.null right = Circle ls l Q.empty
  86     | otherwise = Circle left r rs
  87     where (l :< ls) = Q.viewl left
  88           (r :< rs) = Q.viewl right
  89
  90 makeMove :: Game -> (Integer, Integer) -> Game
  91 makeMove (Game circle score) (player, marble) =
  92     if marble `mod` 23 == 0
  93     then let circle' = (iterate stepAntiClockwise circle) !! 7
  94              score' = updateScore score player (marble + (currentMarble circle'))
  95              circle'' = removeCurrent circle'
  96          in Game circle'' score'
  97     else let circle' = insertAfter marble (stepClockwise circle)
  98          in Game circle' score
  99
 100 updateScore :: Score -> Integer -> Integer -> Score
 101 updateScore score player change = M.insert player (current + change) score
 102     where current = M.findWithDefault 0 player score
 103
 104
 105 -- Parse the input file
 106
 107 type Parser = Parsec Void Text
 108
 109 sc :: Parser ()
 110 sc = L.space (skipSome spaceChar) CA.empty CA.empty
 111
 112 lexeme  = L.lexeme sc
 113 integer = lexeme L.decimal
 114 symb = L.symbol sc
 115
 116 infixP = symb "players; last marble is worth"
 117 suffixP = symb "points"
 118
 119 gameFileP = (,) <$> integer <* infixP <*> integer <* suffixP
 120
 121 successfulParse :: Text -> (Integer, Integer)
 122 successfulParse input =
 123         case parse gameFileP "input" input of
 124                 Left  _error -> (0, 0) -- TIO.putStr $ T.pack $ parseErrorPretty err
 125                 Right game -> game