--- Writeup at https://work.njae.me.uk/2022/12/14/advent-of-code-2022-day-12/
+-- Writeup at https://work.njae.me.uk/2023/12/21/advent-of-code-2023-day-17/
import AoC
-import Debug.Trace
-
import qualified Data.PQueue.Prio.Min as P
import qualified Data.Set as S
import qualified Data.Sequence as Q
-import Data.Sequence ((|>), Seq( (:|>) ) )
-import Data.Foldable (foldl', toList)
+-- import Data.Sequence ((|>), (><), Seq( (:|>) ) )
+import Data.Sequence ((|>), (><))
+import Data.Foldable (foldl')
import Data.Char
import Control.Monad.Reader
-import Control.Lens hiding ((<|), (|>), (:>), (:<), indices)
-import Linear (V2(..), (^+^), (^-^), _x, _y)
+-- import Control.Lens hiding ((<|), (|>), (:>), (:<), indices)
+import Control.Lens hiding ((|>))
+import Linear (V2(..), (^+^), (^-^), (^*), _x, _y)
import Data.Array.IArray
type Position = V2 Int -- r, c
_c :: Lens' (V2 Int) Int
_c = _y
-type Trail = Q.Seq Position
+data Direction = U | D | L | R deriving (Show, Eq, Ord)
+data Move = Move Direction Int deriving (Show, Eq, Ord)
+
+type Trail = Q.Seq Move
+
+type DirectedPosition = (Direction, Position)
type Grid = Array Position Int
+type ExploredStates = S.Set DirectedPosition
+
data City = City
{ _grid :: Grid
, _start :: Position
type CityContext = Reader City
-data Agendum =
- Agendum { _current :: Trail
+data Crucible
+data UltraCrucible
+
+data Agendum a =
+ Agendum { _current :: DirectedPosition
, _trail :: Trail
, _trailCost :: Int
, _cost :: Int
} deriving (Show, Eq)
makeLenses ''Agendum
-type Agenda = P.MinPQueue Int Agendum
-
-type ExploredStates = S.Set Trail
+type Agenda a = P.MinPQueue Int (Agendum a)
main :: IO ()
main =
let city = mkCity text
-- print city
print $ part1 city
- -- print $ part2 city
+ print $ part2 city
--- part1, part2 :: City -> Int
+part1, part2 :: City -> Int
part1 city = maybe 0 _cost result
where s = city ^. start
- result = runReader (searchCity s) city
-
--- part2 city = minimum results
--- where starts = possibleStarts city
--- results = fmap (runSearch city) starts
-
-runSearch :: City -> Position -> Int
-runSearch city s = maybe maxCost _cost result
- where result = runReader (searchCity s) city
- maxCost = length $ indices $ city ^. grid
+ result = runReader (searchCity s) city :: (Maybe (Agendum Crucible))
+part2 city = maybe 0 _cost result
+ where s = city ^. start
+ result = runReader (searchCity s) city :: (Maybe (Agendum UltraCrucible))
mkCity :: String -> City
mkCity text = City { _grid = grid, _start = (V2 0 0), _goal = (V2 r c) }
c = (length $ head rows) - 1
grid = listArray ((V2 0 0), (V2 r c)) $ map digitToInt $ concat rows
-searchCity :: Position -> CityContext (Maybe Agendum)
-searchCity startPos =
+
+class Searchable a where
+
+ searchCity :: Position -> CityContext (Maybe (Agendum a))
+ searchCity startPos =
do agenda <- initAgenda startPos
aStar agenda S.empty
-initAgenda :: Position -> CityContext Agenda
-initAgenda pos =
- do c <- estimateCost pos
- -- return $ P.singleton c Agendum { _current = pos, _trail = Q.empty, _trailCost = 0, _cost = c}
- return $ P.singleton c Agendum { _current = Q.singleton pos, _trail = Q.singleton pos, _trailCost = 0, _cost = c}
-
-aStar :: Agenda -> ExploredStates -> CityContext (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
- -- | trace ("Peeping " ++ (show $ snd $ P.findMin agenda) ) False = undefined
- -- | trace ("Peeping " ++ (show agenda) ) False = undefined
- | P.null agenda = return Nothing
- | otherwise =
- do let (_, currentAgendum) = P.findMin agenda
- let reached = currentAgendum ^. current
- nexts <- candidates currentAgendum closed
- let newAgenda = foldl' (\q a -> P.insert (_cost a) a q) (P.deleteMin agenda) nexts
- reachedGoal <- isGoal reached
- if reachedGoal
- then return (Just currentAgendum)
- else if reached `S.member` closed
- then aStar (P.deleteMin agenda) closed
- else aStar newAgenda (S.insert reached closed)
-
-candidates :: Agendum -> ExploredStates -> CityContext (Q.Seq Agendum)
-candidates agendum closed =
+ initAgenda :: Position -> CityContext (Agenda a)
+ initAgenda pos =
+ do c <- estimateCost pos
+ let dAgendum = Agendum { _current = (D, pos), _trail = Q.empty, _trailCost = 0, _cost = c}
+ dNexts <- candidates dAgendum S.empty
+ let rAgendum = Agendum { _current = (R, pos), _trail = Q.empty, _trailCost = 0, _cost = c}
+ rNexts <- candidates rAgendum S.empty
+ let nexts = dNexts >< rNexts
+ let agenda = foldl' (\q a -> P.insert (_cost a) a q) P.empty nexts
+ return agenda
+
+ aStar :: (Agenda a) -> ExploredStates -> CityContext (Maybe (Agendum a))
+ 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
+ -- | trace ("Peeping " ++ (show $ snd $ P.findMin agenda) ) False = undefined
+ -- | trace ("Peeping " ++ (show agenda) ) False = undefined
+ | P.null agenda = return Nothing
+ | otherwise =
+ do let (_, currentAgendum) = P.findMin agenda
+ let reached = currentAgendum ^. current
+ nexts <- candidates currentAgendum closed
+ let newAgenda = foldl' (\q a -> P.insert (_cost a) a q) (P.deleteMin agenda) nexts
+ reachedGoal <- isGoal reached
+ if reachedGoal
+ then return (Just currentAgendum)
+ else if reached `S.member` closed
+ then aStar (P.deleteMin agenda) closed
+ else aStar newAgenda (S.insert reached closed)
+
+ candidates :: (Agendum a) -> ExploredStates -> CityContext (Q.Seq (Agendum a))
+ candidates agendum closed =
do let candidate = agendum ^. current
+ let (_, here) = candidate
let previous = agendum ^. trail
let prevCost = agendum ^. trailCost
- succs <- successors candidate
- let bent = Q.filter isBent succs
- let nonloops = Q.filter (\s -> s `S.notMember` closed) bent
- mapM (makeAgendum previous prevCost) nonloops
-
-isBent :: Trail -> Bool
--- isBent previous (V2 row col)
--- | Q.length previous <= 3 = True
--- | otherwise = not $
--- all (\p -> p ^. _r == row) previous || all (\p -> p ^. _c == col) previous
-isBent trail
- | Q.length trail <= 4 = True
- | otherwise = not $ all id $ toList $ Q.zipWith (==) diffs $ Q.drop 1 diffs
- where diffs = Q.zipWith (^-^) trail $ Q.drop 1 trail
-
-
-makeAgendum :: Trail -> Int -> Trail -> CityContext Agendum
-makeAgendum previous prevCost newState =
- do let (_ :|> newPosition) = newState
- predicted <- estimateCost newPosition
- grid <- asks _grid
- let newTrail = previous |> newPosition
- let incurred = prevCost + (grid ! newPosition)
- return Agendum { _current = newState
- , _trail = newTrail
- , _trailCost = incurred
- , _cost = incurred + predicted
- }
-
-isGoal :: Trail -> CityContext Bool
-isGoal (_ :|> here) =
+ succs <- successors agendum candidate
+ let nonloops = Q.filter (\s -> (endingDirPos here s) `S.notMember` closed) succs
+ mapM (makeAgendum previous prevCost here) nonloops
+
+ successors :: (Agendum a) -> DirectedPosition -> CityContext (Q.Seq Move)
+
+ makeAgendum :: Trail -> Int -> Position -> Move -> CityContext (Agendum a)
+ makeAgendum previous prevCost here move =
+ do let positions = toPositions here move
+ predicted <- estimateCost $ last positions
+ grid <- asks _grid
+ let newTrail = previous |> move
+ let incurred = prevCost + (sum $ fmap (grid !) positions)
+ return Agendum { _current = endingDirPos here move
+ , _trail = newTrail
+ , _trailCost = incurred
+ , _cost = incurred + predicted
+ }
+
+
+instance Searchable Crucible where
+ successors _ = successorsWithRange (1, 3)
+
+instance Searchable UltraCrucible where
+ successors _ = successorsWithRange (4, 10)
+
+successorsWithRange :: (Int, Int) -> DirectedPosition -> CityContext (Q.Seq Move)
+successorsWithRange rng (dir, here) =
+ do grid <- asks _grid
+ let moves = [ Move d n
+ | d <- turnDirections dir
+ , n <- range rng
+ ]
+ let validMoves = filter (allInBounds (bounds grid) here) moves
+ return $ Q.fromList validMoves
+
+isGoal :: DirectedPosition -> CityContext Bool
+isGoal (_, here) =
do goal <- asks _goal
return $ here == goal
-successors :: Trail -> CityContext (Q.Seq Trail)
-successors trail@(ph :|> here) =
- do grid <- asks _grid
- let neighbours =
- filter (inRange (bounds grid))
- [ here ^+^ delta
- | delta <- [V2 -1 0, V2 1 0, V2 0 -1, V2 0 1]
- ]
- let neighbours' = if Q.null ph
- then neighbours
- else let (_ :|> ph') = ph
- in filter (/= ph') neighbours
- let prev = takeL 4 trail
- let succs = Q.fromList $ fmap (prev :|>) neighbours'
- return succs
-
estimateCost :: Position -> CityContext Int
--- estimateCost _ = return 0
estimateCost here =
do goal <- asks _goal
let (V2 dr dc) = here ^-^ goal
return $ (abs dr) + (abs dc)
+delta :: Direction -> Position
+delta U = V2 (-1) 0
+delta D = V2 1 0
+delta L = V2 0 (-1)
+delta R = V2 0 1
+
+turnDirections :: Direction -> [Direction]
+turnDirections U = [L, R]
+turnDirections D = [L, R]
+turnDirections L = [U, D]
+turnDirections R = [U, D]
+
+toPositions :: Position -> Move -> [Position]
+toPositions here (Move dir n) = [ here ^+^ (d ^* i) | i <- [1..n] ]
+ where d = delta dir
+
+endingDirPos :: Position -> Move -> DirectedPosition
+endingDirPos here move@(Move dir _) = (dir, last $ toPositions here move)
-takeL :: Int -> Q.Seq a -> Q.Seq a
-takeL _ Q.Empty = Q.empty
-takeL 0 _ = Q.empty
-takeL n (xs :|> x) = (takeL (n-1) xs) :|> x
+allInBounds :: (Position, Position) -> Position -> Move -> Bool
+allInBounds bounds here move = all (inRange bounds) $ toPositions here move
--- /dev/null
+-- Writeup at https://work.njae.me.uk/2022/12/14/advent-of-code-2022-day-12/
+
+import AoC
+
+import Debug.Trace
+
+import qualified Data.PQueue.Prio.Min as P
+import qualified Data.Set as S
+import qualified Data.Sequence as Q
+import Data.Sequence ((|>), Seq( (:|>) ) )
+import Data.Foldable (foldl', toList)
+import Data.Char
+import Control.Monad.Reader
+import Control.Lens hiding ((<|), (|>), (:>), (:<), indices)
+import Linear (V2(..), (^+^), (^-^), _x, _y)
+import Data.Array.IArray
+
+type Position = V2 Int -- r, c
+_r :: Lens' (V2 Int) Int
+_r = _x
+_c :: Lens' (V2 Int) Int
+_c = _y
+
+type Trail = Q.Seq Position
+
+type Grid = Array Position Int
+
+data City = City
+ { _grid :: Grid
+ , _start :: Position
+ , _goal :: Position
+ } deriving (Eq, Ord, Show)
+makeLenses ''City
+
+type CityContext = Reader City
+
+data Agendum =
+ Agendum { _current :: Trail
+ , _trail :: Trail
+ , _trailCost :: Int
+ , _cost :: Int
+ } deriving (Show, Eq)
+makeLenses ''Agendum
+
+type Agenda = P.MinPQueue Int Agendum
+
+type ExploredStates = S.Set Trail
+
+main :: IO ()
+main =
+ do dataFileName <- getDataFileName
+ text <- readFile dataFileName
+ let city = mkCity text
+ -- print city
+ print $ part1 city
+ -- print $ part2 city
+
+-- part1, part2 :: City -> Int
+part1 city = maybe 0 _cost result
+ where s = city ^. start
+ result = runReader (searchCity s) city
+
+-- part2 city = minimum results
+-- where starts = possibleStarts city
+-- results = fmap (runSearch city) starts
+
+runSearch :: City -> Position -> Int
+runSearch city s = maybe maxCost _cost result
+ where result = runReader (searchCity s) city
+ maxCost = length $ indices $ city ^. grid
+
+
+mkCity :: String -> City
+mkCity text = City { _grid = grid, _start = (V2 0 0), _goal = (V2 r c) }
+ where rows = lines text
+ r = length rows - 1
+ c = (length $ head rows) - 1
+ grid = listArray ((V2 0 0), (V2 r c)) $ map digitToInt $ concat rows
+
+searchCity :: Position -> CityContext (Maybe Agendum)
+searchCity startPos =
+ do agenda <- initAgenda startPos
+ aStar agenda S.empty
+
+initAgenda :: Position -> CityContext Agenda
+initAgenda pos =
+ do c <- estimateCost pos
+ -- return $ P.singleton c Agendum { _current = pos, _trail = Q.empty, _trailCost = 0, _cost = c}
+ return $ P.singleton c Agendum { _current = Q.singleton pos, _trail = Q.singleton pos, _trailCost = 0, _cost = c}
+
+aStar :: Agenda -> ExploredStates -> CityContext (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
+ -- | trace ("Peeping " ++ (show $ snd $ P.findMin agenda) ) False = undefined
+ -- | trace ("Peeping " ++ (show agenda) ) False = undefined
+ | P.null agenda = return Nothing
+ | otherwise =
+ do let (_, currentAgendum) = P.findMin agenda
+ let reached = currentAgendum ^. current
+ nexts <- candidates currentAgendum closed
+ let newAgenda = foldl' (\q a -> P.insert (_cost a) a q) (P.deleteMin agenda) nexts
+ reachedGoal <- isGoal reached
+ if reachedGoal
+ then return (Just currentAgendum)
+ else if reached `S.member` closed
+ then aStar (P.deleteMin agenda) closed
+ else aStar newAgenda (S.insert reached closed)
+
+candidates :: Agendum -> ExploredStates -> CityContext (Q.Seq Agendum)
+candidates agendum closed =
+ do let candidate = agendum ^. current
+ let previous = agendum ^. trail
+ let prevCost = agendum ^. trailCost
+ succs <- successors candidate
+ let bent = Q.filter isBent succs
+ let nonloops = Q.filter (\s -> s `S.notMember` closed) bent
+ mapM (makeAgendum previous prevCost) nonloops
+
+isBent :: Trail -> Bool
+-- isBent previous (V2 row col)
+-- | Q.length previous <= 3 = True
+-- | otherwise = not $
+-- all (\p -> p ^. _r == row) previous || all (\p -> p ^. _c == col) previous
+isBent trail
+ | Q.length trail <= 4 = True
+ | otherwise = not $ all id $ toList $ Q.zipWith (==) diffs $ Q.drop 1 diffs
+ where diffs = Q.zipWith (^-^) trail $ Q.drop 1 trail
+
+
+makeAgendum :: Trail -> Int -> Trail -> CityContext Agendum
+makeAgendum previous prevCost newState =
+ do let (_ :|> newPosition) = newState
+ predicted <- estimateCost newPosition
+ grid <- asks _grid
+ let newTrail = previous |> newPosition
+ let incurred = prevCost + (grid ! newPosition)
+ return Agendum { _current = newState
+ , _trail = newTrail
+ , _trailCost = incurred
+ , _cost = incurred + predicted
+ }
+
+isGoal :: Trail -> CityContext Bool
+isGoal (_ :|> here) =
+ do goal <- asks _goal
+ return $ here == goal
+
+successors :: Trail -> CityContext (Q.Seq Trail)
+successors trail@(ph :|> here) =
+ do grid <- asks _grid
+ let neighbours =
+ filter (inRange (bounds grid))
+ [ here ^+^ delta
+ | delta <- [V2 -1 0, V2 1 0, V2 0 -1, V2 0 1]
+ ]
+ let neighbours' = if Q.null ph
+ then neighbours
+ else let (_ :|> ph') = ph
+ in filter (/= ph') neighbours
+ let prev = takeL 4 trail
+ let succs = Q.fromList $ fmap (prev :|>) neighbours'
+ return succs
+
+estimateCost :: Position -> CityContext Int
+-- estimateCost _ = return 0
+estimateCost here =
+ do goal <- asks _goal
+ let (V2 dr dc) = here ^-^ goal
+ return $ (abs dr) + (abs dc)
+
+
+takeL :: Int -> Q.Seq a -> Q.Seq a
+takeL _ Q.Empty = Q.empty
+takeL 0 _ = Q.empty
+takeL n (xs :|> x) = (takeL (n-1) xs) :|> x
projects / advent-of-code-23.git / commitdiff