src/advent09/advent09-pointlist.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
  49         -- putStrLn $ part1 schedule
  50         -- print $ part2 schedule
  51
  52 part1 players marbles = highScore $ playGame players marbles
  53
  54 playGame :: Integer -> Integer -> Game
  55 -- playGame players marbles = scanl makeMove createGame $ zip (cycle [1..players]) [1..marbles]
  56 playGame players marbles = foldl' makeMove createGame $ zip (cycle [1..players]) [1..marbles]
  57
  58 highScore :: Game -> Integer
  59 highScore (Game _ score) = maximum $ M.elems score
  60
  61 createGame :: Game
  62 createGame = Game (createCircle 0) M.empty
  63
  64 createCircle :: Integer -> Circle
  65 createCircle current = Circle Q.empty current Q.empty
  66
  67 currentMarble :: Circle -> Integer
  68 currentMarble (Circle _ m _) = m
  69
  70 stepClockwise :: Circle -> Circle
  71 stepClockwise (Circle left current right)
  72     | (Q.null left) && (Q.null right) = Circle left current right
  73     | (Q.null right) = stepClockwise (Circle Q.empty current left)
  74     | otherwise = Circle (left |> current) r rs
  75     where (r :< rs) = Q.viewl right
  76
  77 stepAntiClockwise :: Circle -> Circle
  78 stepAntiClockwise (Circle left current right)
  79     | (Q.null left) && (Q.null right) = Circle left current right
  80     | (Q.null left) = stepAntiClockwise (Circle right current Q.empty)
  81     | otherwise = Circle ls l (current <| right)
  82     where (ls :> l) = Q.viewr left
  83
  84 insertAfter :: Integer -> Circle -> Circle
  85 insertAfter new (Circle left current right) = Circle (left |> current) new right
  86
  87 removeCurrent :: Circle -> Circle
  88 removeCurrent (Circle left _ right)
  89     | Q.null right = Circle ls l Q.empty
  90     | otherwise = Circle left r rs
  91     where (l :< ls) = Q.viewl left
  92           (r :< rs) = Q.viewl right
  93
  94 makeMove :: Game -> (Integer, Integer) -> Game
  95 makeMove (Game circle score) (player, marble) =
  96     if marble `mod` 23 == 0
  97     then let circle' = (iterate stepAntiClockwise circle) !! 7
  98              score' = updateScore score player (marble + (currentMarble circle'))
  99              circle'' = removeCurrent circle'
 100          in Game circle'' score'
 101     else let circle' = insertAfter marble (stepClockwise circle)
 102          in Game circle' score
 103
 104 updateScore :: Score -> Integer -> Integer -> Score
 105 updateScore score player change = M.insert player (current + change) score
 106     where current = M.findWithDefault 0 player score
 107
 108
 109 -- Parse the input file
 110
 111 type Parser = Parsec Void Text
 112
 113 sc :: Parser ()
 114 sc = L.space (skipSome spaceChar) CA.empty CA.empty
 115
 116 lexeme  = L.lexeme sc
 117 integer = lexeme L.decimal
 118 symb = L.symbol sc
 119
 120 infixP = symb "players; last marble is worth"
 121 suffixP = symb "points"
 122
 123
 124 -- linkP = pairify <$> prefixP <*> upperChar <* infixP <*> upperChar <* suffixP
 125 --     where pairify _ a b = (a, b)
 126 gameFileP = (,) <$> integer <* infixP <*> integer <* suffixP
 127
 128 successfulParse :: Text -> (Integer, Integer)
 129 successfulParse input =
 130         case parse gameFileP "input" input of
 131                 Left  _error -> (0, 0) -- TIO.putStr $ T.pack $ parseErrorPretty err
 132                 Right game -> game