X-Git-Url: https://git.njae.me.uk/?p=advent-of-code-19.git;a=blobdiff_plain;f=advent18%2Fsrc%2Fadvent18.hs;h=ac0c1da98b4bcda08c0824c57838755c8537b8ad;hp=a31c17a921901efb56cd3af9017166003f4bbe28;hb=4a61ffa7679d3214f2fc32cef607279ca8835131;hpb=7d62744864f29867c8410ec6f2bbbfd8a2c7e043 diff --git a/advent18/src/advent18.hs b/advent18/src/advent18.hs index a31c17a..ac0c1da 100644 --- a/advent18/src/advent18.hs +++ b/advent18/src/advent18.hs @@ -3,16 +3,18 @@ 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.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 @@ -21,10 +23,21 @@ type Keys = S.Set Char type PointOfInterest = M.Map Position Char -data Explorer = Explorer { _position :: Position - , _keysHeld :: Keys - } deriving (Eq, Ord, Show) -type ExploredStates = S.Set 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 + + +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 @@ -33,12 +46,74 @@ data CaveComplex = CaveComplex { _cave :: Cave } deriving (Eq, Ord, Show) type CaveContext = Reader CaveComplex -data Agendum = Agendum { _current :: Explorer - , _trail :: Q.Seq Explorer +data Agendum e = Agendum { _current :: e + , _trail :: Q.Seq e , _cost :: Int} deriving (Show, Eq) -type Agenda = P.MinPQueue Int Agendum -type Candidates = S.Set (Int, Agendum) - +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 } @@ -49,8 +124,9 @@ main = do -- print cc -- print explorer print $ part1 cc explorer + print $ part2 cc explorer -part1 :: CaveComplex -> Explorer -> Int +part1 :: ExplorerC e => CaveComplex -> e -> Int part1 cave explorer = maybe 0 (( + 1) . _cost ) result where result = runReader (searchCave explorer) cave @@ -59,13 +135,23 @@ part1 cave explorer = maybe 0 (( + 1) . _cost ) result -- where result = runReader (searchCave explorer) cave -keySeq :: Agendum -> Q.Seq Keys +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 _keysHeld $ _trail agendum - kdiff = fmap (uncurry S.difference) $ Q.zip ((_keysHeld $ _current agendum) <| keyss) keyss + where keyss = fmap keysHeldE $ _trail agendum + kdiff = fmap (uncurry S.difference) $ Q.zip ((keysHeldE $ _current agendum) <| keyss) keyss -searchCave :: Explorer -> CaveContext (Maybe Agendum) +searchCave :: ExplorerC e => e -> CaveContext (Maybe (Agendum e)) searchCave explorer = do agenda <- initAgenda explorer aStar agenda S.empty @@ -73,14 +159,14 @@ searchCave explorer = buildCaveComplex text = foldl' buildCaveRow (cc0, explorer0) $ zip [0..] rows where cc0 = CaveComplex {_cave = S.empty, _keys = M.empty, _doors = M.empty} - explorer0 = Explorer { _position = (0, 0), _keysHeld = S.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 { _position = here }) + | 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) @@ -88,15 +174,13 @@ buildCaveCell r (cc, explorer) (c, char) here = (r, c) - - -initAgenda :: Explorer -> CaveContext Agenda +initAgenda :: ExplorerC e => e -> CaveContext (Agenda e) initAgenda explorer = do cost <- estimateCost explorer return $ P.singleton cost Agendum { _current = explorer, _trail = Q.empty, _cost = cost} -aStar :: Agenda -> ExploredStates -> CaveContext (Maybe Agendum) +aStar :: ExplorerC 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 @@ -115,13 +199,13 @@ aStar agenda closed else aStar newAgenda (S.insert reached closed) -isGoal :: Explorer -> CaveContext Bool +isGoal :: ExplorerC e => e -> CaveContext Bool isGoal explorer = do keys <- asks (S.fromList . M.elems . _keys) - return $ keys == _keysHeld explorer + return $ keys == keysHeldE explorer -candidates :: Agendum -> ExploredStates -> CaveContext (Q.Seq Agendum) +candidates :: ExplorerC e => Agendum e -> ExploredStates e -> CaveContext (Q.Seq (Agendum e)) candidates agendum closed = do let candidate = _current agendum let previous = _trail agendum @@ -129,7 +213,7 @@ candidates agendum closed = let nonloops = Q.filter (\s -> not $ s `S.member` closed) succs mapM (makeAgendum candidate previous) nonloops -makeAgendum :: Explorer -> (Q.Seq Explorer) -> Explorer -> CaveContext Agendum +makeAgendum :: ExplorerC e => e -> (Q.Seq e) -> e -> CaveContext (Agendum e) makeAgendum candidate previous new = do cost <- estimateCost new return Agendum { _current = new @@ -137,17 +221,6 @@ makeAgendum candidate previous new = , _cost = cost + (Q.length previous) } -successors :: Explorer -> CaveContext (Q.Seq Explorer) -successors explorer = - do let here = _position explorer - let locations0 = possibleNeighbours here - cave <- asks _cave - keys <- asks _keys - doors <- asks _doors - let keysHeld = _keysHeld explorer - let locations1 = Q.filter (`S.member` cave) locations0 - let locations2 = Q.filter (hasKeyFor doors keysHeld) locations1 - return $ fmap (\l -> explorer { _position = l, _keysHeld = pickupKey keys keysHeld l}) locations2 hasKeyFor :: PointOfInterest -> Keys -> Position -> Bool @@ -166,22 +239,6 @@ pickupKey keys held here = maybe held (`S.insert` held) $ M.lookup here keys -- else held -estimateCost :: Explorer -> CaveContext Int -estimateCost explorer = -- return 0 - do keys <- asks _keys - let (r, c) = _position explorer - let unfoundKeys = M.filter (`S.notMember` (_keysHeld explorer)) keys - let minR = 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 M.null unfoundKeys - then return 0 - else return $ fromIntegral (spanR + spanC) - -- return $ sum $ map (manhattan here) $ M.keys unfoundKeys - spanV this minV maxV | this < minV = maxV - this | this > maxV = this - minV @@ -193,3 +250,17 @@ 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