From f0d22f1976f3c65c6adc251a637b106ec3e002e3 Mon Sep 17 00:00:00 2001 From: Neil Smith Date: Fri, 3 Jan 2020 16:39:46 +0000 Subject: [PATCH] Finished day 18 --- advent18/advent18.dot | 78 +++++++++ advent18/advent184.dot | 49 ++++++ advent18/advent18x4.dot | 22 +++ advent18/package.yaml | 11 -- advent18/src/advent18.hs | 33 +++- advent18/src/advent18class.hs | 308 --------------------------------- advent18/src/advent18direct.hs | 24 +-- 7 files changed, 185 insertions(+), 340 deletions(-) create mode 100644 advent18/advent18.dot create mode 100644 advent18/advent184.dot create mode 100644 advent18/advent18x4.dot delete mode 100644 advent18/src/advent18class.hs diff --git a/advent18/advent18.dot b/advent18/advent18.dot new file mode 100644 index 0000000..39bbf0a --- /dev/null +++ b/advent18/advent18.dot @@ -0,0 +1,78 @@ +graph Cave { +0 -- d [ label = ", 64"]; +0 -- g [ label = "t, 28"]; +0 -- h [ label = "m, 210"]; +0 -- i [ label = "lm, 226"]; +0 -- m [ label = "g, 182"]; +0 -- p [ label = "sx, 164"]; +0 -- q [ label = "o, 134"]; +0 -- s [ label = ", 50"]; +0 -- t [ label = ", 16"]; +0 -- x [ label = "n, 110"]; +a -- m [ label = "ceuw, 146"]; +a -- y [ label = "eu, 66"]; +b -- w [ label = "a, 86"]; +c -- i [ label = ", 22"]; +c -- w [ label = ", 14"]; +d -- g [ label = "t, 90"]; +d -- h [ label = "m, 274"]; +d -- i [ label = "lm, 290"]; +d -- m [ label = "g, 244"]; +d -- p [ label = "sx, 128"]; +d -- q [ label = "o, 196"]; +d -- s [ label = ", 112"]; +d -- t [ label = ", 52"]; +d -- x [ label = "n, 172"]; +e -- r [ label = ", 94"]; +e -- u [ label = "y, 62"]; +e -- x [ label = ", 198"]; +f -- k [ label = "v, 34"]; +g -- h [ label = "mt, 236"]; +g -- i [ label = "lmt, 252"]; +g -- m [ label = "gt, 210"]; +g -- p [ label = "stx, 190"]; +g -- q [ label = "ot, 118"]; +g -- s [ label = "t, 78"]; +g -- t [ label = "t, 42"]; +g -- x [ label = "nt, 94"]; +h -- i [ label = "l, 32"]; +h -- m [ label = "gm, 390"]; +h -- p [ label = "msx, 374"]; +h -- q [ label = "mo, 342"]; +h -- s [ label = "m, 258"]; +h -- t [ label = "m, 226"]; +h -- x [ label = "mn, 318"]; +i -- m [ label = "glm, 406"]; +i -- p [ label = "lmsx, 390"]; +i -- q [ label = "lmo, 358"]; +i -- s [ label = "lm, 274"]; +i -- t [ label = "lm, 242"]; +i -- x [ label = "lmn, 334"]; +j -- o [ label = ", 48"]; +k -- z [ label = "r, 28"]; +l -- p [ label = ", 36"]; +m -- p [ label = "gsx, 344"]; +m -- q [ label = "go, 316"]; +m -- s [ label = "g, 228"]; +m -- t [ label = "g, 196"]; +m -- x [ label = "gn, 292"]; +m -- y [ label = "cw, 96"]; +n -- o [ label = ", 18"]; +n -- s [ label = "d, 30"]; +p -- q [ label = "osx, 296"]; +p -- s [ label = "sx, 212"]; +p -- t [ label = "sx, 152"]; +p -- x [ label = "nsx, 272"]; +p -- z [ label = ", 200"]; +q -- s [ label = "o, 184"]; +q -- t [ label = "o, 148"]; +q -- x [ label = "no, 100"]; +r -- u [ label = "y, 128"]; +r -- v [ label = "k, 36"]; +r -- x [ label = ", 264"]; +s -- t [ label = ", 64"]; +s -- x [ label = "n, 160"]; +t -- x [ label = "n, 124"]; +u -- x [ label = "y, 184"]; + +} diff --git a/advent18/advent184.dot b/advent18/advent184.dot new file mode 100644 index 0000000..ebdd59c --- /dev/null +++ b/advent18/advent184.dot @@ -0,0 +1,49 @@ +graph Cave1 { + +0 -- d [ label = ", 62"]; +0 -- p [ label = "sx, 162"]; +0 -- t [ label = ", 14"]; +1 -- g [ label = "t, 26"]; +1 -- q [ label = "o, 132"]; +1 -- x [ label = "n, 108"]; + +d -- p [ label = "sx, 128"]; +d -- t [ label = ", 52"]; +f -- k [ label = "v, 34"]; +k -- z [ label = "r, 28"]; +l -- p [ label = ", 36"]; +p -- t [ label = "sx, 152"]; +p -- z [ label = ", 200"]; + +e -- r [ label = ", 94"]; +e -- u [ label = "y, 62"]; +e -- x [ label = ", 198"]; +g -- q [ label = "ot, 118"]; +g -- x [ label = "nt, 94"]; +q -- x [ label = "no, 100"]; +r -- u [ label = "y, 128"]; +r -- v [ label = "k, 36"]; +r -- x [ label = ", 264"]; +u -- x [ label = "y, 184"]; + + +2 -- m [ label = "g, 180"]; +2 -- s [ label = ", 48"]; +a -- m [ label = "ceuw, 146"]; +a -- y [ label = "eu, 66"]; +m -- s [ label = "g, 228"]; +m -- y [ label = "cw, 96"]; +n -- o [ label = ", 18"]; +n -- s [ label = "d, 30"]; + +3 -- h [ label = "m, 208"]; +3 -- i [ label = "lm, 224"]; +b -- w [ label = "a, 86"]; +c -- i [ label = ", 22"]; +c -- w [ label = ", 14"]; +h -- i [ label = "l, 32"]; +j -- o [ label = ", 48"]; + + + +} \ No newline at end of file diff --git a/advent18/advent18x4.dot b/advent18/advent18x4.dot new file mode 100644 index 0000000..8aeaa7f --- /dev/null +++ b/advent18/advent18x4.dot @@ -0,0 +1,22 @@ +graph Cave { +0 -- a [ label = ", 1"]; +0 -- e [ label = ", 1"]; +1 -- c [ label = "b, 2"]; +1 -- h [ label = "e, 4"]; +2 -- m [ label = "n, 4"]; +2 -- n [ label = "kl, 4"]; +3 -- i [ label = "h, 2"]; +3 -- k [ label = "g, 7"]; +a -- b [ label = ", 1"]; +a -- e [ label = ", 2"]; +b -- d [ label = "c, 2"]; +c -- h [ label = "be, 6"]; +c -- l [ label = "ij, 4"]; +d -- g [ label = "f, 2"]; +e -- f [ label = "d, 3"]; +i -- k [ label = "gh, 9"]; +j -- k [ label = ", 1"]; +m -- n [ label = "kln, 8"]; +n -- o [ label = "m, 2"]; + +} diff --git a/advent18/package.yaml b/advent18/package.yaml index f503113..a93913e 100644 --- a/advent18/package.yaml +++ b/advent18/package.yaml @@ -71,14 +71,3 @@ executables: - pqueue - mtl - 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 ad8dd55..eb6219f 100644 --- a/advent18/src/advent18.hs +++ b/advent18/src/advent18.hs @@ -20,19 +20,19 @@ type Keys = S.Set Char type PointOfInterest = M.Map Position Char data Explorer = Explorer { _position :: S.Set Char - , _keysHeld :: Keys - , _travelled :: Int - } deriving (Show) + , _keysHeld :: Keys + , _travelled :: Int + } 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) + e1 `compare` e2 = + ((_position e1) `compare` (_position e2)) + <> ((_keysHeld e1) `compare` (_keysHeld e2)) + type ExploredStates = S.Set Explorer @@ -70,10 +70,24 @@ main = do text <- readFile "data/advent18.txt" let (ccE, startPosition) = buildCaveComplex text -- print ccE - -- print $ contractCave ccE [startPosition] + -- 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 @@ -126,6 +140,7 @@ edgeTouches x e 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 @@ -264,6 +279,6 @@ 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" +showEdge e = [h] ++ " -- " ++ [t] ++ " [ label = \"" ++ (edgeLabel e) ++ "\"];\n" where edgeLabel e = (S.toList (e ^. keysRequired)) ++ ", " ++ (show (e ^. distance)) (h, t) = e ^. connections diff --git a/advent18/src/advent18class.hs b/advent18/src/advent18class.hs deleted file mode 100644 index a06e6f1..0000000 --- a/advent18/src/advent18class.hs +++ /dev/null @@ -1,308 +0,0 @@ -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 3d6125e..346e61f 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, Show e) => ExplorerC e where +class (Eq e, Ord e, Show e) => Explorer e where successors :: e -> CaveContext (Q.Seq e) estimateCost :: e -> CaveContext Int -- positionE :: e -> Position @@ -52,7 +52,7 @@ data Agendum e = Agendum { _current :: e type Agenda e = P.MinPQueue Int (Agendum e) -- type Candidates e = S.Set (Int, Agendum e) -instance ExplorerC Explorer1 where +instance Explorer Explorer1 where successors explorer = do let here = _position1 explorer let locations0 = possibleNeighbours here @@ -84,7 +84,7 @@ instance ExplorerC Explorer1 where keysHeldE = _keysHeld1 emptyExplorer = Explorer1 { _position1 = (0, 0), _keysHeld1 = S.empty } -instance ExplorerC Explorer4 where +instance Explorer Explorer4 where successors explorer = do let rawHeres = _position4 explorer let heres = setToSeq $ allSplits rawHeres @@ -119,14 +119,14 @@ instance ExplorerC Explorer4 where main :: IO () main = do - text <- readFile "data/advent18x.txt" + 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 :: Explorer e => CaveComplex -> e -> Int part1 cave explorer = maybe 0 (( + 1) . _cost ) result where result = runReader (searchCave explorer) cave @@ -145,13 +145,13 @@ part2 caveComplex0 explorer1 = maybe 0 (( + 1) . _cost ) result 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 :: Explorer 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 -searchCave :: ExplorerC e => e -> CaveContext (Maybe (Agendum e)) +searchCave :: Explorer e => e -> CaveContext (Maybe (Agendum e)) searchCave explorer = do agenda <- initAgenda explorer aStar agenda S.empty @@ -174,13 +174,13 @@ buildCaveCell r (cc, explorer) (c, char) here = (r, c) -initAgenda :: ExplorerC e => e -> CaveContext (Agenda e) +initAgenda :: Explorer e => e -> CaveContext (Agenda e) 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 :: Explorer e => Agenda e -> ExploredStates e -> CaveContext (Maybe (Agendum e)) -- aStar [] _ = Agendum {current=buildingTest, trail=[], cost=0} aStar agenda closed -- | trace ("Peeping " ++ (show $ fst $ P.findMin agenda) ++ ": " ++ (show reached) ++ " <- " ++ (show $ toList $ Q.take 1 $ _trail $ currentAgendum) ++ " :: " ++ (show newAgenda)) False = undefined @@ -200,13 +200,13 @@ aStar agenda closed else aStar newAgenda (S.insert reached closed) -isGoal :: ExplorerC e => e -> CaveContext Bool +isGoal :: Explorer e => e -> CaveContext Bool isGoal explorer = do keys <- asks (S.fromList . M.elems . _keys) return $ keys == keysHeldE explorer -candidates :: ExplorerC e => Agendum e -> ExploredStates e -> CaveContext (Q.Seq (Agendum e)) +candidates :: Explorer 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 @@ -215,7 +215,7 @@ 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 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 -- 2.34.1