src/advent24/advent24.hs

   1 {-# LANGUAGE NegativeLiterals #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE OverloadedStrings #-}
   4 {-# LANGUAGE TypeFamilies #-}
   5
   6 import Data.Text (Text)
   7 import qualified Data.Text as T
   8 import qualified Data.Text.IO as TIO
   9
  10 import Text.Megaparsec hiding (State)
  11 import qualified Text.Megaparsec.Lexer as L
  12 import Text.Megaparsec.Text (Parser)
  13 import qualified Control.Applicative as CA
  14
  15 import qualified Data.MultiSet as B -- B for bag
  16 import qualified Data.Set as S
  17 import Data.Either
  18
  19 type Part = B.MultiSet Integer
  20 type Parts = B.MultiSet Part
  21 type Candidates = S.Set Part
  22 data Bridge = Bridge { bridgeParts :: Parts, requiring :: Integer } deriving (Eq, Show, Ord)
  23 type Bridges = S.Set Bridge
  24
  25
  26 main :: IO ()
  27 main = do
  28         text <- TIO.readFile "data/advent24.txt"
  29         let parts = successfulParse text
  30         let bridges = allBridges parts
  31         print $ part1 bridges
  32         print $ part2 bridges
  33
  34
  35 part1 = strongestBridge
  36
  37 part2 = bestBridge
  38
  39 strongestBridge :: Bridges -> Integer
  40 strongestBridge bridges = S.findMax $ S.map bridgeStrength bridges
  41
  42 bestBridge :: Bridges -> Integer
  43 bestBridge bridges = strongestBridge longBridges
  44     where longest = S.findMax $ S.map bridgeLength bridges
  45           longBridges = S.filter (\b -> bridgeLength b == longest) bridges
  46
  47
  48 emptyBridge :: Bridge
  49 emptyBridge = Bridge { bridgeParts = B.empty, requiring = 0}
  50
  51
  52 allBridges :: Parts -> Bridges
  53 allBridges parts = extendBridges parts (S.singleton emptyBridge) S.empty
  54
  55 extendBridges :: Parts -> Bridges -> Bridges -> Bridges
  56 extendBridges parts bridges completed =
  57     if S.null bridges then completed
  58                       else extendBridges parts bridges' completed'
  59     where updates = map (extendOneBridge parts) $ S.toList bridges
  60           newCompleted = lefts updates
  61           completed' = S.union completed $ S.fromList newCompleted
  62           bridges' = S.unions $ rights updates
  63
  64 extendOneBridge :: Parts -> Bridge -> Either Bridge Bridges
  65 extendOneBridge parts bridge =
  66     if S.null $ candidates parts bridge
  67     then Left bridge
  68     else Right (S.map (grow bridge) $ candidates parts bridge)
  69
  70 grow :: Bridge -> Part -> Bridge
  71 grow bridge part = bridge {bridgeParts = bp', requiring = req'}
  72     where req = requiring bridge
  73           req' = B.findMin $ B.delete req part
  74           bp' = B.insert part $ bridgeParts bridge
  75
  76 candidates :: Parts -> Bridge -> Candidates
  77 candidates parts bridge = B.toSet $ B.filter canUse parts
  78     where needed = requiring bridge
  79           canUse p = hasPort p needed && available parts p bridge
  80
  81 hasPort :: Part -> Integer -> Bool
  82 hasPort part port = port `B.member` part
  83
  84 available :: Parts -> Part -> Bridge -> Bool
  85 available parts part bridge = B.occur part parts > B.occur part (bridgeParts bridge)
  86
  87
  88 bridgeStrength :: Bridge -> Integer
  89 bridgeStrength bridge = B.fold (+) 0 $ B.map partStrength $ bridgeParts bridge
  90     where partStrength = sum . B.elems
  91
  92 bridgeLength :: Bridge -> Int
  93 bridgeLength bridge = B.size $ bridgeParts bridge
  94
  95
  96 -- really persuade Megaparsec not to include newlines in how it consume spaces.
  97 onlySpace = (char ' ') <|> (char '\t')
  98
  99 sc :: Parser ()
 100 sc = L.space (skipSome onlySpace) CA.empty CA.empty
 101
 102 lexeme = L.lexeme sc
 103 integer = lexeme L.integer
 104 symbol = L.symbol sc
 105 slash = symbol "/"
 106
 107 partsP = partP `sepBy` newline
 108 partP = B.fromList <$> integer `sepBy` slash
 109
 110 successfulParse :: Text -> Parts
 111 successfulParse input =
 112         case parse partsP "input" input of
 113                 Left  _error -> B.empty -- TIO.putStr $ T.pack $ parseErrorPretty err
 114                 Right partsList -> B.fromList partsList