advent15/MainSlow.hs

   1 -- Writeup at https://work.njae.me.uk/2021/12/13/advent-of-code-2021-day-13/
   2
   3
   4 import Debug.Trace
   5
   6 -- import qualified Data.Text.IO as TIO
   7
   8 -- import qualified Data.Map.Strict as M
   9 -- import Data.Map.Strict ((!))
  10 import qualified Data.PQueue.Prio.Min as P
  11 import qualified Data.Set as S
  12 import qualified Data.Sequence as Q
  13 import Data.Sequence ((<|), (|>), (><)) --, ViewR( (:>) ), ViewL( (:<) ))
  14 import Data.Foldable (foldl', sum) -- (toList, foldr', foldl', all)
  15 import Data.Char
  16 import Control.Monad.Reader
  17 import Control.Lens hiding ((<|), (|>), (:>), (:<))
  18 import Data.Maybe (fromMaybe)
  19 import Linear (V2(..), (^+^), (^-^), (*^), (^*))
  20 import Data.Array.IArray
  21 -- import Data.List
  22
  23
  24 pattern Empty   <- (Q.viewl -> Q.EmptyL)  where Empty = Q.empty
  25 pattern x :< xs <- (Q.viewl -> x Q.:< xs) where (:<)  = (Q.<|)
  26 pattern xs :> x <- (Q.viewr -> xs Q.:> x) where (:>)  = (Q.|>)
  27
  28 type BasePosition = V2 Int -- r, c
  29 newtype Position = Position BasePosition -- r, c
  30   deriving (Eq, Ord, Show)
  31 newtype TiledPosition = TiledPosition BasePosition -- r, c
  32   deriving (Eq, Ord, Show)
  33 type Grid = Array BasePosition Int
  34
  35 data Cave = Cave
  36   { _grid :: Grid
  37   , _goal :: BasePosition
  38   } deriving (Eq, Ord, Show)
  39 makeLenses ''Cave
  40
  41 type CaveContext = Reader Cave
  42
  43
  44 data Agendum s =
  45     Agendum { _current :: s
  46             , _trail :: Q.Seq s
  47             , _cost :: Int
  48             } deriving (Show, Eq)
  49 makeLenses ''Agendum
  50
  51 type Agenda s = P.MinPQueue Int (Agendum s)
  52
  53 type ExploredStates s = S.Set s
  54
  55 class (Eq s, Ord s, Show s) => SearchState s where
  56     unwrapPos :: s -> BasePosition
  57     successors :: s -> CaveContext (Q.Seq s)
  58     estimateCost :: s -> CaveContext Int
  59     emptySearchState :: s
  60     isGoal :: s -> CaveContext Bool
  61     entryCost :: s -> CaveContext Int
  62
  63
  64 instance SearchState Position where
  65
  66   unwrapPos (Position p) = p
  67
  68   emptySearchState = Position (V2 0 0)
  69
  70   -- successors :: Position -> CaveContext (Q.Seq Position)
  71   successors here =
  72     do grid <- asks _grid
  73        let neighbours =
  74             filter (inRange (bounds grid))
  75               [ (unwrapPos here) ^+^ delta
  76               | delta <- [V2 -1 0, V2 1 0, V2 0 -1, V2 0 1]
  77               ]
  78        let succs = Q.fromList $ map Position neighbours
  79        return succs
  80
  81   -- estimateCost :: Position -> CaveContext Int
  82   estimateCost here =
  83     do goal <- asks _goal
  84        let (V2 dr dc) = (unwrapPos here) ^-^ goal
  85        return $ (abs dr) + (abs dc)
  86
  87   -- isGoal :: here -> CaveContext Bool
  88   isGoal here =
  89     do goal <- asks _goal
  90        return $ (unwrapPos here) == goal
  91
  92   entryCost here =
  93     do grid <- asks _grid
  94        return $ grid ! (unwrapPos here)
  95
  96 instance SearchState TiledPosition where
  97
  98   emptySearchState = TiledPosition (V2 0 0)
  99
 100   unwrapPos (TiledPosition p) = p
 101
 102   -- successors :: Position -> CaveContext (Q.Seq Position)
 103   successors (TiledPosition here) =
 104     do grid <- asks _grid
 105        let (lowBound, highBound) = bounds grid
 106        let extendedBounds = ( lowBound
 107                             , tileScale highBound
 108                             )
 109        let neighbours =
 110             filter (inRange extendedBounds)
 111               [ here ^+^ delta
 112               | delta <- [V2 -1 0, V2 1 0, V2 0 -1, V2 0 1]
 113               ]
 114        let succs = Q.fromList $ map TiledPosition neighbours
 115        return succs
 116
 117   -- estimateCost :: Position -> CaveContext Int
 118   estimateCost (TiledPosition here) =
 119     do goal <- asks _goal
 120        let (V2 dr dc) = here ^-^ (tileScale goal)
 121        return $ (abs dr) + (abs dc)
 122
 123   -- isGoal :: here -> CaveContext Bool
 124   isGoal (TiledPosition here) =
 125     do goal <- asks _goal
 126        return $ here == (tileScale goal)
 127
 128   entryCost (TiledPosition (V2 r c)) =
 129     do grid <- asks _grid
 130        let (_, V2 maxR maxC) = bounds grid
 131        let (tileR, gridR) = r `divMod` (maxR + 1)
 132        let (tileC, gridC) = c `divMod` (maxC + 1)
 133        let gridCost = grid ! (V2 gridR gridC)
 134        let !cost = (gridCost - 1 + tileR + tileC) `mod` 9 + 1
 135        return cost
 136
 137 tileScale :: BasePosition -> BasePosition
 138 tileScale (V2 r c) = V2 (ts r) (ts c)
 139   where ts n = (n + 1) * 5 - 1
 140
 141 ------------------------------
 142
 143 main :: IO ()
 144 main =
 145   do  text <- readFile "data/advent15.txt"
 146       let cave = mkCave text
 147       print $ part1 cave
 148       print $ part2 cave
 149       -- print $ part2 grid
 150
 151 mkCave :: String -> Cave
 152 mkCave text = Cave { _grid = grid, _goal = V2 r c }
 153   where rows = lines text
 154         r = length rows - 1
 155         c = (length $ head rows) - 1
 156         grid = listArray ((V2 0 0), (V2 r c)) $ map mkCell $ concat rows
 157         mkCell e = digitToInt e
 158
 159
 160 part1 :: Cave -> Int
 161 part1 cave = maybe 0 _cost result
 162     where result = runReader searchCave cave :: Maybe (Agendum Position)
 163
 164 part2 :: Cave -> Int
 165 part2 cave = maybe 0 _cost result
 166     where result = runReader searchCave cave :: Maybe (Agendum TiledPosition)
 167
 168
 169 searchCave ::  SearchState s => CaveContext (Maybe (Agendum s))
 170 searchCave =
 171     do agenda <- initAgenda
 172        aStar agenda S.empty
 173
 174 initAgenda ::  SearchState s => CaveContext (Agenda s)
 175 initAgenda =
 176     do let ss = emptySearchState
 177        c <- estimateCost ss
 178        return $ P.singleton c Agendum { _current = ss, _trail = Q.empty, _cost = c}
 179
 180
 181 aStar ::  SearchState s => Agenda s -> ExploredStates s -> CaveContext (Maybe (Agendum s))
 182 aStar agenda closed
 183     -- | trace ("Peeping " ++ (show $ fst $ P.findMin agenda) ++ ": " ++ (show reached) ++ " <- " ++ (show $ toList $ Q.take 1 $ _trail $ currentAgendum) ++ " :: " ++ (show newAgenda)) False = undefined
 184     -- | trace ("Peeping " ++ (show $ _current $ snd $ P.findMin agenda) ) False = undefined
 185     | P.null agenda = return Nothing
 186     | otherwise =
 187         do  let (_, currentAgendum) = P.findMin agenda
 188             let reached = currentAgendum ^. current
 189             nexts <- candidates currentAgendum closed
 190             let newAgenda = foldl' (\q a -> P.insert (_cost a) a q) (P.deleteMin agenda) nexts
 191             reachedGoal <- isGoal reached
 192             if reachedGoal
 193             then return (Just currentAgendum)
 194             else if reached `S.member` closed
 195                  then aStar (P.deleteMin agenda) closed
 196                  else aStar newAgenda (S.insert reached closed)
 197
 198
 199 candidates ::  SearchState s => Agendum s -> ExploredStates s -> CaveContext (Q.Seq (Agendum s))
 200 candidates agendum closed =
 201     do  let candidate = agendum ^. current
 202         let previous = agendum ^. trail
 203         let prevCost = agendum ^. cost
 204         succs <- successors candidate
 205         let nonloops = Q.filter (\s -> s `S.notMember` closed) succs
 206         mapM (makeAgendum previous) nonloops
 207         -- mapM (makeAgendum previous prevCost) nonloops
 208
 209 makeAgendum ::  SearchState s => (Q.Seq s) -> s -> CaveContext (Agendum s)
 210 makeAgendum previous newPosition =
 211     do predicted <- estimateCost newPosition
 212        grid <- asks _grid
 213        let newTrail = previous |> newPosition
 214        incurredQ <- mapM entryCost newTrail
 215        let !incurred = foldr (+) 0 incurredQ
 216        return Agendum { _current = newPosition
 217                       , _trail = newTrail
 218                       , _cost = incurred + predicted
 219                       }
 220 -- makeAgendum ::  SearchState s => (Q.Seq s) -> Int -> s -> CaveContext (Agendum s)
 221 -- makeAgendum previous prevCost newPosition =
 222 --     do predicted <- estimateCost newPosition
 223 --        grid <- asks _grid
 224 --        let newTrail = previous |> newPosition
 225 --        newPositionCost <- entryCost newPosition
 226 --        let incurred = prevCost + newPositionCost
 227 --        return Agendum { _current = newPosition
 228 --                       , _trail = newTrail
 229 --                       , _cost = incurred + predicted
 230 --                       }
 231 --