~rootmos/AoC

8f92eb590f3b69c72d792ac508a250bf380de725 — Gustav Behm 1 year, 11 months ago d4ec93b
Add solution to AoC 2022 #16b
2 files changed, 91 insertions(+), 48 deletions(-)

M 2022/16.hs
M lib/Qulude.hs
M 2022/16.hs => 2022/16.hs +80 -48
@@ 20,14 20,10 @@ import qualified Data.Set as Set

type Name = String

indexed :: [a] -> [(Int, a)]
indexed = go 0
  where go _ [] = []
        go i (x:xs) = (i,x):go (succ i) xs

data Survey = Survey { rates :: Array Int Int
                     , distances :: Map (Int,Int) Int
                     , initiallyClosedValves :: [ Int ]
                     , initiallyClosedValves :: Set Int
                     , totalRate :: Int
                     }
  deriving (Show, Eq)



@@ 44,70 40,106 @@ parser = mk <$> many valve
          newline
          return $ (v, r, ds)

mk vs = Survey { rates, distances, initiallyClosedValves }
  where is = indexed vs
mk vs = Survey { rates, distances, initiallyClosedValves, totalRate }
  where is = enumerate vs
        n = length is
        r = (0, pred $ length is)
        names = Array.array r $ flip fmap is $ \(i, (n, _, _)) -> (i,n)
        tunnels = Array.array r $ flip fmap is $ \(i, (_, _, ds)) -> (i, g 0 <$> ds)
        rates = Array.array r $ flip fmap is $ \(i, (_, r, ds)) -> (i,r)
        initiallyClosedValves = Maybe.mapMaybe (\(i, (_, r, _)) -> if r > 0 then Just i else Nothing) is
        initiallyClosedValves = Set.fromList $ Maybe.mapMaybe (\(i, (_, r, _)) -> if r > 0 then Just i else Nothing) is
        totalRate = Set.foldl (\r i -> r + rates ! i) 0 initiallyClosedValves
        g i d | d == names ! i = i
        g i d | otherwise = g (succ i) d
        distances = Map.fromList [ ((i, j), d i j) | i <- 0:initiallyClosedValves, j <- initiallyClosedValves, i /= j ]
        distances = Map.fromList [ ((i, j), d i j) | i <- 0:(Set.toList initiallyClosedValves), j <- (Set.toList initiallyClosedValves), i /= j ]
        ns = Set.fromList $ Array.range r
        d i j = dijkstra i j ns (\k -> fmap (flip (,) 1) (tunnels ! k))

data Action = Noop | Move Int | Open
data Action = Move Int Int | Open Int
  deriving ( Show, Eq )

data St = St { loc :: Int
data St = St { action :: [ Action ]
             , pressure :: Int
             , openValves :: [ Int ]
             , closedValves :: [ Int ]
             , rate :: Int
             , closedValves :: Set Int
             , time :: Int
             }
  deriving ( Show, Eq )

initSt s = St { loc = 0
              , pressure = 0
              , openValves = []
              , closedValves = initiallyClosedValves s
              , time = 0
              }

releasePressure s@(Survey { rates }) (St { openValves }) t = sum $ fmap (\i -> t * rates ! i) openValves

move s i st = st { time = time st + d
                 , loc = i
                 , pressure = pressure st + releasePressure s st d
                 }
  where d = (Map.!) (distances s) (loc st, i)

open s i st = st { time = time st + 1
                 , pressure = pressure st + releasePressure s st 1
                 , closedValves = List.delete i $ closedValves st
                 , openValves = i:openValves st
                 }

next s st@(St { loc, pressure, time, closedValves }) = Maybe.mapMaybe f closedValves
  where f i = let d = (Map.!) (distances s) (loc, i) in
              if 30 - time > d + 1 then Just (open s i $ move s i st) else Nothing

partA s = go 0 [ initSt s ]
initSt n s = St { action = take n $ repeat $ Move 0 0
                , pressure = 0
                , rate = 0
                , closedValves = initiallyClosedValves s
                , time = 0
                }

releasePressure s st = st { pressure = pressure st + rate st }

runOutTheClock n s st = st { time = n
                           , pressure = pressure st + (n - time st) * rate st
                           }

potential n s st = pressure st + (n - time st) * (totalRate s)

takeTime st = st { time = time st + 1 }

doOpen s i st | Set.member i (closedValves st) = st { closedValves = Set.delete i (closedValves st)
                                                    , rate = rate st + (rates s ! i)
                                                    }
doOpen _ i st | otherwise = st

whatsNext :: Int -> Survey -> St -> Action -> [ Action ]
whatsNext n _ st _ | time st == n = []
whatsNext _ s st a | otherwise = case a of
                                 Move 0 l -> if Set.member l (closedValves st) then open l else walk l
                                 Move d l -> [ Move (pred d) l ]
                                 Open l -> walk l
  where walk l = f l <$> Set.toList (closedValves st)
        f l i = Move (pred $ (Map.!) (distances s) (l, i)) i
        open l = [ Open l ]

next :: Survey -> St -> St
next s st = releasePressure s . takeTime . cardinal1R foldl' (\st a -> act a st) (action st) $ st
  where act (Open loc) st = doOpen s loc st
        act (Move _ loc) st = st

partA :: Survey -> Int
partA s = go 0 [ initSt 1 s ]
  where go !m [] = m
        go !m (st:acc) = case next s st of
                           [] -> let m' = runOutTheClock st in
        go !m (st:acc) = let st' = next s st in
                         case whatsNext 30 s st' (head $ action st') of
                           [] -> let m' = pressure $ runOutTheClock 30 s st' in
                                 go (max m m') acc
                           sts -> go m (sts `combine` acc)
        runOutTheClock st@(St { pressure, time }) = pressure + releasePressure s st (30 - time)
                           as -> let sts = fmap (\a -> st' { action = a:[] }) as in
                                 go m (sts `combine` acc)

--partB :: Parse -> Parse
--partB = id
partB :: Survey -> Int
partB s = go 0 [ initSt 2 s ]
  where go !m [] = m
        go !m (st:acc) = let st' = next s st in
                         if potential 26 s st' <= m then go m acc else
                         case action st' of
                           a:[] ->
                                case whatsNext 26 s st' a of
                                  [] -> let m' = pressure $ runOutTheClock 26 s st' in
                                        go (max m m') acc
                                  as -> let sts = fmap (\a -> st' { action = a:[] }) as in
                                        go m (sts `combine` acc)
                           a:b:[] ->
                                let a:b:[] = action st' in
                                case (whatsNext 26 s st' a, whatsNext 26 s st' b) of
                                  ([], []) -> let m' = pressure $ runOutTheClock 26 s st' in
                                              go (max m m') acc
                                  (as, []) -> let sts = fmap (\a -> st' { action = a:[] }) as in
                                              go m (sts `combine` acc)
                                  ([], bs) -> let sts = fmap (\a -> st' { action = b:[] }) bs in
                                              go m (sts `combine` acc)
                                  (as, bs) -> let sts = [ st' { action = a:b:[] } | a<-as, b<-bs, a /= b ] in
                                              go m (sts `combine` acc)

main :: IO ()
main = with parser $ do
  run' "16.example" "a example" partA 1651
  run' "16.input" "a input" partA 1896
  --run "16.example" "b example" partB
  --run "16.input" "b input" partB
  run' "16.example" "b example" partB 1707
  run' "16.input" "b input" partB 2576

M lib/Qulude.hs => lib/Qulude.hs +11 -0
@@ 27,10 27,12 @@ module Qulude ( module Prelude
              , count
              , distinct
              , combine
              , enumerate

              , thrush
              , warbler
              , cardinal
              , cardinal1R

              , Parser
              , parseFile


@@ 128,6 130,11 @@ count = go 0
distinct :: Ord a => [a] -> [a]
distinct = Set.toList . Set.fromList

enumerate :: [a] -> [(Int, a)]
enumerate = go 0
  where go _ [] = []
        go i (x:xs) = (i,x):go (succ i) xs

combine :: [a] -> [a] -> [a]
combine [] bs = bs
combine (a:as) bs = a:(combine as bs)


@@ 155,6 162,10 @@ warbler f a = f a a
cardinal :: (a -> b -> c) -> b -> a -> c
cardinal = flip

-- Cardinal Once Removed: labcd.abdc
cardinal1R :: (b -> c -> d -> e) -> b -> d -> c -> e
cardinal1R a b d c = a b c d

parseFile :: Parser a -> String -> IO (Maybe a)
parseFile parser fn = doesFileExist fn >>= \case
  False -> return Nothing