day 17 inputs

2022/day16.hs

@@ -5,8 +5,9 @@ import Debug.Trace (traceShowId, traceShow, trace)
 import Data.Maybe (fromMaybe)
 
 import Bfs
-import Data.List (maximumBy, permutations, delete)
+import Data.List (maximumBy, permutations, delete, singleton)
 import Data.Function (on)
+import Control.Monad.Trans.State (State, get, put, evalState)
 
 data Valve = V { flow' :: Int, neighs' :: [String] } deriving Show
 type ZMap = M.Map String Valve
@@ -63,7 +64,7 @@ perms limit m = perms' "AA" limit elems where
     perms' current remaining as = do
         a <- as
         let distance = dists (m M.! current) M.! a
-        if distance < remaining then do
+        [a] : if distance < remaining then do
             let l = delete a as
             ls <- perms' a (remaining-distance) l
             pure $ a:ls
@@ -88,14 +89,54 @@ traceMap cond f (x:y:xs)
     | cond x y = let result = f x in traceShow (result, x) (result: traceMap cond f (y:xs))
     | otherwise = f x : traceMap cond f (y:xs)
 
+type EleMemo = M.Map (S.Set String) Int
+eleLookup :: NzMap -> S.Set String -> State EleMemo Int
+eleLookup nzmap permutation = do
+    mmap <- get
+    case M.lookup permutation mmap of
+        Just x -> pure x
+        Nothing -> do
+            let valves = M.fromList $ filter (\(name, valve) -> S.notMember name permutation) (M.toList nzmap)
+            let elePerms = traceShow ("elephant", permutation) $ perms 26 valves
+            let exec p = execPerm nzmap p 0 "AA" 26
+            let flow = maximum $ map exec elePerms
+            put $ M.insert permutation flow mmap
+            pure flow
+
+part2 :: NzMap -> [String] -> State EleMemo Int
+part2 nzmap permutation = do
+    let me = execPerm nzmap permutation 0 "AA" 26
+    elephant <- eleLookup nzmap (S.fromList permutation)
+    pure $ me + elephant
+    -- case elephant of
+    --     Just ele -> pure $ me + ele
+    --     Nothing -> do
+    --         let valves = M.fromList $ filter (\(name, valve) -> S.notMember name permset) (M.toList nzmap)
+    --         let elePerms = traceShow ("elephant", permutation) $ perms 26 valves
+    --         let exec p = execPerm nzmap p 0 "AA" 26
+    --         let ele = maximum $ map exec elePerms
+    --         put $ M.insert permset ele state
+    --         pure $ me + ele
+
 main :: IO ()
 main = do
     x <- prepass . M.fromList . map parseValve . lines <$> getContents
     mapM_ print x
 
-    let all = perms 30 x
-    let exec p = execPerm x p 0 "AA" 30
-    let result = traceMap (\a b -> take 2 a /= take 2 b) exec all
-    putStr "part 1: "
-    print $ maximum result
+    -- let all = perms 30 x
+    -- let exec p = execPerm x p 0 "AA" 30
+    -- let result = traceMap (\a b -> take 2 a /= take 2 b) exec all
+    -- putStr "part 1: "
+    -- print $ maximum result
     -- print $ fst $ search x S.empty "AA" 30 M.empty
+
+    putStr "part 2: "
+    -- let initialEle = maximumBy (compare `on` fst) $ map (\p -> (execPerm x p 0 "AA" 26, [S.fromList p])) (perms 26 x)
+    -- print initialEle
+
+
+    let all = perms 26 x
+    let action = mapM (part2 x) all
+    let result = evalState action M.empty
+    print $ maximum result
+    pure ()

2022/day17.hs

@@ -0,0 +1,98 @@
+import qualified Data.Set as S
+import Debug.Trace (traceShow)
+
+type Coord = (Integer, Integer)
+type Rock = [Coord]
+
+rockFix :: Rock -> Rock
+rockFix xs = let maxy = maximum (map snd xs) in map (\(x,y) -> (x+2, y-maxy)) xs
+
+rocks :: [Rock]
+rocks = map rockFix
+  [ [(0,0), (1,0), (2,0), (3,0)]
+  , [(1,0), (0,1), (1,1), (2,1), (1,2)]
+  , [(2,0), (2,1), (0,2), (1,2), (2,2)]
+  , [(0,0), (0,1), (0,2), (0,3)]
+  , [(0,0), (0,1), (1,0), (1,1)]
+  ]
+
+simulate :: [Rock] -> Maybe Rock -> String -> S.Set Coord -> Integer -> S.Set Coord
+simulate [] _ _ _ _ = error "finite stream of rocks"
+simulate (r:rs) Nothing jets occupied 0 = occupied
+simulate (r:rs) Nothing jets occupied n = simulate rs (Just next) jets occupied (n-1) where
+    height = minimum (1 : map snd (S.toList occupied)) - 4
+    next = map (\(x,y) -> (x, y+height)) r
+simulate (r:rs) (Just rock) (j:js) occupied remaining = if valid dropped
+    then simulate (r:rs) (Just dropped) js occupied remaining
+    else simulate (r:rs) Nothing js occupied' remaining
+    where
+        pushF = case j of
+            '>' -> \(x,y) -> (x+1, y)
+            '<' -> \(x,y) -> (x-1, y)
+            _ -> error ("invalid char" ++ show j)
+        dropF (x,y) = (x, y+1)
+        valid = all (\c@(x,y) -> c `S.notMember` occupied
+                              && x >= 0 && x < 7 && y <= 0)
+        pushed = if valid (map pushF rock) then map pushF rock else rock
+        dropped = map dropF pushed
+        occupied' = foldr S.insert occupied pushed
+
+
+-- simulate2 :: [Rock] -> String -> [Rock] -> Maybe Rock -> String -> S.Set Coord -> Integer -> Integer -> Integer
+-- simulate2 origR origJ [] _ _ _ _ _ = error "finite stream of rocks"
+-- simulate2 origR origJ (r:rs) Nothing jets occupied 0 iters = undefined
+-- simulate2 origR origJ (r:rs) Nothing jets occupied n iters = if iters > 0 && matchesR && matchesJ
+--     then let h = minimum (map snd (S.toList occupied)) in
+--          let repetitions = n `div` iters in
+--          let addedHeight = h * repetitions in addedHeight + simulate2 origR origJ (r:rs) Nothing jets occupied (n `mod` iters) 0
+--     else simulate2 origR origJ rs (Just next) jets occupied (n-1) (iters+1) where
+--         height = minimum (1 : map snd (S.toList occupied)) - 4
+--         next = map (\(x,y) -> (x, y+height)) r
+--         matchesR = origR == take (length origR) (r:rs)
+--         matchesJ = origJ == take (length origJ) jets
+-- simulate2 origR origJ (r:rs) (Just rock) (j:js) occupied remaining iters = if valid dropped
+--     then simulate2 origR origJ (r:rs) (Just dropped) js occupied remaining iters
+--     else simulate2 origR origJ (r:rs) Nothing js occupied' remaining iters
+--     where
+--         pushF = case j of
+--             '>' -> \(x,y) -> (x+1, y)
+--             '<' -> \(x,y) -> (x-1, y)
+--             _ -> error ("invalid char" ++ show j)
+--         dropF (x,y) = (x, y+1)
+--         valid = all (\c@(x,y) -> c `S.notMember` occupied
+--                               && x >= 0 && x < 7 && y <= 0)
+--         pushed = if valid (map pushF rock) then map pushF rock else rock
+--         dropped = map dropF pushed
+--         occupied' = foldr S.insert occupied pushed
+
+
+main :: IO ()
+main = do
+    jets <- head . lines <$> getContents
+    let height set = -(minimum $ map snd (S.toList set)) + 1
+
+    putStr "part 1: "
+    let tower = simulate (cycle rocks) Nothing (cycle jets) S.empty 2022
+    print (height tower)
+
+    -- part 2
+    let repIters = lcm (fromIntegral $ length jets) (fromIntegral $ length rocks) :: Integer
+    putStr "repeated: " >> print repIters
+
+    let initial = simulate (cycle rocks) Nothing (cycle jets) S.empty repIters
+    let repeated = simulate (cycle rocks) Nothing (cycle jets) S.empty (2*repIters)
+
+    let diff ls = zipWith (-) (tail ls) ls
+    print $ diff $ map (\i -> height $ simulate (cycle rocks) Nothing (cycle jets) S.empty (i*repIters)) [1..20]
+
+    let initHeight = height initial
+    let repHeight = height repeated - initHeight
+    putStr "repeated structure height: " >> print (initHeight, repHeight)
+    let remIters = 1000000000000 `mod` repIters
+    let remaining = simulate (cycle rocks) Nothing (cycle jets) S.empty remIters
+    let remHeight = if remIters > 0 then -(minimum $ map snd (S.toList remaining)) + 1 else 0
+    -- let tower = simulate2 rocks jets (cycle rocks) Nothing (cycle jets) S.empty 2022 0
+
+    putStr "part 2: "
+    let repNum = 1000000000000 `div` repIters
+    print $ (repNum * repHeight) + remHeight

2022/inputs/day17.test

@@ -0,0 +1 @@
+>>><<><>><<<>><>>><<<>>><<<><<<>><>><<>>