advent20/src/advent20.hs

   1 import Debug.Trace
   2
   3 -- import qualified Data.Text.IO as TIO
   4
   5 -- import qualified Data.Map.Strict as M
   6 -- import Data.Map.Strict ((!))
   7 import qualified Data.PQueue.Prio.Min as P
   8 import qualified Data.Set as S
   9 import qualified Data.Sequence as Q
  10 import Data.Sequence ((<|)) -- , (|>), (><))
  11 import Data.Foldable (foldl', any, sum) -- (toList, foldr', foldl', all)
  12 import Data.Char
  13 import Control.Monad.Reader
  14 import Control.Lens hiding ((<|), (|>))
  15 import Data.Maybe (fromMaybe)
  16
  17
  18
  19 type Position = (Int, Int) -- r, c
  20
  21 data Portal = Portal { _label :: String
  22                      , _position :: Position
  23                      } deriving (Eq, Ord, Show)
  24 makeLenses ''Portal
  25
  26 type Portals = S.Set Portal
  27
  28
  29 type ExpandedMaze = S.Set Position
  30 data MazeComplex = MazeComplex
  31     { _mazeE :: ExpandedMaze
  32     , _portalsE :: Portals
  33     , _portalLocs :: S.Set Position
  34     } deriving (Eq, Ord, Show)
  35 makeLenses ''MazeComplex
  36
  37 type EdgeConnects = (Portal, Portal)
  38 data EdgeType = Walk | Teleport deriving (Eq, Ord, Show)
  39
  40 data Edge = Edge { _connects :: EdgeConnects
  41                  , _edgeType :: EdgeType
  42                  , _distance :: Int
  43                  } deriving (Eq, Ord, Show)
  44 makeLenses ''Edge
  45
  46 type Maze = S.Set Edge
  47
  48 type MazeContext = Reader Maze
  49
  50 type ExploredStates = S.Set Portal
  51
  52 data Agendum = Agendum { _current :: Portal
  53                        , _trail :: Q.Seq Edge
  54                        , _cost :: Int} deriving (Show, Eq)
  55 makeLenses ''Agendum
  56
  57 type Agenda = P.MinPQueue Int (Agendum)
  58
  59
  60 main :: IO ()
  61 main = do
  62         -- text <- readFile "data/advent20a.txt"
  63         -- let mc = buildComplex text
  64         -- print mc
  65         -- let maze = contractMaze mc
  66         -- print maze
  67         maze <- setup
  68         putStrLn $ showContracted maze
  69         print $ part1 maze
  70         -- print $ S.size $ edgeC $ _caveE ccE
  71         -- print $ S.size $ _cave $ contractCave ccE [startPosition]
  72         -- putStrLn $ showContracted $ contractCave ccE [startPosition]
  73         -- let (re, ce) = startPosition
  74         -- let startPositions = [(re - 1, ce - 1), (re - 1, ce + 1), (re + 1 , ce - 1), (re + 1, ce + 1)]
  75         -- let cavern0 = ccE ^. caveE
  76         -- let cavern = cavern0 `S.difference` [(re, ce), (re + 1, ce), (re - 1, ce), (re, ce + 1), (re, ce - 1)]
  77         -- let caveComplex = ccE & caveE .~ cavern
  78         -- let cc = contractCave caveComplex startPositions
  79         -- putStrLn $ showContracted cc
  80         -- print $ part1 ccE startPosition
  81         -- print $ part2 ccE startPosition
  82
  83 -- edgeC ec = S.foldl' ecAdd S.empty ec
  84 --     where ecAdd es n = S.union (eds n) es
  85 --           eds n = S.map (\m -> S.fromList [n, m]) $ nbrs n
  86 --           nbrs n = S.intersection ec $ possibleNeighbours n
  87
  88
  89
  90 setup = do
  91         text <- readFile "data/advent20.txt"
  92         let mc = buildComplex text
  93         -- print mc
  94         return $  contractMaze mc
  95         -- print maze
  96
  97
  98 -- part1 :: Maze -> Int
  99 part1 maze = result -- maybe 0 _cost result
 100     where result = runReader searchMaze maze
 101
 102
 103
 104 buildComplex :: String -> MazeComplex
 105 buildComplex text = mc & portalLocs .~ pLocs
 106     where mc = foldl' (buildMazeRow rows) mc0 [0..l]
 107           mc0 = MazeComplex {_mazeE = S.empty, _portalsE = S.empty, _portalLocs = S.empty}
 108           rows = lines text
 109           l = length rows - 1
 110           pLocs = S.map _position (mc ^. portalsE)
 111
 112 buildMazeRow :: [String] -> MazeComplex -> Int -> MazeComplex
 113 buildMazeRow rows mc r = foldl' (buildMazeCell rows r) mc [0..l]
 114     where l = length (rows!!r) - 1
 115
 116
 117 buildMazeCell :: [String] -> Int -> MazeComplex -> Int -> MazeComplex
 118 buildMazeCell rows r mc c
 119     | char == '.' = mc'
 120     | isUpper char = mc & portalsE .~ portals'
 121     | otherwise = mc
 122     where char = (rows!!r)!!c
 123           mc' = mc & mazeE %~ (S.insert here)
 124           here = (r, c)
 125           portals' = makePortal (mc ^. portalsE) rows char r c
 126
 127
 128 makePortal portals rows hc r c
 129     | isUpper rc = if pr == '.'
 130                    then S.insert (Portal [hc, rc] (r, c + 2)) portals
 131                    else S.insert (Portal [hc, rc] (r, c - 1)) portals
 132     | isUpper dc = if pd == '.'
 133                    then S.insert (Portal [hc, dc] (r + 2, c)) portals
 134                    else S.insert (Portal [hc, dc] (r - 1, c)) portals
 135     | otherwise = portals
 136     where -- lc = charAt rows r (c - 1)
 137           rc = charAt rows r (c + 1)
 138           -- uc = charAt rows (r - 1) c
 139           dc = charAt rows (r + 1) c
 140           -- pu = charAt rows (r - 1) c
 141           pd = charAt rows (r + 2) c
 142           -- pl = charAt rows r (c - 1)
 143           pr = charAt rows r (c + 2)
 144
 145 charAt :: [String] -> Int -> Int -> Char
 146 charAt rows r c = atDef ' ' (atDef "" rows r) c
 147
 148 atDef :: a -> [a] -> Int -> a
 149 atDef x xs i = fromMaybe x $ atMaybe xs i
 150 -- atDef x = (fromMaybe x) . atMaybe
 151
 152 atMaybe :: [a] -> Int -> Maybe a
 153 atMaybe xs i
 154     | i < 0 = Nothing
 155     | i >= (length xs) = Nothing
 156     | otherwise = Just (xs!!i)
 157
 158
 159 contractMaze :: MazeComplex -> Maze
 160 contractMaze expanded = S.union mazeW mazeP
 161     where starts = expanded ^. portalsE
 162           mazeW = S.foldr (contractFrom expanded) S.empty starts
 163           mazeP = S.foldr (addWarp starts) S.empty starts
 164
 165
 166 contractFrom :: MazeComplex -> Portal -> Maze -> Maze
 167 contractFrom expanded start maze0 = S.union maze0 reachables
 168     where startPos = start ^. position
 169           reachables = reachableFrom [(startPos, 0)] S.empty expanded' start
 170           expanded' = expanded & portalsE %~ (S.delete start)
 171                                & portalLocs %~ (S.delete startPos)
 172                                -- & mazeE %~ (S.delete startPos)
 173
 174 reachableFrom :: [(Position, Int)] -> (S.Set Position) -> MazeComplex -> Portal -> Maze
 175 reachableFrom [] _closed _expanded _start = S.empty
 176 reachableFrom ((here, distance):boundary) closed expanded start
 177     | here `S.member` closed = reachableFrom boundary closed expanded start
 178     | here `S.member` ps = S.insert edge $ reachableFrom boundary closed' expanded start
 179     | otherwise = reachableFrom boundary' closed' expanded start
 180     where nbrs0 = S.intersection (expanded ^. mazeE) $ possibleNeighbours here
 181           nbrs = S.difference nbrs0 closed
 182           closed' = S.insert here closed
 183           ps = expanded ^. portalLocs
 184           other = S.findMin $ S.filter (\p -> p ^. position == here) $ expanded ^. portalsE
 185           edge = Edge { _connects = mkConnection start other, _edgeType = Walk, _distance = distance }
 186           neighbours = S.map (\n -> (n, distance + 1)) nbrs
 187           boundary' = boundary ++ (S.toAscList neighbours)
 188
 189
 190 addWarp :: Portals -> Portal -> Maze -> Maze
 191 addWarp portals portal warps
 192     | S.null others = warps
 193     | otherwise = S.insert warp warps
 194     where others = S.filter (portalsConnect lab pos) portals
 195           lab = portal ^. label
 196           pos = portal ^. position
 197           other = S.findMin others
 198           warp = Edge {_connects = mkConnection portal other, _edgeType = Teleport, _distance = 1}
 199
 200
 201 portalsConnect :: String -> Position -> Portal -> Bool
 202 portalsConnect lab pos portal = (pLabel == lab) && (not (pPos == pos))
 203     where pLabel = portal ^. label
 204           pPos = portal ^. position
 205
 206
 207 mkConnection :: Portal -> Portal -> EdgeConnects
 208 mkConnection a b = if a < b then (a, b) else (b, a)
 209
 210 edgeTouches :: Portal -> Edge -> Bool
 211 edgeTouches p e
 212     | p == a = True
 213     | p == b = True
 214     | otherwise = False
 215     where (a, b) = e ^. connects
 216
 217 -- anyEdgeTouch :: S.Set Portal -> Edge -> Bool
 218 -- -- anyEdgeTouch xs e = S.foldl' (\t x -> t || (edgeTouches e x)) False xs
 219 -- anyEdgeTouch xs e = any (edgeTouches e) xs
 220
 221 edgeOther :: Portal -> Edge -> Portal
 222 edgeOther x e
 223     | x == a = b
 224     | otherwise = a
 225     where (a, b) = e ^. connects
 226
 227 possibleNeighbours :: Position -> S.Set Position
 228 possibleNeighbours (r, c) = S.fromList [(r + 1, c), (r - 1, c), (r, c + 1), (r, c - 1)]
 229
 230
 231 mazePortals edges = S.foldr' mps S.empty edges
 232     where mps e ps = let (p1, p2) = e ^. connects
 233                      in S.insert p1 $ S.insert p2 ps
 234
 235
 236
 237 searchMaze ::  MazeContext (Maybe (Agendum))
 238 searchMaze =
 239     do agenda <- initAgenda
 240        aStar agenda S.empty
 241
 242 initAgenda ::  MazeContext (Agenda)
 243 initAgenda =
 244     do edges <- ask
 245        let portals = mazePortals edges
 246        let portal = S.findMin $ S.filter (\p -> p ^. label == "AA") portals
 247        cost <- estimateCost portal
 248        return $ P.singleton cost Agendum { _current = portal, _trail = Q.empty, _cost = cost}
 249
 250
 251 aStar ::  Agenda -> ExploredStates -> MazeContext (Maybe (Agendum))
 252 aStar agenda closed
 253     -- | trace ("Peeping " ++ (show $ fst $ P.findMin agenda) ++ ": " ++ (show reached) ++ " <- " ++ (show $ toList $ Q.take 1 $ _trail $ currentAgendum) ++ " :: " ++ (show newAgenda)) False = undefined
 254     -- | trace ("Peeping " ++ (show $ _current $ snd $ P.findMin agenda) ) False = undefined
 255     | P.null agenda = return Nothing
 256     | otherwise =
 257         do  let (_, currentAgendum) = P.findMin agenda
 258             let reached = _current currentAgendum
 259             nexts <- candidates currentAgendum closed
 260             let newAgenda = foldl' (\q a -> P.insert (_cost a) a q) (P.deleteMin agenda) nexts
 261             reachedGoal <- isGoal reached
 262             if reachedGoal
 263             then return (Just currentAgendum)
 264             else if reached `S.member` closed
 265                  then aStar (P.deleteMin agenda) closed
 266                  else aStar newAgenda (S.insert reached closed)
 267
 268
 269 isGoal :: Portal -> MazeContext Bool
 270 isGoal portal = return $ portal ^. label == "ZZ"
 271
 272 candidates ::  Agendum -> ExploredStates -> MazeContext (Q.Seq (Agendum))
 273 candidates agendum closed =
 274     do  let candidate = agendum ^. current
 275         let previous = agendum ^. trail
 276         succs <- successors candidate
 277         let nonloops = Q.filter (\s -> not $ (fst s) `S.member` closed) succs
 278         mapM (makeAgendum previous) nonloops
 279
 280 makeAgendum ::  (Q.Seq Edge) -> (Portal, Edge) -> MazeContext (Agendum)
 281 makeAgendum previous (newP, newE) =
 282     do predicted <- estimateCost newP
 283        let incurred = (newE ^. distance) + (sum $ fmap (^. distance) previous)
 284        return Agendum { _current = newP
 285                       , _trail = newE <| previous
 286                       , _cost = incurred + predicted
 287                       }
 288
 289 successors :: Portal -> MazeContext (Q.Seq (Portal, Edge))
 290 successors portal =
 291     do maze <- ask
 292        let edges = S.filter (edgeTouches portal) maze
 293        let locations = S.map (\e -> (edgeOther portal e, e)) edges
 294        let succs = S.foldr' (<|) Q.empty locations
 295        return succs
 296
 297 estimateCost :: Portal -> MazeContext Int
 298 estimateCost portal = return 0
 299     -- do let heres = explorer ^. position
 300     --    ks <- asks _keys
 301     --    cavern <- asks _cave
 302     --    let kH = explorer ^. keysHeld
 303     --    let unfound = ks `S.difference` kH
 304     --    let unfoundEdges0 = S.filter (\e -> edgeTouch heres e) cavern
 305     --    let unfoundEdges = S.filter (\e -> not $ anyEdgeTouch kH e) unfoundEdges0
 306     --    let furthest = S.findMax $ S.insert 0 $ S.map _distance unfoundEdges
 307     --    return $ max 0 $ furthest + (S.size unfound) - 1
 308
 309
 310
 311
 312
 313
 314 showContracted :: Maze -> String
 315 showContracted maze = "graph Maze {\n" ++ bulk ++ "\n}"
 316     where   bulk = S.foldr (\e s -> (showEdge e) ++ s) "" maze
 317
 318 showEdge :: Edge -> String
 319 showEdge e = (showPortal h) ++ " -- " ++ (showPortal t) ++ " [ label = \"" ++ (edgeLabel e) ++ "\"];\n"
 320     where edgeLabel e = (show (e ^. edgeType)) ++ ", " ++ (show (e ^. distance))
 321           (h, t) = e ^. connects
 322           showPortal p = p ^. label ++ (show (fst (p ^. position))) ++ "c" ++ (show (snd (p ^. position)))