X-Git-Url: https://git.njae.me.uk/?a=blobdiff_plain;f=advent18%2Fsrc%2Fadvent18.hs;h=eb6219ff6ad85afd8179b54e67b1aca4b4b9b8e5;hb=f0d22f1976f3c65c6adc251a637b106ec3e002e3;hp=ac0c1da98b4bcda08c0824c57838755c8537b8ad;hpb=4a61ffa7679d3214f2fc32cef607279ca8835131;p=advent-of-code-19.git diff --git a/advent18/src/advent18.hs b/advent18/src/advent18.hs index ac0c1da..eb6219f 100644 --- a/advent18/src/advent18.hs +++ b/advent18/src/advent18.hs @@ -3,18 +3,15 @@ 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 -import Data.Sequence ((<|), (|>), (><)) -import Data.Foldable (toList, foldr', foldl', all) --- import Data.Maybe (fromJust) --- import Data.List +import Data.Sequence ((<|)) -- , (|>), (><)) +import Data.Foldable (foldl') -- (toList, foldr', foldl', all) import Data.Char import Control.Monad.Reader import Control.Lens hiding ((<|), (|>)) --- import Data.Map.Lens type Position = (Integer, Integer) -- r, c @@ -22,166 +19,186 @@ 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 +instance Eq Explorer where + e1 == e2 = (_position e1 == _position e2) && (_keysHeld e1 == _keysHeld e2) +instance Ord Explorer where + e1 `compare` e2 = + ((_position e1) `compare` (_position e2)) + <> ((_keysHeld e1) `compare` (_keysHeld e2)) -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 Cave = S.Set Position -data CaveComplex = CaveComplex { _cave :: Cave - , _keys :: PointOfInterest +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 + +type Connection = (Char, Char) +data CaveEdge = CaveEdge { _connections :: Connection + , _keysRequired :: S.Set Char + , _distance :: Int + } deriving (Eq, Ord, Show) +makeLenses ''CaveEdge + +type Cave = S.Set 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 +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) 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 - --- -- part1 :: CaveComplex -> Explorer -> Maybe Agendum --- part1 cave explorer = keySeq (fromJust result) --- where result = runReader (searchCave explorer) cave + let (ccE, startPosition) = buildCaveComplex text + -- print ccE + -- print $ S.size $ edgeC $ _caveE ccE + -- print $ S.size $ _cave $ contractCave ccE [startPosition] + -- putStrLn $ showContracted $ contractCave ccE [startPosition] + -- let (re, ce) = startPosition + -- let startPositions = [(re - 1, ce - 1), (re - 1, ce + 1), (re + 1 , ce - 1), (re + 1, ce + 1)] + -- let cavern0 = ccE ^. caveE + -- let cavern = cavern0 `S.difference` [(re, ce), (re + 1, ce), (re - 1, ce), (re, ce + 1), (re, ce - 1)] + -- let caveComplex = ccE & caveE .~ cavern + -- let cc = contractCave caveComplex startPositions + -- putStrLn $ showContracted cc + print $ part1 ccE startPosition + print $ part2 ccE startPosition + +-- edgeC ec = S.foldl' ecAdd S.empty ec +-- where ecAdd es n = S.union (eds n) es +-- eds n = S.map (\m -> S.fromList [n, m]) $ nbrs n +-- nbrs n = S.intersection ec $ possibleNeighbours n + + +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 :: 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 = caveComplex0 ^. caveE + 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 :: 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} + rows = lines text +buildCaveRow :: (ExpandedCaveComplex, Position) -> (Integer, String) -> (ExpandedCaveComplex, Position) +buildCaveRow (cc, explorers) (r, row) = foldl' (buildCaveCell r) (cc, explorers) $ zip [0..] row -part2 :: CaveComplex -> Explorer1 -> Int -part2 caveComplex0 explorer1 = maybe 0 (( + 1) . _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 -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 +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), startPosition) -- (cc' { _keysE = M.insert here char $ _keysE cc'}, startPosition) + | isUpper char = (cc' & doors %~ (M.insert here char), startPosition) + | otherwise = (cc, startPosition) + where cc' = cc & caveE %~ (S.insert here) + here = (r, c) -searchCave :: ExplorerC e => e -> CaveContext (Maybe (Agendum e)) +mkConnection :: Char -> Char -> Connection +mkConnection a b = if a < b then (a, b) else (b, a) + +edgeTouches :: Char -> CaveEdge -> Bool +edgeTouches x e + | x == a = True + | x == b = True + | otherwise = False + where (a, b) = e ^. connections + +anyEdgeTouch :: Keys -> CaveEdge -> Bool +anyEdgeTouch xs e = S.foldl' (\t x -> t || (edgeTouches x e)) False xs +-- anyEdgeTouch xs e = any (\x -> edgeTouches x e) $ S.toList xs + +edgeOther :: Char -> CaveEdge -> Char +edgeOther x e + | x == a = b + | otherwise = a + where (a, b) = e ^. connections + + + +contractCave :: ExpandedCaveComplex -> [Position] -> CaveComplex +contractCave expanded startPositions = cavern + where explorers = M.fromList $ zip startPositions $ map intToDigit [0..] + starts = M.union explorers (expanded ^. keysE) + cavern0 = CaveComplex {_cave = S.empty, _keys = S.fromList $ M.elems (expanded ^. keysE)} + cavern = M.foldrWithKey (contractFrom expanded) cavern0 starts + +contractFrom :: ExpandedCaveComplex -> Position -> Char -> CaveComplex -> CaveComplex +contractFrom expanded startPos startKey cc = cc { _cave = S.union (_cave cc) reachables } + where reachables = reachableFrom [(startPos, edge0)] S.empty expanded' startKey + edge0 = CaveEdge {_connections = ('0', '0'), _keysRequired = S.empty, _distance = 0} + expanded' = expanded & keysE %~ (M.delete startPos) + +reachableFrom :: [(Position, CaveEdge)] -> (S.Set Position) -> ExpandedCaveComplex -> Char -> Cave +reachableFrom [] _closed _expanded _startKey = S.empty +reachableFrom ((here, edge):boundary) closed expanded startKey + | here `S.member` closed = reachableFrom boundary closed expanded startKey + | here `M.member` ks = S.insert edgeK $ reachableFrom boundary closed' expanded startKey + | here `M.member` drs = reachableFrom boundaryD closed' expanded startKey + | otherwise = reachableFrom boundary' closed' expanded startKey + where nbrs0 = S.intersection (expanded ^. caveE) $ possibleNeighbours here + nbrs = S.difference nbrs0 closed + closed' = S.insert here closed + ks = expanded ^. keysE + drs = expanded ^. doors + edge' = edge & distance %~ (+1) + edgeK = edge & connections .~ (mkConnection startKey (ks!here)) + edgeD = edge' & keysRequired %~ (S.insert (toLower (drs!here))) + 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 - -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 - -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) - - -initAgenda :: ExplorerC e => e -> CaveContext (Agenda e) +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 +216,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 +230,55 @@ 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) + , _cost = (new ^. travelled) + predicted } - - -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 +successors :: Explorer -> CaveContext (Q.Seq Explorer) +successors explorer = + do let heres = explorer ^. position + cavern <- asks _cave + let kH = explorer ^. keysHeld + let locations0 = S.filter (\e -> anyEdgeTouch heres e) cavern + let locations1 = S.filter (\e -> S.null ((e ^. keysRequired) `S.difference` kH)) locations0 + let succs = S.foldr' (\e q -> (extendExplorer explorer 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 = S.filter (\e -> anyEdgeTouch heres e) cavern + let unfoundEdges = S.filter (\e -> not $ anyEdgeTouch kH e) unfoundEdges0 + let furthest = S.findMax $ S.insert 0 $ S.map _distance 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 -> CaveEdge -> Explorer +extendExplorer explorer edge = + explorer & position .~ pos' + & keysHeld .~ kH' + & travelled .~ d' + where here = S.findMin $ S.filter (\p -> edgeTouches p edge) (explorer ^. position) + there = edgeOther here edge + kH' = S.insert there (explorer ^. keysHeld) + d' = (explorer ^. travelled) + (edge ^. distance) + pos' = S.insert there $ S.delete here (explorer ^. position) + + +showContracted cc = "graph Cave {\n" ++ bulk ++ "\n}" + where cavern = cc ^. cave + bulk = S.foldr (\e s -> (showEdge e) ++ s) "" cavern + +showEdge e = [h] ++ " -- " ++ [t] ++ " [ label = \"" ++ (edgeLabel e) ++ "\"];\n" + where edgeLabel e = (S.toList (e ^. keysRequired)) ++ ", " ++ (show (e ^. distance)) + (h, t) = e ^. connections