-- 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
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
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
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
projects / advent-of-code-19.git / blobdiff