src/advent22/advent22.hs

   1 {-# LANGUAGE NegativeLiterals #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE OverloadedStrings #-}
   4 {-# LANGUAGE TypeFamilies #-}
   5 {-# LANGUAGE BangPatterns #-}
   6
   7 import Debug.Trace
   8
   9 -- import Prelude hiding ((++))
  10
  11 import qualified Data.Map.Strict as M
  12 import Data.Map.Strict ((!))
  13 import Data.List
  14
  15 import qualified Data.PQueue.Prio.Min as P
  16 import qualified Data.Set as S
  17 import qualified Data.Sequence as Q
  18 import Data.Sequence ((<|), (|>), (><))
  19 import Data.Foldable (toList, foldr', foldl', all)
  20 import Data.Maybe (fromJust)
  21 import Debug.Trace
  22
  23 type Coord = (Integer, Integer)
  24 type Cave = M.Map Coord Integer
  25
  26
  27 data Region = Rocky | Wet | Narrow deriving (Eq, Ord, Show)
  28 data Tool = Rope | Torch | Neither deriving (Eq, Ord, Show)
  29 data Explorer = Explorer { _tool :: Tool
  30                          , _coord :: Coord
  31                          , _time :: Integer
  32                          } deriving (Ord, Show)
  33 type ExploredStates = S.Set Explorer
  34
  35 type RegionCave = M.Map Coord Region
  36
  37 data Agendum = Agendum { _current :: Explorer
  38                        , _trail :: Q.Seq Explorer
  39                        , _cost :: Int} deriving (Show, Eq)
  40 type Agenda = P.MinPQueue Int Agendum
  41 type Candidates = S.Set (Int, Agendum)
  42
  43
  44 instance Eq Explorer where
  45     e1 == e2   = (_tool e1 == _tool e2) && (_coord e1 == _coord e2)
  46
  47
  48 depth :: Integer
  49 -- depth = 510
  50 depth = 10689
  51
  52 target :: Coord
  53 -- target = (10, 10)
  54 target = (11, 722)
  55
  56 width :: Integer
  57 width = fst target
  58
  59 height :: Integer
  60 height = snd target
  61
  62
  63 main :: IO ()
  64 main = do
  65         print $ part1
  66         print $ part2
  67         -- print $ part2 ip instrs
  68
  69 part1 = cave_risk_level $ erosion_levels width height
  70
  71 part2 = _time $ _current $ fromJust result
  72     where cave = region_cave $ erosion_levels (width + height + 10)  (width + height + 10)
  73           result = aStar (initAgenda) cave S.empty
  74
  75
  76
  77 geologic_index_mouth = 0
  78 geologic_index_target = 0
  79 geologic_index_y0 x =  x * 16807
  80 geologic_index_x0 y =  y * 48271
  81 geologic_index l u = l * u
  82
  83 erosion_level gi = (gi + depth) `mod` 20183
  84
  85 risk_level el = el `mod` 3
  86
  87 region_type 0 = Rocky
  88 region_type 1 = Wet
  89 region_type 2 = Narrow
  90
  91 erosion_levels :: Integer -> Integer -> Cave
  92 erosion_levels w h = M.insert (width, height) (erosion_level $ geologic_index_target) cave
  93     where cave0 = M.singleton (0, 0) $ erosion_level $ geologic_index_mouth
  94           cave_top = foldl' (\c x -> M.insert (x, 0) (erosion_level $ geologic_index_y0 x) c) cave0 [1..w]
  95           cave_left = foldl' (\c y -> M.insert (0, y) (erosion_level $ geologic_index_x0 y) c) cave_top [1..h]
  96           cave = foldl' insert_erosion_level
  97                         cave_left
  98                         [ (xx, yy) | xx <- [1..w], yy <- [1..h] ]
  99           insert_erosion_level c (x, y) = M.insert (x, y) (erosion_level $ geologic_index (c!((x - 1), y)) (c!(x, (y - 1)))) c
 100
 101 cave_risk_level cave = sum $ map risk_level $ M.elems cave
 102
 103 region_cave cave = M.map (region_type . risk_level) cave
 104
 105
 106 initAgenda :: Agenda
 107 initAgenda = P.singleton (estimateCost explorer) Agendum { _current = explorer, _trail = Q.empty, _cost = estimateCost explorer}
 108     where explorer = Explorer { _coord = (0, 0), _tool = Torch, _time = 0 }
 109
 110
 111 aStar :: Agenda -> RegionCave -> ExploredStates -> Maybe Agendum
 112 -- aStar [] _ = Agendum {current=buildingTest, trail=[], cost=0}
 113 aStar agenda cave closed
 114     -- | trace ("Peeping " ++ (show $ fst $ P.findMin agenda) ++ ": " ++ (show reached) ++ " <- " ++ (show $ toList $ Q.take 1 $ _trail $ currentAgendum) ++ " :: " ++ (show newAgenda)) False = undefined
 115     -- | trace ("Peeping " ++ (show $ P.findMin agenda) ) False = undefined
 116     | P.null agenda = Nothing
 117     | otherwise =
 118         if isGoal reached then Just currentAgendum
 119         else if reached `S.member` closed
 120             then aStar (P.deleteMin agenda) cave closed
 121             else aStar newAgenda cave (S.insert reached closed)
 122         where
 123             (_, currentAgendum) = P.findMin agenda
 124             reached = _current currentAgendum
 125             newAgenda = foldl' (\q a -> P.insert (_cost a) a q) (P.deleteMin agenda) $ candidates currentAgendum cave closed
 126
 127
 128
 129 candidates :: Agendum -> RegionCave -> ExploredStates -> (Q.Seq Agendum)
 130 candidates agendum cave closed = newCandidates
 131     where
 132         candidate = _current agendum
 133         previous = _trail agendum
 134         succs = legalSuccessors cave $ successors candidate
 135         nonloops = Q.filter (\s -> not $ s `S.member` closed) succs
 136         newCandidates = fmap (\n -> makeAgendum n) nonloops
 137         makeAgendum new = Agendum { _current = new
 138                                   , _trail = candidate <| previous
 139                                   , _cost = estimateCost new + (fromIntegral $ _time new)
 140                                   }
 141
 142 isGoal :: Explorer -> Bool
 143 isGoal explorer = (_coord explorer) == target && (_tool explorer) == Torch
 144
 145
 146 isLegal :: RegionCave -> Explorer -> Bool
 147 isLegal cave explorer =
 148     legalInRegion region tool
 149     where region = cave!(_coord explorer)
 150           tool = _tool explorer
 151
 152 legalInRegion :: Region -> Tool -> Bool
 153 legalInRegion Rocky Rope = True
 154 legalInRegion Rocky Torch = True
 155 legalInRegion Wet Rope = True
 156 legalInRegion Wet Neither = True
 157 legalInRegion Narrow Torch = True
 158 legalInRegion Narrow Neither = True
 159 legalInRegion _ _ = False
 160
 161
 162 successors :: Explorer -> (Q.Seq Explorer)
 163 successors explorer = movingSuccessors >< switchingSuccessors
 164     where time = _time explorer
 165           (x, y) = _coord explorer
 166           tool = _tool explorer
 167           locations = filter (\(x', y') -> x' >= 0 && y' >= 0)
 168                             [(x, y + 1),  (x, y - 1), (x + 1, y), (x - 1, y)]
 169           tools = [t | t <- [Rope, Torch, Neither] , t /= tool ]
 170           movingSuccessors = fmap (\l -> explorer { _coord = l, _time = time + 1}) $ Q.fromList locations
 171           switchingSuccessors = fmap (\t -> explorer { _tool = t, _time = time + 7}) $ Q.fromList tools
 172
 173
 174 legalSuccessors :: RegionCave -> (Q.Seq Explorer) -> (Q.Seq Explorer)
 175 legalSuccessors cave = Q.filter (isLegal cave)
 176
 177
 178 estimateCost :: Explorer -> Int
 179 estimateCost explorer = fromIntegral $ (abs (x - width)) + (abs (y - height))
 180     where (x, y) = _coord explorer
 181
 182