From a9dd0c4031eae1a3b5aa8a637093eb0419a31930 Mon Sep 17 00:00:00 2001 From: Neil Smith Date: Wed, 1 Jan 2020 13:08:44 +0000 Subject: [PATCH] Further cleanup, increased use of lenses --- advent18/advent18x.dot | 47 +++++++++++ advent18/src/advent18.hs | 172 ++++++++++++++++++++------------------- 2 files changed, 136 insertions(+), 83 deletions(-) create mode 100644 advent18/advent18x.dot diff --git a/advent18/advent18x.dot b/advent18/advent18x.dot new file mode 100644 index 0000000..a4735da --- /dev/null +++ b/advent18/advent18x.dot @@ -0,0 +1,47 @@ +graph Cave { + K=2; + splines=true; +0 -- a [ label = ", 3"]; +0 -- c [ label = "b, 4"]; +0 -- e [ label = ", 3"]; +0 -- h [ label = "e, 6"]; +0 -- i [ label = "h, 4"]; +0 -- k [ label = "g, 9"]; +0 -- m [ label = "n, 6"]; +0 -- n [ label = "kl, 6"]; +a -- b [ label = ", 1"]; +a -- c [ label = "b, 5"]; +a -- e [ label = ", 2"]; +a -- h [ label = "e, 7"]; +a -- i [ label = "h, 7"]; +a -- k [ label = "g, 12"]; +a -- m [ label = "n, 7"]; +a -- n [ label = "kl, 7"]; +b -- d [ label = "c, 2"]; +c -- e [ label = "b, 5"]; +c -- h [ label = "be, 6"]; +c -- i [ label = "bh, 6"]; +c -- k [ label = "bg, 11"]; +c -- l [ label = "ij, 4"]; +c -- m [ label = "bn, 10"]; +c -- n [ label = "bkl, 10"]; +d -- g [ label = "f, 2"]; +e -- f [ label = "d, 3"]; +e -- h [ label = "e, 7"]; +e -- i [ label = "h, 7"]; +e -- k [ label = "g, 12"]; +e -- m [ label = "n, 7"]; +e -- n [ label = "kl, 7"]; +h -- i [ label = "eh, 8"]; +h -- k [ label = "eg, 13"]; +h -- m [ label = "en, 12"]; +h -- n [ label = "ekl, 12"]; +i -- k [ label = "gh, 9"]; +i -- m [ label = "hn, 8"]; +i -- n [ label = "hkl, 8"]; +j -- k [ label = ", 1"]; +k -- m [ label = "gn, 13"]; +k -- n [ label = "gkl, 13"]; +m -- n [ label = "kln, 8"]; +n -- o [ label = "m, 2"]; +} diff --git a/advent18/src/advent18.hs b/advent18/src/advent18.hs index 4267fac..ad8dd55 100644 --- a/advent18/src/advent18.hs +++ b/advent18/src/advent18.hs @@ -7,14 +7,11 @@ 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 @@ -28,6 +25,15 @@ data Explorer = Explorer { _position :: S.Set Char } deriving (Show) makeLenses ''Explorer +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) + type ExploredStates = S.Set Explorer type ExpandedCave = S.Set Position @@ -37,13 +43,14 @@ data ExpandedCaveComplex = ExpandedCaveComplex { _caveE :: ExpandedCave } deriving (Eq, Ord, Show) makeLenses ''ExpandedCaveComplex -data CaveEdge = CaveEdge { _keysRequired :: S.Set Char +type Connection = (Char, Char) +data CaveEdge = CaveEdge { _connections :: Connection + , _keysRequired :: S.Set Char , _distance :: Int } deriving (Eq, Ord, Show) makeLenses ''CaveEdge -type EdgeKey = (Char, Char) -type Cave = M.Map EdgeKey CaveEdge +type Cave = S.Set CaveEdge data CaveComplex = CaveComplex { _cave :: Cave , _keys :: S.Set Char @@ -58,61 +65,12 @@ data Agendum = Agendum { _current :: Explorer 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 (ccE, startPosition) = buildCaveComplex text -- print ccE + -- print $ contractCave ccE [startPosition] print $ part1 ccE startPosition print $ part2 ccE startPosition @@ -127,7 +85,7 @@ 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 + 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 @@ -135,12 +93,10 @@ part2 caveComplex0 (re, ce) = maybe 0 _cost result 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) @@ -151,57 +107,62 @@ buildCaveCell :: Integer -> (ExpandedCaveComplex, Position) -> (Integer, Char) - 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) + | 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 $ _caveE cc } + where cc' = cc & caveE %~ (S.insert here) here = (r, c) +mkConnection :: Char -> Char -> Connection +mkConnection a b = if a < b then (a, b) else (b, a) -mkEdgeKey a b = if a < b then (a, b) else (b, a) - -edgeTouches x (a, b) +edgeTouches :: Char -> CaveEdge -> Bool +edgeTouches x e | x == a = True | x == b = True | otherwise = False + where (a, b) = e ^. connections -anyEdgeTouch xs p = S.foldl' (\t x -> t || (edgeTouches x p)) False xs +anyEdgeTouch :: Keys -> CaveEdge -> Bool +anyEdgeTouch xs e = S.foldl' (\t x -> t || (edgeTouches x e)) False xs -edgeOther x (a, b) +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 $ _keysE expanded - cavern0 = CaveComplex {_cave = M.empty, _keys = S.fromList $ M.elems $ _keysE expanded} + 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 = M.union (_cave cc) reachables } +contractFrom expanded startPos startKey cc = cc { _cave = S.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} + 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 = M.empty +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 = M.insert edgeKey edge $ 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 (_caveE expanded) $ possibleNeighbours here + where nbrs0 = S.intersection (expanded ^. caveE) $ 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')} + 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) @@ -260,4 +221,49 @@ makeAgendum candidate previous new = return Agendum { _current = new , _trail = candidate <| previous , _cost = (new ^. travelled) + predicted - } \ No newline at end of file + } + +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 = (show h) ++ " -- " ++ (show t) ++ " [ label = \"" ++ (edgeLabel e) ++ "\"];\n" + where edgeLabel e = (S.toList (e ^. keysRequired)) ++ ", " ++ (show (e ^. distance)) + (h, t) = e ^. connections -- 2.34.1