X-Git-Url: https://git.njae.me.uk/?p=advent-of-code-22.git;a=blobdiff_plain;f=advent16%2FMain.hs;fp=advent16%2FMain.hs;h=30d0843b1c2239add994e76b6bc19c60605aa8f4;hp=7db601d30bafb2aeb9906e281296994366cde433;hb=4087698696ed09477c3b5073f3d4d93d85c0a632;hpb=549425defbc1482abcef0e926094f0817842a4f5 diff --git a/advent16/Main.hs b/advent16/Main.hs index 7db601d..30d0843 100644 --- a/advent16/Main.hs +++ b/advent16/Main.hs @@ -1,6 +1,6 @@ -- Writeup at https://work.njae.me.uk/2022/12/17/advent-of-code-2022-day-16/ --- import Debug.Trace +import Debug.Trace import AoC import Data.Text (Text) @@ -12,39 +12,44 @@ import qualified Data.Set as S import qualified Data.Sequence as Q import qualified Data.Map.Strict as M import Data.Map.Strict ((!)) -import Data.Sequence ((|>)) +-- import Data.Sequence ((|>), Seq((:|>)), ViewR ((:>))) +import Data.Sequence ( (|>), Seq((:|>)) ) import Data.List import Data.List.Split (chunksOf) import Data.Ord import Control.Monad.Reader import Control.Lens hiding ((<|), (|>), (:>), (:<), indices) --- pattern Empty <- (Q.viewl -> Q.EmptyL) where Empty = Q.empty --- pattern x :< xs <- (Q.viewl -> x Q.:< xs) where (:<) = (Q.<|) --- pattern xs :> x <- (Q.viewr -> xs Q.:> x) where (:>) = (Q.|>) type RoomID = String +data Tunnel = Tunnel { _tunnelTo :: RoomID, _tunnelLength :: Int} + deriving (Eq, Show, Ord) +makeLenses ''Tunnel + data Room = Room { _flowRate :: Int - , _tunnels :: [RoomID] + , _tunnels :: S.Set Tunnel } deriving (Eq, Show, Ord) makeLenses ''Room type Cave = M.Map RoomID Room -data TimedCave = TimedCave { getCave :: Cave, getTimeLimit :: Int} +data TimedCave = TimedCave { getCave :: Cave, getTimeLimit :: Int , getSortedRooms :: [RoomID]} type CaveContext = Reader TimedCave data SingleSearchState = SingleSearchState { _currentRoom :: RoomID + , _currentTime :: Int , _sOpenValves :: S.Set RoomID } deriving (Eq, Show, Ord) makeLenses ''SingleSearchState data DoubleSearchState = DoubleSearchState { _personRoom :: RoomID + , _personTime :: Int , _elephantRoom :: RoomID + , _elephantTime :: Int , _dOpenValves :: S.Set RoomID } deriving (Eq, Show, Ord) makeLenses ''DoubleSearchState @@ -59,17 +64,24 @@ makeLenses ''Agendum type Agenda s = P.MaxPQueue Int (Agendum s) -type ExploredStates s = S.Set (s, Int, Int) +-- state, total flowed so far +type ExploredStates s = S.Set (s, Int) class (Eq s, Ord s, Show s) => SearchState s where emptySearchState :: RoomID -> s currentFlow :: s -> CaveContext Int + timeOf :: s -> Int successors :: s -> CaveContext (Q.Seq s) - estimateBenefit :: s -> Int -> CaveContext Int + -- estimateBenefit :: s -> Int -> CaveContext Int + estimateBenefit :: s -> CaveContext Int instance SearchState SingleSearchState where - emptySearchState startID = SingleSearchState { _currentRoom = startID, _sOpenValves = S.empty } + emptySearchState startID = SingleSearchState + { _currentRoom = startID + , _currentTime = 0 + , _sOpenValves = S.empty + } currentFlow state = do cave <- asks getCave @@ -77,29 +89,31 @@ instance SearchState SingleSearchState where let presentRooms = cave `M.restrictKeys` valves return $ sumOf (folded . flowRate) presentRooms + timeOf state = state ^. currentTime + successors state = do isFF <- isFullFlow state + -- cave <- asks getCave + timeLimit <- asks getTimeLimit let here = state ^. currentRoom let opened = state ^. sOpenValves - succPairs <- personSuccessor here opened - let succStates = - [ SingleSearchState - { _currentRoom = r - , _sOpenValves = o - } - | (r, o) <- succPairs - ] - if isFF - then return $ Q.singleton state - else return $ Q.fromList succStates - - estimateBenefit here timeElapsed = + let now = state ^. currentTime + succs <- agentSuccessor now opened now here + let succStates = Q.fromList succs + if isFF || (Q.null succStates) + then return $ Q.singleton (state & currentTime .~ timeLimit) + else return succStates + + estimateBenefit here = do cave <- asks getCave timeLimit <- asks getTimeLimit - let timeRemaining = timeLimit - (timeElapsed + 2) + let timeRemaining = timeLimit - (timeOf here) cf <- currentFlow here - let closedValves = (cave `M.withoutKeys` (here ^. sOpenValves)) ^.. folded . flowRate - let sortedClosedValves = sortOn Down closedValves + -- let closedValves = (cave `M.withoutKeys` (here ^. sOpenValves)) ^.. folded . flowRate + -- let sortedClosedValves = sortOn Down closedValves + sortedValves <- asks getSortedRooms + let opened = here ^. sOpenValves + let sortedClosedValves = [(cave ! v) ^. flowRate | v <- sortedValves, v `S.notMember` opened] let otherValveFlows = sum $ zipWith (*) [timeRemaining, (timeRemaining - 2) .. 0] sortedClosedValves return $ (cf * timeRemaining) + otherValveFlows @@ -107,44 +121,64 @@ instance SearchState SingleSearchState where instance SearchState DoubleSearchState where emptySearchState startID = DoubleSearchState { _personRoom = startID + , _personTime = 0 , _elephantRoom = startID + , _elephantTime = 0 , _dOpenValves = S.empty } currentFlow state = do cave <- asks getCave - let valves = state ^. dOpenValves - let presentRooms = cave `M.restrictKeys` valves - return $ sumOf (folded . flowRate) presentRooms + let valves = S.toList $ state ^. dOpenValves + return $ sum $ fmap (\v -> (cave ! v) ^. flowRate) valves + -- let presentRooms = cave `M.restrictKeys` valves + -- return $ sumOf (folded . flowRate) presentRooms + + timeOf state = min (state ^. personTime) (state ^. elephantTime) successors state = do isFF <- isFullFlow state + -- cave <- asks getCave + timeLimit <- asks getTimeLimit + let opened = state ^. dOpenValves + let pNow = state ^. personTime + let eNow = state ^. elephantTime + let now = min pNow eNow let pHere = state ^. personRoom let eHere = state ^. elephantRoom - let opened = state ^. dOpenValves - pSuccPairs <- personSuccessor pHere opened - eSuccPairs <- personSuccessor eHere opened - let succStates = - [ DoubleSearchState - { _personRoom = p - , _elephantRoom = e - , _dOpenValves = S.union po eo - } - | (p, po) <- pSuccPairs - , (e, eo) <- eSuccPairs - ] - if isFF - then return $ Q.singleton state - else return $ Q.fromList succStates - - estimateBenefit here timeElapsed = + pNexts <- agentSuccessor now opened pNow pHere + eNexts <- agentSuccessor now opened eNow eHere + let nexts = [ state & personRoom .~ (p ^. currentRoom) + & personTime .~ (p ^. currentTime) + & elephantRoom .~ (e ^. currentRoom) + & elephantTime .~ (e ^. currentTime) + & dOpenValves %~ (S.union (p ^. sOpenValves) . S.union (e ^. sOpenValves)) + | p <- pNexts + , e <- eNexts + ] + let dedups = if pNow == eNow && pHere == eHere + then filter (\s -> (s ^. personRoom) < (s ^. elephantRoom)) nexts + -- else nexts + else filter (\s -> (s ^. personRoom) /= (s ^. elephantRoom)) nexts + -- let succStates = trace ("Succs: in " ++ (show state) ++ " out " ++ (show dedups)) (Q.fromList dedups) + let succStates = Q.fromList dedups + if isFF || (Q.null succStates) + then return $ Q.singleton (state & personTime .~ timeLimit & elephantTime .~ timeLimit) + else return succStates + + estimateBenefit here = do cave <- asks getCave timeLimit <- asks getTimeLimit - let timeRemaining = timeLimit - (timeElapsed + 2) + let timeRemaining = timeLimit - (timeOf here) cf <- currentFlow here - let closedValves = (cave `M.withoutKeys` (here ^. dOpenValves)) ^.. folded . flowRate - let sortedClosedValves = fmap sum $ chunksOf 2 $ sortOn Down closedValves + -- let closedValves = (cave `M.withoutKeys` (here ^. dOpenValves)) ^.. folded . flowRate + -- let sortedClosedValves = fmap sum $ chunksOf 2 $ {-# SCC estSort #-} sortOn Down closedValves + -- let sortedClosedValves = fmap sum $ chunksOf 2 $ reverse $ sort closedValves -- no significant improvement + sortedValves <- asks getSortedRooms + let opened = here ^. dOpenValves + let sortedClosedValves = fmap sum $ chunksOf 2 $ [(cave ! v) ^. flowRate | v <- sortedValves, v `S.notMember` opened] let otherValveFlows = sum $ zipWith (*) [timeRemaining, (timeRemaining - 2) .. 0] sortedClosedValves + -- let otherValveFlows = timeRemaining * (sum closedValves) -- 8 minute runtime rather than 1:50 return $ (cf * timeRemaining) + otherValveFlows @@ -152,8 +186,11 @@ main :: IO () main = do dataFileName <- getDataFileName text <- TIO.readFile dataFileName - let cave = successfulParse text + let expandedCave = successfulParse text -- print cave + -- print $ reachableFrom cave [Tunnel "AA" 0] S.empty [] + -- print $ compress cave + let cave = compress expandedCave print $ part1 cave print $ part2 cave @@ -164,10 +201,14 @@ main = -- part2 cave = runReader (searchCave "AA") (TimedCave cave 26) part1, part2 :: Cave -> Int +-- part1 :: Cave -> Int part1 cave = maybe 0 _benefit result - where result = runReader (searchCave "AA") (TimedCave cave 30) :: Maybe (Agendum SingleSearchState) + where result = runReader (searchCave "AA") (TimedCave cave 30 sortedRooms) :: Maybe (Agendum SingleSearchState) + sortedRooms = sortOn (\r -> Down $ (cave ! r) ^. flowRate ) $ M.keys $ M.filter (\r -> r ^. flowRate > 0) cave part2 cave = maybe 0 _benefit result - where result = runReader (searchCave "AA") (TimedCave cave 26) :: Maybe (Agendum DoubleSearchState) + where result = runReader (searchCave "AA") (TimedCave cave 26 sortedRooms) :: Maybe (Agendum DoubleSearchState) + sortedRooms = sortOn (\r -> Down $ (cave ! r) ^. flowRate ) $ M.keys $ M.filter (\r -> r ^. flowRate > 0) cave + -- sortedRooms = sortOn (\r -> Down $ (cave ! r) ^. flowRate ) $ M.keys cave searchCave :: SearchState s => String -> CaveContext (Maybe (Agendum s)) searchCave startRoom = @@ -177,13 +218,15 @@ searchCave startRoom = initAgenda :: SearchState s => String -> CaveContext (Agenda s) initAgenda startID = do let startState = emptySearchState startID - b <- estimateBenefit startState 0 + b <- estimateBenefit startState return $ P.singleton b Agendum { _current = startState, _trail = Q.empty, _trailBenefit = 0, _benefit = b} aStar :: SearchState s => Agenda s -> ExploredStates s -> CaveContext (Maybe (Agendum s)) aStar agenda closed -- | trace ("Peeping " ++ (show $ fst $ P.findMin agenda) ++ ": " ++ (show reached) ++ " <- " ++ (show $ toList $ Q.take 1 $ _trail $ currentAgendum) ++ " :: " ++ (show newAgenda)) False = undefined - -- | trace ("Peeping " ++ (show $ _current $ snd $ P.findMax agenda) ++ " : len " ++ (show $ Q.length $ _trail $ snd $ P.findMax agenda)) False = undefined + -- | trace ("Peeping " ++ (show $ _current $ snd $ P.findMax agenda) ++ " : foundFlow " ++ (show $ _trailBenefit $ snd $ P.findMax agenda)) False = undefined + -- | trace ("Peeping " ++ (show $ _current $ snd $ P.findMax agenda) ++ " : foundFlow " ++ (show $ _trailBenefit $ snd $ P.findMax agenda) ++ " : trail " ++ (show $ _trail $ snd $ P.findMax agenda) ++ " : closed " ++ (show closed)) False = undefined + -- | trace ("Peeping " ++ (show $ P.findMax agenda)) False = undefined | P.null agenda = return Nothing | otherwise = do let (_, currentAgendum) = P.findMax agenda @@ -191,15 +234,17 @@ aStar agenda closed nexts <- candidates currentAgendum closed let newAgenda = foldl' (\q a -> P.insert (_benefit a) a q) (P.deleteMax agenda) nexts -- let beamAgenda = P.fromDescList $ P.take 10000 newAgenda -- agenda beam width - let beamAgenda = P.fromDescList $ P.take 5000 newAgenda -- agenda beam width + -- let beamAgenda = P.fromDescList $ P.take 5000 newAgenda -- agenda beam width + -- let beamAgenda = P.fromDescList $ P.take 1000 newAgenda -- agenda beam width reachedGoal <- isGoal currentAgendum - let cl = (reached, currentAgendum ^. trailBenefit, Q.length $ currentAgendum ^. trail) + -- let cl = (reached, currentAgendum ^. trailBenefit, Q.length $ currentAgendum ^. trail) + let cl = (reached, currentAgendum ^. trailBenefit) if reachedGoal then return (Just currentAgendum) else if (cl `S.member` closed) then aStar (P.deleteMax agenda) closed - -- else aStar newAgenda (S.insert cl closed) - else aStar beamAgenda (S.insert cl closed) + else aStar newAgenda (S.insert cl closed) + -- else aStar beamAgenda (S.insert cl closed) candidates :: SearchState s => Agendum s -> ExploredStates s -> CaveContext (Q.Seq (Agendum s)) @@ -209,41 +254,65 @@ candidates agendum closed = let prevBenefit = agendum ^. trailBenefit succs <- successors candidate succAgs <- mapM (makeAgendum previous prevBenefit) succs - let nonloops = Q.filter (\s -> (s ^. current, s ^. trailBenefit, Q.length $ s ^. trail) `S.notMember` closed) succAgs + -- let nonloops = Q.filter (\s -> (s ^. current, s ^. trailBenefit, Q.length $ s ^. trail) `S.notMember` closed) succAgs + let nonloops = Q.filter (\s -> (s ^. current, s ^. trailBenefit) `S.notMember` closed) succAgs return nonloops -personSuccessor, openValveSuccessor, walkSuccessor :: RoomID -> S.Set RoomID -> CaveContext [(RoomID, S.Set RoomID)] -personSuccessor here opened = - do ovs <- openValveSuccessor here opened - ws <- walkSuccessor here opened - return (ovs ++ ws) -openValveSuccessor here opened - | here `S.member` opened = return [] - | otherwise = return [(here, S.insert here opened)] - -walkSuccessor here opened = - do cave <- asks getCave - let neighbours = (cave ! here) ^. tunnels - return [(n, opened) | n <- neighbours] +agentSuccessor :: Int -> S.Set RoomID -> Int -> RoomID -> CaveContext [SingleSearchState] +agentSuccessor now opened aTime here + | aTime /= now = return [SingleSearchState { _currentRoom = here, _currentTime = aTime, _sOpenValves = opened }] + | otherwise = + do cave <- asks getCave + timeLimit <- asks getTimeLimit + let remaining = S.toList $ S.filter (\t -> (t ^. tunnelTo) `S.notMember` opened) ((cave ! here) ^. tunnels) + let moves = [ SingleSearchState + { _currentRoom = (t ^. tunnelTo) + , _currentTime = now + (t ^. tunnelLength) + , _sOpenValves = opened + } + | t <- remaining + , now + (t ^. tunnelLength) <= timeLimit + ] + let opens = if here `S.notMember` opened && (cave ! here) ^. flowRate > 0 + then [SingleSearchState { _currentRoom = here, _currentTime = aTime + 1, _sOpenValves = S.insert here opened }] + else [] + -- let nexts = moves ++ opens + let nexts = if null opens then moves else opens + let nexts' = if null nexts + then [ SingleSearchState + { _currentRoom = here + , _currentTime = timeLimit + , _sOpenValves = opened + } ] + else nexts + return nexts' makeAgendum :: SearchState s => Q.Seq s -> Int -> s -> CaveContext (Agendum s) makeAgendum previous prevBenefit newState = - do predicted <- estimateBenefit newState (Q.length previous) - cf <- currentFlow newState + do predicted <- estimateBenefit newState -- (Q.length previous) + -- cf <- currentFlow newState + oldFlow <- lastFlow previous (timeOf newState) let newTrail = previous |> newState - let incurred = prevBenefit + cf + let incurred = prevBenefit + oldFlow return Agendum { _current = newState , _trail = newTrail , _trailBenefit = incurred , _benefit = incurred + predicted } +lastFlow :: SearchState s => Q.Seq s -> Int -> CaveContext Int +lastFlow Q.Empty _ = return 0 +lastFlow (_ :|> previous) newTime = + do cf <- currentFlow previous + let dt = newTime - (timeOf previous) + return (cf * dt) isGoal :: SearchState s => Agendum s -> CaveContext Bool isGoal agendum = do timeLimit <- asks getTimeLimit - return $ Q.length (agendum ^. trail) == (timeLimit - 1) + let s = agendum ^. current + return $ (timeOf s) == timeLimit isFullFlow :: SearchState s => s -> CaveContext Bool isFullFlow state = @@ -252,21 +321,40 @@ isFullFlow state = let ff = sumOf (folded . flowRate) cave return (cf == ff) +compress :: Cave -> Cave +compress cave = M.mapWithKey (compressRoom cave) cave + +compressRoom :: Cave -> RoomID -> Room -> Room +compressRoom cave here room = room & tunnels .~ t' + where t' = reachableFrom cave [Tunnel here 0] S.empty S.empty + +reachableFrom :: Cave -> [Tunnel] -> S.Set RoomID -> S.Set Tunnel -> S.Set Tunnel +reachableFrom _ [] _ routes = routes +reachableFrom cave (tunnel@(Tunnel here len):boundary) found routes + | here `S.member` found = reachableFrom cave boundary found routes + | otherwise = reachableFrom cave (boundary ++ (S.toList legs)) (S.insert here found) routes' + where exits = (cave ! here) ^. tunnels + exits' = S.filter (\t -> (t ^. tunnelTo) `S.notMember` found) exits + legs = S.map (\t -> t & tunnelLength .~ (len + 1)) exits' + routes' = if (len == 0) || ((cave ! here) ^. flowRate) == 0 + then routes + else S.insert tunnel routes + -- Parse the input file caveP :: Parser Cave valveP :: Parser (RoomID, Room) roomP :: Parser Room -tunnelsP :: Parser [RoomID] -turnnelTextP :: Parser Text +tunnelsP :: Parser (S.Set Tunnel) +tunnelTextP :: Parser Text caveP = M.fromList <$> valveP `sepBy` endOfLine valveP = (,) <$> ("Valve " *> (many1 letter)) <*> roomP -roomP = roomify <$> (" has flow rate=" *> decimal) <*> (turnnelTextP *> tunnelsP) - where roomify v ts = Room {_flowRate = v, _tunnels = ts } -tunnelsP = (many1 letter) `sepBy` ", " -turnnelTextP = "; tunnels lead to valves " <|> "; tunnel leads to valve " +roomP = Room <$> (" has flow rate=" *> decimal) <*> (tunnelTextP *> tunnelsP) + -- where roomify v ts = Room {flowRate = v, tunnels = ts } +tunnelsP = (S.fromList . (fmap (flip Tunnel 1))) <$> (many1 letter) `sepBy` ", " +tunnelTextP = "; tunnels lead to valves " <|> "; tunnel leads to valve " successfulParse :: Text -> Cave successfulParse input =