--- /dev/null
+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"];
+}
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
} 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
} 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
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
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
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)
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)
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
projects / advent-of-code-19.git / commitdiff