## ~rootmos/AoC

8f92eb590f3b69c72d792ac508a250bf380de725 — Gustav Behm 1 year, 3 months ago
```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

```