From ff5148c99076cfed05fe1029fd5a8d02a7e0accb Mon Sep 17 00:00:00 2001 From: Neil Smith Date: Mon, 30 Dec 2019 17:18:33 +0000 Subject: [PATCH] Done part 2 --- advent18/package.yaml | 13 +- advent18/src/advent18.hs | 357 ++++++++++++++++----------------- advent18/src/advent18class.hs | 308 ++++++++++++++++++++++++++++ advent18/src/advent18direct.hs | 9 +- problems/day18.html | 330 ++++++++++++++++++++++++++++++ 5 files changed, 833 insertions(+), 184 deletions(-) create mode 100644 advent18/src/advent18class.hs create mode 100644 problems/day18.html diff --git a/advent18/package.yaml b/advent18/package.yaml index e179ca5..f503113 100644 --- a/advent18/package.yaml +++ b/advent18/package.yaml @@ -70,4 +70,15 @@ executables: - containers - pqueue - mtl - - lens \ No newline at end of file + - lens + + advent18class: + main: advent18class.hs + source-dirs: src + dependencies: + - base >= 2 && < 6 + - text + - containers + - pqueue + - mtl + - lens \ No newline at end of file diff --git a/advent18/src/advent18.hs b/advent18/src/advent18.hs index ac0c1da..4267fac 100644 --- a/advent18/src/advent18.hs +++ b/advent18/src/advent18.hs @@ -3,7 +3,7 @@ import Debug.Trace -- import qualified Data.Text.IO as TIO import qualified Data.Map.Strict as M --- import Data.Map.Strict ((!)) +import Data.Map.Strict ((!)) import qualified Data.PQueue.Prio.Min as P import qualified Data.Set as S import qualified Data.Sequence as Q @@ -22,166 +22,207 @@ type Position = (Integer, Integer) -- r, c type Keys = S.Set Char type PointOfInterest = M.Map Position Char +data Explorer = Explorer { _position :: S.Set Char + , _keysHeld :: Keys + , _travelled :: Int + } deriving (Show) +makeLenses ''Explorer -class (Eq e, Ord e) => ExplorerC e where - successors :: e -> CaveContext (Q.Seq e) - estimateCost :: e -> CaveContext Int - -- positionE :: e -> Position - keysHeldE :: e -> Keys - emptyExplorer :: e +type ExploredStates = S.Set Explorer + +type ExpandedCave = S.Set Position +data ExpandedCaveComplex = ExpandedCaveComplex { _caveE :: ExpandedCave + , _keysE :: PointOfInterest + , _doors :: PointOfInterest + } deriving (Eq, Ord, Show) +makeLenses ''ExpandedCaveComplex +data CaveEdge = CaveEdge { _keysRequired :: S.Set Char + , _distance :: Int + } deriving (Eq, Ord, Show) +makeLenses ''CaveEdge -data Explorer1 = Explorer1 { _position1 :: Position - , _keysHeld1 :: Keys - } deriving (Eq, Ord, Show) -data Explorer4 = Explorer4 { _position4 :: S.Set Position - , _keysHeld4 :: Keys - } deriving (Eq, Ord, Show) -type ExploredStates e = S.Set e +type EdgeKey = (Char, Char) +type Cave = M.Map EdgeKey CaveEdge -type Cave = S.Set Position data CaveComplex = CaveComplex { _cave :: Cave - , _keys :: PointOfInterest - , _doors :: PointOfInterest + , _keys :: S.Set Char } deriving (Eq, Ord, Show) +makeLenses ''CaveComplex + type CaveContext = Reader CaveComplex -data Agendum e = Agendum { _current :: e - , _trail :: Q.Seq e +data Agendum = Agendum { _current :: Explorer + , _trail :: Q.Seq Explorer , _cost :: Int} deriving (Show, Eq) -type Agenda e = P.MinPQueue Int (Agendum e) --- type Candidates e = S.Set (Int, Agendum e) - -instance ExplorerC Explorer1 where - successors explorer = - do let here = _position1 explorer - let locations0 = possibleNeighbours here - cave <- asks _cave - keys <- asks _keys - doors <- asks _doors - let keysHeld = _keysHeld1 explorer - let locations1 = Q.filter (`S.member` cave) locations0 - let locations2 = Q.filter (hasKeyFor doors keysHeld) locations1 - return $ fmap (\l -> explorer { _position1 = l, _keysHeld1 = pickupKey keys keysHeld l}) locations2 - - estimateCost explorer = -- return 0 - do keys <- asks _keys - let (r, c) = _position1 explorer - let unfoundKeys = M.keysSet $ M.filter (`S.notMember` (_keysHeld1 explorer)) keys - let (minR, maxR, minC, maxC) = bounds $ unfoundKeys - -- = minimum $ map fst $ M.keys unfoundKeys - -- let minC = minimum $ map snd $ M.keys unfoundKeys - -- let maxR = maximum $ map fst $ M.keys unfoundKeys - -- let maxC = maximum $ map snd $ M.keys unfoundKeys - let spanR = spanV r minR maxR - let spanC = spanV c minC maxC - if S.null unfoundKeys - then return 0 - else return $ fromIntegral (spanR + spanC) - -- return $ sum $ map (manhattan here) $ M.keys unfoundKeys - - -- positionE = _position1 - keysHeldE = _keysHeld1 - emptyExplorer = Explorer1 { _position1 = (0, 0), _keysHeld1 = S.empty } - -instance ExplorerC Explorer4 where - successors explorer = - do let rawHeres = _position4 explorer - let heres = setToSeq $ allSplits rawHeres - let locations0 = over (traversed . _1) possibleNeighbours heres - cave <- asks _cave - keys <- asks _keys - doors <- asks _doors - let keysHeld = _keysHeld4 explorer - let locations1 = over (traversed . _1) (Q.filter (`S.member` cave)) locations0 - let locations2 = over (traversed . _1) (Q.filter (hasKeyFor doors keysHeld)) locations1 - let locations3 = fmap (\(ls, hs) -> fmap (\l -> (l, hs)) ls) locations2 - let locations4 = foldl1 (><) locations3 - return $ fmap (\(l, hs) -> explorer { _position4 = S.insert l hs, _keysHeld4 = pickupKey keys keysHeld l}) locations4 - - estimateCost explorer = -- return 0 - do keys <- asks _keys - let unfoundKeys = M.keysSet $ M.filter (`S.notMember` (_keysHeld4 explorer)) keys - let (minR, maxR, minC, maxC) = bounds unfoundKeys - let (minDR, maxDR, minDC, maxDC) = bounds $ _position4 explorer - let dr = abs (minR - minDR) + abs (maxR - maxDR) - let dc = abs (minC - minDC) + abs (maxC - maxDC) - if S.null unfoundKeys - then return 0 - else return $ fromIntegral (dr + dc) - -- return $ sum $ map (manhattan here) $ M.keys unfoundKeys - - -- positionE = _position1 - keysHeldE = _keysHeld4 - emptyExplorer = Explorer4 { _position4 = S.fromList $ replicate 4 (0, 0), _keysHeld4 = S.empty } +type Agenda = P.MinPQueue Int (Agendum) +instance Eq Explorer where + e1 == e2 = (_position e1 == _position e2) && (_keysHeld e1 == _keysHeld e2) + +instance Ord Explorer where + e1 `compare` e2 = + if _position e1 == _position e2 + then (_keysHeld e1) `compare` (_keysHeld e2) + else (_position e1) `compare` (_position e2) + + + -- positionE :: e -> Position + -- keysHeldE :: e -> Keys + +successors :: Explorer -> CaveContext (Q.Seq Explorer) +successors explorer = -- return Q.empty + do let heres = explorer ^. position + cavern <- asks _cave + let kH = explorer ^. keysHeld + let locations0 = M.filterWithKey (\k _ds -> anyEdgeTouch heres k) cavern + let locations1 = M.filter (\e -> S.null ((e ^. keysRequired) `S.difference` kH)) locations0 + let succs = M.foldrWithKey' (\k e q -> (extendExplorer explorer k e) <| q) Q.empty locations1 + return succs + +estimateCost :: Explorer -> CaveContext Int +estimateCost explorer = -- return 0 + do let heres = explorer ^. position + ks <- asks _keys + cavern <- asks _cave + let kH = explorer ^. keysHeld + let unfound = ks `S.difference` kH + let unfoundEdges0 = M.filterWithKey (\k _ -> anyEdgeTouch heres k) cavern + let unfoundEdges = M.filterWithKey (\k _ -> not $ anyEdgeTouch kH k) unfoundEdges0 + let furthest = maximum $ (0:) $ map _distance $ M.elems unfoundEdges + return $ max 0 $ furthest + (S.size unfound) - 1 + +emptyExplorer :: S.Set Char -> Explorer +emptyExplorer ps = Explorer { _position = ps, _keysHeld = S.empty, _travelled = 0 } + +extendExplorer :: Explorer -> EdgeKey -> CaveEdge -> Explorer +extendExplorer explorer edgeKey edge = + explorer & position .~ pos' + & keysHeld .~ kH' + & travelled .~ d' + where here = S.findMin $ S.filter (\p -> edgeTouches p edgeKey) (explorer ^. position) + there = edgeOther here edgeKey + kH' = S.insert there (explorer ^. keysHeld) + d' = (explorer ^. travelled) + (edge ^. distance) + pos' = S.insert there $ S.delete here (explorer ^. position) + main :: IO () main = do text <- readFile "data/advent18.txt" - let (cc, explorer) = buildCaveComplex text - -- print cc - -- print explorer - print $ part1 cc explorer - print $ part2 cc explorer - -part1 :: ExplorerC e => CaveComplex -> e -> Int -part1 cave explorer = maybe 0 (( + 1) . _cost ) result - where result = runReader (searchCave explorer) cave + let (ccE, startPosition) = buildCaveComplex text + -- print ccE + print $ part1 ccE startPosition + print $ part2 ccE startPosition --- -- part1 :: CaveComplex -> Explorer -> Maybe Agendum --- part1 cave explorer = keySeq (fromJust result) --- where result = runReader (searchCave explorer) cave +part1 :: ExpandedCaveComplex -> Position -> Int +part1 cavern startPosition = maybe 0 _cost result + where cc = contractCave cavern [startPosition] + explorer = emptyExplorer ['0'] + result = runReader (searchCave explorer) cc -part2 :: CaveComplex -> Explorer1 -> Int -part2 caveComplex0 explorer1 = maybe 0 (( + 1) . _cost ) result +part2 :: ExpandedCaveComplex -> Position -> Int +part2 caveComplex0 (re, ce) = maybe 0 _cost result where - (re, ce) = _position1 explorer1 - cave0 = _cave caveComplex0 - cave = cave0 `S.difference` [(re, ce), (re + 1, ce), (re - 1, ce), (re, ce + 1), (re, ce - 1)] - caveComplex = caveComplex0 {_cave = cave} - explorer = Explorer4 {_position4 = [(re + 1, ce + 1), (re - 1, ce + 1), (re + 1, ce - 1), (re - 1, ce - 1)], _keysHeld4 = S.empty } - result = runReader (searchCave explorer) caveComplex + startPositions = [(re - 1, ce - 1), (re - 1, ce + 1), (re + 1 , ce - 1), (re + 1, ce + 1)] + cavern0 = _caveE caveComplex0 + cavern = cavern0 `S.difference` [(re, ce), (re + 1, ce), (re - 1, ce), (re, ce + 1), (re, ce - 1)] + caveComplex = caveComplex0 {_caveE = cavern} + cc = contractCave caveComplex startPositions + explorer = emptyExplorer $ S.fromList "0123" + result = runReader (searchCave explorer) cc + + +-- buildCaveComplex :: Explorer e => String -> (CaveComplex, e) +buildCaveComplex :: String -> (ExpandedCaveComplex, Position) +buildCaveComplex text = (ccE, startPosition) + where (ccE, startPosition) = foldl' buildCaveRow (cc0, (0, 0)) $ zip [0..] rows + cc0 = ExpandedCaveComplex {_caveE = S.empty, _keysE = M.empty, _doors = M.empty} + -- explorer0 = emptyExplorer -- Explorer { _position = (0, 0), _keysHeld = S.empty } + rows = lines text -keySeq :: ExplorerC e => (Agendum e) -> Q.Seq Keys -keySeq agendum = Q.filter (not . S.null) kdiff - where keyss = fmap keysHeldE $ _trail agendum - kdiff = fmap (uncurry S.difference) $ Q.zip ((keysHeldE $ _current agendum) <| keyss) keyss +buildCaveRow :: (ExpandedCaveComplex, Position) -> (Integer, String) -> (ExpandedCaveComplex, Position) +buildCaveRow (cc, explorers) (r, row) = foldl' (buildCaveCell r) (cc, explorers) $ zip [0..] row -searchCave :: ExplorerC e => e -> CaveContext (Maybe (Agendum e)) -searchCave explorer = - do agenda <- initAgenda explorer - aStar agenda S.empty +buildCaveCell :: Integer -> (ExpandedCaveComplex, Position) -> (Integer, Char) -> (ExpandedCaveComplex, Position) +buildCaveCell r (cc, startPosition) (c, char) + | char == '.' = (cc', startPosition) + | char == '@' = (cc', here) + | isLower char = (cc' { _keysE = M.insert here char $ _keysE cc'}, startPosition) + | isUpper char = (cc' { _doors = M.insert here char $ _doors cc'}, startPosition) + | otherwise = (cc, startPosition) + where cc' = cc { _caveE = S.insert here $ _caveE cc } + here = (r, c) -buildCaveComplex text = foldl' buildCaveRow (cc0, explorer0) $ zip [0..] rows - where cc0 = CaveComplex {_cave = S.empty, _keys = M.empty, _doors = M.empty} - explorer0 = emptyExplorer -- Explorer { _position = (0, 0), _keysHeld = S.empty } - rows = lines text -buildCaveRow (cc, explorer) (r, row) = foldl' (buildCaveCell r) (cc, explorer) $ zip [0..] row +mkEdgeKey a b = if a < b then (a, b) else (b, a) + +edgeTouches x (a, b) + | x == a = True + | x == b = True + | otherwise = False + +anyEdgeTouch xs p = S.foldl' (\t x -> t || (edgeTouches x p)) False xs + +edgeOther x (a, b) + | x == a = b + | otherwise = a + -buildCaveCell r (cc, explorer) (c, char) - | char == '.' = (cc', explorer) - | char == '@' = (cc', explorer { _position1 = here }) - | isLower char = (cc' { _keys = M.insert here char $ _keys cc'}, explorer) - | isUpper char = (cc' { _doors = M.insert here char $ _doors cc'}, explorer) - | otherwise = (cc, explorer) - where cc' = cc { _cave = S.insert here $ _cave cc } - here = (r, c) +contractCave :: ExpandedCaveComplex -> [Position] -> CaveComplex +contractCave expanded startPositions = cavern + where explorers = M.fromList $ zip startPositions $ map intToDigit [0..] + starts = M.union explorers $ _keysE expanded + cavern0 = CaveComplex {_cave = M.empty, _keys = S.fromList $ M.elems $ _keysE expanded} + cavern = M.foldrWithKey (contractFrom expanded) cavern0 starts -initAgenda :: ExplorerC e => e -> CaveContext (Agenda e) +contractFrom :: ExpandedCaveComplex -> Position -> Char -> CaveComplex -> CaveComplex +contractFrom expanded startPos startKey cc = cc { _cave = M.union (_cave cc) reachables } + where reachables = reachableFrom [(startPos, edge0)] S.empty expanded' startKey + edge0 = CaveEdge {_keysRequired = S.empty, _distance = 0} + expanded' = expanded {_keysE = M.delete startPos $ _keysE expanded} + +reachableFrom :: [(Position, CaveEdge)] -> (S.Set Position) -> ExpandedCaveComplex -> Char -> Cave +reachableFrom [] _closed _expanded _startKey = M.empty +reachableFrom ((here, edge):boundary) closed expanded startKey + | here `S.member` closed = reachableFrom boundary closed expanded startKey + | here `M.member` ks = M.insert edgeKey edge $ reachableFrom boundary closed' expanded startKey + | here `M.member` drs = reachableFrom boundaryD closed' expanded startKey + | otherwise = reachableFrom boundary' closed' expanded startKey + where nbrs0 = S.intersection (_caveE expanded) $ possibleNeighbours here + nbrs = S.difference nbrs0 closed + closed' = S.insert here closed + ks = _keysE expanded + drs = _doors expanded + edgeKey = mkEdgeKey startKey (ks!here) + edge' = edge { _distance = (_distance edge) + 1} + edgeD = edge' {_keysRequired = S.insert (toLower (drs!here)) (_keysRequired edge')} + neighbours = S.map (\n -> (n, edge')) nbrs + neighboursD = S.map (\n -> (n, edgeD)) nbrs + boundary' = boundary ++ (S.toAscList neighbours) + boundaryD = boundary ++ (S.toAscList neighboursD) + +possibleNeighbours :: Position -> S.Set Position +possibleNeighbours (r, c) = [(r + 1, c), (r - 1, c), (r, c + 1), (r, c - 1)] + + +searchCave :: Explorer -> CaveContext (Maybe (Agendum)) +searchCave explorer = + do agenda <- initAgenda explorer + aStar agenda S.empty + +initAgenda :: Explorer -> CaveContext (Agenda) initAgenda explorer = do cost <- estimateCost explorer return $ P.singleton cost Agendum { _current = explorer, _trail = Q.empty, _cost = cost} -aStar :: ExplorerC e => Agenda e -> ExploredStates e -> CaveContext (Maybe (Agendum e)) --- aStar [] _ = Agendum {current=buildingTest, trail=[], cost=0} +aStar :: Agenda -> ExploredStates -> CaveContext (Maybe (Agendum)) 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.findMin agenda) ) False = undefined @@ -199,13 +240,13 @@ aStar agenda closed else aStar newAgenda (S.insert reached closed) -isGoal :: ExplorerC e => e -> CaveContext Bool +isGoal :: Explorer -> CaveContext Bool isGoal explorer = - do keys <- asks (S.fromList . M.elems . _keys) - return $ keys == keysHeldE explorer + do ks <- asks _keys + return $ ks == (explorer ^. keysHeld) -candidates :: ExplorerC e => Agendum e -> ExploredStates e -> CaveContext (Q.Seq (Agendum e)) +candidates :: Agendum -> ExploredStates -> CaveContext (Q.Seq (Agendum)) candidates agendum closed = do let candidate = _current agendum let previous = _trail agendum @@ -213,54 +254,10 @@ candidates agendum closed = let nonloops = Q.filter (\s -> not $ s `S.member` closed) succs mapM (makeAgendum candidate previous) nonloops -makeAgendum :: ExplorerC e => e -> (Q.Seq e) -> e -> CaveContext (Agendum e) +makeAgendum :: Explorer -> (Q.Seq Explorer) -> Explorer -> CaveContext (Agendum) makeAgendum candidate previous new = - do cost <- estimateCost new + do predicted <- estimateCost new return Agendum { _current = new , _trail = candidate <| previous - , _cost = cost + (Q.length previous) - } - - - -hasKeyFor :: PointOfInterest -> Keys -> Position -> Bool --- hasKeyFor doors keys here | trace ("hkf: " ++ (intercalate " " [show doors, show keys, show here, show (maybe True (`S.member` keys) $ M.lookup here doors)])) False = undefined -hasKeyFor doors keys here = maybe True keyForDoor $ M.lookup here doors - where keyForDoor d = (toLower d) `S.member` keys - -- if location `M.member` doors - -- then (doors!location) `S.elem` keys - -- else True - - -pickupKey :: PointOfInterest -> Keys -> Position -> Keys -pickupKey keys held here = maybe held (`S.insert` held) $ M.lookup here keys - -- if here `M.member` keys - -- then S.insert (keys!here) held - -- else held - - -spanV this minV maxV - | this < minV = maxV - this - | this > maxV = this - minV - -- | this > minV && this < maxV = (this - minV) + (maxV - this) - | otherwise = (this - minV) + (maxV - this) - -manhattan :: Position -> Position -> Int -manhattan (r1, c1) (r2, c2) = fromIntegral $ abs (r1 - r2) + abs (c1 - c2) - -possibleNeighbours :: Position -> Q.Seq Position -possibleNeighbours (r, c) = [(r + 1, c), (r - 1, c), (r, c + 1), (r, c - 1)] - -bounds :: S.Set Position -> (Integer, Integer, Integer, Integer) -bounds points = (minR, maxR, minC, maxC) - where minR = S.findMin $ S.map fst points - minC = S.findMin $ S.map snd points - maxR = S.findMax $ S.map fst points - maxC = S.findMax $ S.map snd points - - -allSplits :: Ord a => S.Set a -> S.Set (a, S.Set a) -allSplits xs = S.map (\x -> (x, S.delete x xs)) xs - -setToSeq :: Ord a => S.Set a -> Q.Seq a -setToSeq = S.foldl (|>) Q.empty + , _cost = (new ^. travelled) + predicted + } \ No newline at end of file diff --git a/advent18/src/advent18class.hs b/advent18/src/advent18class.hs new file mode 100644 index 0000000..a06e6f1 --- /dev/null +++ b/advent18/src/advent18class.hs @@ -0,0 +1,308 @@ +import Debug.Trace + +-- import qualified Data.Text.IO as TIO + +import qualified Data.Map.Strict as M +import Data.Map.Strict ((!)) +import qualified Data.PQueue.Prio.Min as P +import qualified Data.Set as S +import qualified Data.Sequence as Q +import Data.Sequence ((<|), (|>), (><)) +import Data.Foldable (toList, foldr', foldl', all) +-- import Data.Maybe (fromJust) +-- import Data.List +import Data.Char +import Control.Monad.Reader +import Control.Lens hiding ((<|), (|>)) +-- import Data.Map.Lens + + +type Position = (Integer, Integer) -- r, c + +type Keys = S.Set Char +type PointOfInterest = M.Map Position Char + +data Explorer1 = Explorer1 { _explorer1Position :: Char + , _explorer1KeysHeld :: Keys + , _explorer1Travelled :: Int + } deriving (Show) +data Explorer4 = Explorer4 { _explorer4Position :: S.Set Char + , _explorer4KeysHeld :: Keys + , _explorer4Travelled :: Int + } deriving (Show) +makeFields ''Explorer1 +makeFields ''Explorer4 + +type ExploredStates e = S.Set e + +type ExpandedCave = S.Set Position +data ExpandedCaveComplex = ExpandedCaveComplex { _caveE :: ExpandedCave + , _keysE :: PointOfInterest + , _doors :: PointOfInterest + } deriving (Eq, Ord, Show) +makeLenses ''ExpandedCaveComplex + +data CaveEdge = CaveEdge { _keysRequired :: S.Set Char + , _distance :: Int + } deriving (Eq, Ord, Show) +makeLenses ''CaveEdge + +type EdgeKey = (Char, Char) +type Cave = M.Map EdgeKey CaveEdge + +data CaveComplex = CaveComplex { _cave :: Cave + , _keys :: S.Set Char + } deriving (Eq, Ord, Show) +makeLenses ''CaveComplex + +type CaveContext = Reader CaveComplex + +data Agendum e = Agendum { _current :: e + , _trail :: Q.Seq e + , _cost :: Int} deriving (Show, Eq) +type Agenda e = P.MinPQueue Int (Agendum e) + + +instance Eq Explorer1 where + e1 == e2 = (_explorer1Position e1 == _explorer1Position e2) && (_explorer1KeysHeld e1 == _explorer1KeysHeld e2) +instance Eq Explorer4 where + e1 == e2 = (_explorer4Position e1 == _explorer4Position e2) && (_explorer4KeysHeld e1 == _explorer4KeysHeld e2) + +instance Ord Explorer1 where + e1 `compare` e2 = + if _explorer1Position e1 == _explorer1Position e2 + then (_explorer1KeysHeld e1) `compare` (_explorer1KeysHeld e2) + else (_explorer1Position e1) `compare`(_explorer1Position e2) +instance Ord Explorer4 where + e1 `compare` e2 = + if _explorer4Position e1 == _explorer4Position e2 + then (_explorer4KeysHeld e1) `compare` (_explorer4KeysHeld e2) + else (_explorer4Position e1) `compare`(_explorer4Position e2) + + +class (Eq e, Ord e, Show e) => Explorer e where + successors :: e -> CaveContext (Q.Seq e) + estimateCost :: e -> CaveContext Int + extendExplorer :: e -> EdgeKey -> CaveEdge -> e + -- positionE :: e -> Position + -- keysHeldE :: e -> Keys + emptyExplorer :: e + +instance Explorer Explorer1 where + successors explorer = -- return Q.empty + do let here = explorer ^. position + cavern <- asks _cave + let kH = explorer ^. keysHeld + let locations0 = M.filterWithKey (\k _ds -> edgeTouches here k) cavern + let locations1 = M.filter (\e -> S.null ((e ^. keysRequired) `S.difference` kH)) locations0 + let succs = M.foldrWithKey' (\k e q -> (extendExplorer explorer k e) <| q) Q.empty locations1 + return succs + + estimateCost explorer = -- return 0 + do let here = explorer ^. position + ks <- asks _keys + cavern <- asks _cave + let kH = explorer ^. keysHeld + let unfound = ks `S.difference` kH + let unfoundEdges = M.filterWithKey (\k _ -> (edgeTouches here k) && ((edgeOther here k) `S.member` unfound)) cavern + let furthest = maximum $ (0:) $ map _distance $ M.elems unfoundEdges + return $ max 0 $ furthest + (S.size unfound) - 1 + -- return $ S.size unfound + + emptyExplorer = Explorer1 { _explorer1Position = '0', _explorer1KeysHeld = S.empty, _explorer1Travelled = 0 } + + extendExplorer explorer edgeKey edge = + explorer & position .~ there + & keysHeld .~ kH' + & travelled .~ d' + where there = edgeOther (explorer ^. position) edgeKey + kH' = S.insert there (explorer ^. keysHeld) + d' = (explorer ^. travelled) + (edge ^. distance) + +instance Explorer Explorer4 where + successors explorer = -- return Q.empty + do let heres = explorer ^. position + cavern <- asks _cave + let kH = explorer ^. keysHeld + let locations0 = M.filterWithKey (\k _ds -> anyEdgeTouch heres k) cavern + let locations1 = M.filter (\e -> S.null ((e ^. keysRequired) `S.difference` kH)) locations0 + let succs = M.foldrWithKey' (\k e q -> (extendExplorer explorer k e) <| q) Q.empty locations1 + return succs + + estimateCost explorer = -- return 0 + do let heres = explorer ^. position + ks <- asks _keys + cavern <- asks _cave + let kH = explorer ^. keysHeld + let unfound = ks `S.difference` kH + let unfoundEdges0 = M.filterWithKey (\k _ -> anyEdgeTouch heres k) cavern + let unfoundEdges = M.filterWithKey (\k _ -> not $ anyEdgeTouch kH k) unfoundEdges0 + let furthest = maximum $ (0:) $ map _distance $ M.elems unfoundEdges + return $ max 0 $ furthest + (S.size unfound) - 1 + + emptyExplorer = Explorer4 { _explorer4Position = S.fromList "0123", _explorer4KeysHeld = S.empty, _explorer4Travelled = 0 } + + extendExplorer explorer edgeKey edge = + explorer & position .~ pos' + & keysHeld .~ kH' + & travelled .~ d' + where here = S.findMin $ S.filter (\p -> edgeTouches p edgeKey) (explorer ^. position) + there = edgeOther here edgeKey + kH' = S.insert there (explorer ^. keysHeld) + d' = (explorer ^. travelled) + (edge ^. distance) + pos' = S.insert there $ S.delete here (explorer ^. position) + + +main :: IO () +main = do + text <- readFile "data/advent18.txt" + let (ccE, startPosition) = buildCaveComplex text + -- print ccE + print $ part1 ccE startPosition + print $ part2 ccE startPosition + + +part1 :: ExpandedCaveComplex -> Position -> Int +part1 cavern startPosition = maybe 0 _cost result + where cc = contractCave cavern [startPosition] + explorer = emptyExplorer :: Explorer1 + result = runReader (searchCave explorer) cc + +part2 :: ExpandedCaveComplex -> Position -> Int +part2 caveComplex0 (re, ce) = maybe 0 _cost result + where + startPositions = [(re - 1, ce - 1), (re - 1, ce + 1), (re + 1 , ce - 1), (re + 1, ce + 1)] + cavern0 = _caveE caveComplex0 + cavern = cavern0 `S.difference` [(re, ce), (re + 1, ce), (re - 1, ce), (re, ce + 1), (re, ce - 1)] + caveComplex = caveComplex0 {_caveE = cavern} + cc = contractCave caveComplex startPositions + explorer = emptyExplorer :: Explorer4 + result = runReader (searchCave explorer) cc + + +-- buildCaveComplex :: Explorer e => String -> (CaveComplex, e) +buildCaveComplex :: String -> (ExpandedCaveComplex, Position) +buildCaveComplex text = (ccE, startPosition) + where (ccE, startPosition) = foldl' buildCaveRow (cc0, (0, 0)) $ zip [0..] rows + cc0 = ExpandedCaveComplex {_caveE = S.empty, _keysE = M.empty, _doors = M.empty} + -- explorer0 = emptyExplorer -- Explorer { _position = (0, 0), _keysHeld = S.empty } + rows = lines text + +buildCaveRow :: (ExpandedCaveComplex, Position) -> (Integer, String) -> (ExpandedCaveComplex, Position) +buildCaveRow (cc, explorers) (r, row) = foldl' (buildCaveCell r) (cc, explorers) $ zip [0..] row + + +buildCaveCell :: Integer -> (ExpandedCaveComplex, Position) -> (Integer, Char) -> (ExpandedCaveComplex, Position) +buildCaveCell r (cc, startPosition) (c, char) + | char == '.' = (cc', startPosition) + | char == '@' = (cc', here) + | isLower char = (cc' { _keysE = M.insert here char $ _keysE cc'}, startPosition) + | isUpper char = (cc' { _doors = M.insert here char $ _doors cc'}, startPosition) + | otherwise = (cc, startPosition) + where cc' = cc { _caveE = S.insert here $ _caveE cc } + here = (r, c) + + + +mkEdgeKey a b = if a < b then (a, b) else (b, a) + +edgeTouches x (a, b) + | x == a = True + | x == b = True + | otherwise = False + +anyEdgeTouch xs p = S.foldl' (\t x -> t || (edgeTouches x p)) False xs + +edgeOther x (a, b) + | x == a = b + | otherwise = a + + + +contractCave :: ExpandedCaveComplex -> [Position] -> CaveComplex +contractCave expanded startPositions = cavern + where explorers = M.fromList $ zip startPositions $ map intToDigit [0..] + starts = M.union explorers $ _keysE expanded + cavern0 = CaveComplex {_cave = M.empty, _keys = S.fromList $ M.elems $ _keysE expanded} + cavern = M.foldrWithKey (contractFrom expanded) cavern0 starts + +contractFrom :: ExpandedCaveComplex -> Position -> Char -> CaveComplex -> CaveComplex +contractFrom expanded startPos startKey cc = cc { _cave = M.union (_cave cc) reachables } + where reachables = reachableFrom [(startPos, edge0)] S.empty expanded' startKey + edge0 = CaveEdge {_keysRequired = S.empty, _distance = 0} + expanded' = expanded {_keysE = M.delete startPos $ _keysE expanded} + +reachableFrom :: [(Position, CaveEdge)] -> (S.Set Position) -> ExpandedCaveComplex -> Char -> Cave +reachableFrom [] _closed _expanded _startKey = M.empty +reachableFrom ((here, edge):boundary) closed expanded startKey + | here `S.member` closed = reachableFrom boundary closed expanded startKey + | here `M.member` ks = M.insert edgeKey edge $ reachableFrom boundary closed' expanded startKey + | here `M.member` drs = reachableFrom boundaryD closed' expanded startKey + | otherwise = reachableFrom boundary' closed' expanded startKey + where nbrs0 = S.intersection (_caveE expanded) $ possibleNeighbours here + nbrs = S.difference nbrs0 closed + closed' = S.insert here closed + ks = _keysE expanded + drs = _doors expanded + edgeKey = mkEdgeKey startKey (ks!here) + edge' = edge { _distance = (_distance edge) + 1} + edgeD = edge' {_keysRequired = S.insert (toLower (drs!here)) (_keysRequired edge')} + neighbours = S.map (\n -> (n, edge')) nbrs + neighboursD = S.map (\n -> (n, edgeD)) nbrs + boundary' = boundary ++ (S.toAscList neighbours) + boundaryD = boundary ++ (S.toAscList neighboursD) + +possibleNeighbours :: Position -> S.Set Position +possibleNeighbours (r, c) = [(r + 1, c), (r - 1, c), (r, c + 1), (r, c - 1)] + + +searchCave :: (Explorer e, HasTravelled e Int, HasKeysHeld e Keys) => e -> CaveContext (Maybe (Agendum e)) +searchCave explorer = + do agenda <- initAgenda explorer + aStar agenda S.empty + +initAgenda :: (Explorer e, HasTravelled e Int, HasKeysHeld e Keys) => e -> CaveContext (Agenda e) +initAgenda explorer = + do cost <- estimateCost explorer + return $ P.singleton cost Agendum { _current = explorer, _trail = Q.empty, _cost = cost} + + +aStar :: (Explorer e, HasTravelled e Int, HasKeysHeld e Keys) => Agenda e -> ExploredStates e -> CaveContext (Maybe (Agendum e)) +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.findMin agenda) ) False = undefined + | P.null agenda = return Nothing + | otherwise = + do let (_, currentAgendum) = P.findMin agenda + let reached = _current currentAgendum + nexts <- candidates currentAgendum closed + let newAgenda = foldl' (\q a -> P.insert (_cost a) a q) (P.deleteMin agenda) nexts + reachedGoal <- isGoal reached + if reachedGoal + then return (Just currentAgendum) + else if reached `S.member` closed + then aStar (P.deleteMin agenda) closed + else aStar newAgenda (S.insert reached closed) + + +isGoal :: (Explorer e, HasTravelled e Int, HasKeysHeld e Keys) => e -> CaveContext Bool +isGoal explorer = + do ks <- asks _keys + return $ ks == (explorer ^. keysHeld) + + +candidates :: (Explorer e, HasTravelled e Int, HasKeysHeld e Keys) => Agendum e -> ExploredStates e -> CaveContext (Q.Seq (Agendum e)) +candidates agendum closed = + do let candidate = _current agendum + let previous = _trail agendum + succs <- successors candidate + let nonloops = Q.filter (\s -> not $ s `S.member` closed) succs + mapM (makeAgendum candidate previous) nonloops + +makeAgendum :: (Explorer e, HasTravelled e Int, HasKeysHeld e Keys) => e -> (Q.Seq e) -> e -> CaveContext (Agendum e) +makeAgendum candidate previous new = + do predicted <- estimateCost new + return Agendum { _current = new + , _trail = candidate <| previous + , _cost = (new ^. travelled) + predicted + } \ No newline at end of file diff --git a/advent18/src/advent18direct.hs b/advent18/src/advent18direct.hs index ac0c1da..3d6125e 100644 --- a/advent18/src/advent18direct.hs +++ b/advent18/src/advent18direct.hs @@ -23,7 +23,7 @@ type Keys = S.Set Char type PointOfInterest = M.Map Position Char -class (Eq e, Ord e) => ExplorerC e where +class (Eq e, Ord e, Show e) => ExplorerC e where successors :: e -> CaveContext (Q.Seq e) estimateCost :: e -> CaveContext Int -- positionE :: e -> Position @@ -119,7 +119,7 @@ instance ExplorerC Explorer4 where main :: IO () main = do - text <- readFile "data/advent18.txt" + text <- readFile "data/advent18x.txt" let (cc, explorer) = buildCaveComplex text -- print cc -- print explorer @@ -191,6 +191,7 @@ aStar agenda closed let reached = _current currentAgendum nexts <- candidates currentAgendum closed let newAgenda = foldl' (\q a -> P.insert (_cost a) a q) (P.deleteMin agenda) nexts + -- let newAgenda = trace ("nexts " ++ ( show nexts)) newAgenda0 reachedGoal <- isGoal reached if reachedGoal then return (Just currentAgendum) @@ -206,6 +207,7 @@ isGoal explorer = candidates :: ExplorerC e => Agendum e -> ExploredStates e -> CaveContext (Q.Seq (Agendum e)) +-- candidates a _ | trace ("Cand " ++ show (a)) False = undefined candidates agendum closed = do let candidate = _current agendum let previous = _trail agendum @@ -214,6 +216,7 @@ candidates agendum closed = mapM (makeAgendum candidate previous) nonloops makeAgendum :: ExplorerC e => e -> (Q.Seq e) -> e -> CaveContext (Agendum e) +-- makeAgendum c _p n | trace ("Agendum " ++ (show c) ++ " " ++ (show n) ) False = undefined makeAgendum candidate previous new = do cost <- estimateCost new return Agendum { _current = new @@ -263,4 +266,4 @@ allSplits :: Ord a => S.Set a -> S.Set (a, S.Set a) allSplits xs = S.map (\x -> (x, S.delete x xs)) xs setToSeq :: Ord a => S.Set a -> Q.Seq a -setToSeq = S.foldl (|>) Q.empty +setToSeq xs = foldl' (|>) Q.empty $ S.toAscList xs diff --git a/problems/day18.html b/problems/day18.html new file mode 100644 index 0000000..5631b02 --- /dev/null +++ b/problems/day18.html @@ -0,0 +1,330 @@ + + + + +Day 18 - Advent of Code 2019 + + + + + + + +

Advent of Code

Neil Smith (AoC++) 36*

   int y=2019;

+ + + +
+ +

--- Day 18: Many-Worlds Interpretation ---

As you approach Neptune, a planetary security system detects you and activates a giant tractor beam on Triton! You have no choice but to land.

+

A scan of the local area reveals only one interesting feature: a massive underground vault. You generate a map of the tunnels (your puzzle input). The tunnels are too narrow to move diagonally.

+

Only one entrance (marked @) is present among the open passages (marked .) and stone walls (#), but you also detect an assortment of keys (shown as lowercase letters) and doors (shown as uppercase letters). Keys of a given letter open the door of the same letter: a opens A, b opens B, and so on. You aren't sure which key you need to disable the tractor beam, so you'll need to collect all of them.

+

For example, suppose you have the following map:

+
#########
+#b.A.@.a#
+#########
+
+

Starting from the entrance (@), you can only access a large door (A) and a key (a). Moving toward the door doesn't help you, but you can move 2 steps to collect the key, unlocking A in the process:

+
#########
+#b.....@#
+#########
+
+

Then, you can move 6 steps to collect the only other key, b:

+
#########
+#@......#
+#########
+
+

So, collecting every key took a total of 8 steps.

+

Here is a larger example:

+
########################
+#f.D.E.e.C.b.A.@.a.B.c.#
+######################.#
+#d.....................#
+########################
+
+

The only reasonable move is to take key a and unlock door A:

+
########################
+#f.D.E.e.C.b.....@.B.c.#
+######################.#
+#d.....................#
+########################
+
+

Then, do the same with key b:

+
########################
+#f.D.E.e.C.@.........c.#
+######################.#
+#d.....................#
+########################
+
+

...and the same with key c:

+
########################
+#f.D.E.e.............@.#
+######################.#
+#d.....................#
+########################
+
+

Now, you have a choice between keys d and e. While key e is closer, collecting it now would be slower in the long run than collecting key d first, so that's the best choice:

+
########################
+#f...E.e...............#
+######################.#
+#@.....................#
+########################
+
+

Finally, collect key e to unlock door E, then collect key f, taking a grand total of 86 steps.

+

Here are a few more examples:

+
    +
  • ########################
+#...............b.C.D.f#
+#.######################
+#.....@.a.B.c.d.A.e.F.g#
+########################
+
    +

    Shortest path is 132 steps: b, a, c, d, f, e, g

    • +
  • #################
+#i.G..c...e..H.p#
+########.########
+#j.A..b...f..D.o#
+########@########
+#k.E..a...g..B.n#
+########.########
+#l.F..d...h..C.m#
+#################
+
    +

    Shortest paths are 136 steps;
    one is: a, f, b, j, g, n, h, d, l, o, e, p, c, i, k, m

    • +
  • ########################
+#@..............ac.GI.b#
+###d#e#f################
+###A#B#C################
+###g#h#i################
+########################
+
    +

    Shortest paths are 81 steps; one is: a, c, f, i, d, g, b, e, h

    • +
+

How many steps is the shortest path that collects all of the keys?

+
+

Your puzzle answer was 6286.

--- Part Two ---

You arrive at the vault only to discover that there is not one vault, but four - each with its own entrance.

+

On your map, find the area in the middle that looks like this:

+
...
+.@.
+...
+
+

Update your map to instead use the correct data:

+
@#@
+###
+@#@
+
+

This change will split your map into four separate sections, each with its own entrance:

+
#######       #######
+#a.#Cd#       #a.#Cd#
+##...##       ##@#@##
+##.@.##  -->  #######
+##...##       ##@#@##
+#cB#Ab#       #cB#Ab#
+#######       #######
+
+

Because some of the keys are for doors in other vaults, it would take much too long to collect all of the keys by yourself. Instead, you deploy four remote-controlled robots. Each starts at one of the entrances (@).

+

Your goal is still to collect all of the keys in the fewest steps, but now, each robot has its own position and can move independently. You can only remotely control a single robot at a time. Collecting a key instantly unlocks any corresponding doors, regardless of the vault in which the key or door is found.

+

For example, in the map above, the top-left robot first collects key a, unlocking door A in the bottom-right vault:

+
#######
+#@.#Cd#
+##.#@##
+#######
+##@#@##
+#cB#.b#
+#######
+
+

Then, the bottom-right robot collects key b, unlocking door B in the bottom-left vault:

+
#######
+#@.#Cd#
+##.#@##
+#######
+##@#.##
+#c.#.@#
+#######
+
+

Then, the bottom-left robot collects key c:

+
#######
+#@.#.d#
+##.#@##
+#######
+##.#.##
+#@.#.@#
+#######
+
+

Finally, the top-right robot collects key d:

+
#######
+#@.#.@#
+##.#.##
+#######
+##.#.##
+#@.#.@#
+#######
+
+

In this example, it only took 8 steps to collect all of the keys.

+

Sometimes, multiple robots might have keys available, or a robot might have to wait for multiple keys to be collected:

+
###############
+#d.ABC.#.....a#
+######@#@######
+###############
+######@#@######
+#b.....#.....c#
+###############
+
+

First, the top-right, bottom-left, and bottom-right robots take turns collecting keys a, b, and c, a total of 6 + 6 + 6 = 18 steps. Then, the top-left robot can access key d, spending another 6 steps; collecting all of the keys here takes a minimum of 24 steps.

+

Here's a more complex example:

+
#############
+#DcBa.#.GhKl#
+#.###@#@#I###
+#e#d#####j#k#
+###C#@#@###J#
+#fEbA.#.FgHi#
+#############
+
+
    +
  • Top-left robot collects key a.
    • +
  • Bottom-left robot collects key b.
    • +
  • Top-left robot collects key c.
    • +
  • Bottom-left robot collects key d.
    • +
  • Top-left robot collects key e.
    • +
  • Bottom-left robot collects key f.
    • +
  • Bottom-right robot collects key g.
    • +
  • Top-right robot collects key h.
    • +
  • Bottom-right robot collects key i.
    • +
  • Top-right robot collects key j.
    • +
  • Bottom-right robot collects key k.
    • +
  • Top-right robot collects key l.
    • +
+

In the above example, the fewest steps to collect all of the keys is 32.

+

Here's an example with more choices:

+
#############
+#g#f.D#..h#l#
+#F###e#E###.#
+#dCba@#@BcIJ#
+#############
+#nK.L@#@G...#
+#M###N#H###.#
+#o#m..#i#jk.#
+#############
+
+

One solution with the fewest steps is:

+
    +
  • Top-left robot collects key e.
    • +
  • Top-right robot collects key h.
    • +
  • Bottom-right robot collects key i.
    • +
  • Top-left robot collects key a.
    • +
  • Top-left robot collects key b.
    • +
  • Top-right robot collects key c.
    • +
  • Top-left robot collects key d.
    • +
  • Top-left robot collects key f.
    • +
  • Top-left robot collects key g.
    • +
  • Bottom-right robot collects key k.
    • +
  • Bottom-right robot collects key j.
    • +
  • Top-right robot collects key l.
    • +
  • Bottom-left robot collects key n.
    • +
  • Bottom-left robot collects key m.
    • +
  • Bottom-left robot collects key o.
    • +
+

This example requires at least 72 steps to collect all keys.

+

After updating your map and using the remote-controlled robots, what is the fewest steps necessary to collect all of the keys?

+
+

Your puzzle answer was 2140.

Both parts of this puzzle are complete! They provide two gold stars: **

+

At this point, you should return to your Advent calendar and try another puzzle.

+

If you still want to see it, you can get your puzzle input.

+

You can also this puzzle.

+
+ + + + + + \ No newline at end of file -- 2.34.1