Done day 17 part 1

diff --git a/advent-of-code23.cabal b/advent-of-code23.cabal
index dbddc057e10e3d6205609ccee46a3645836228e2..39f88e1390675edaf8f346eccb4ef97586bcaef8 100644 (file)
--- a/advent-of-code23.cabal
+++ b/advent-of-code23.cabal
@@ -196,3 +196,8 @@ executable advent16
   import: common-extensions, build-directives
   main-is: advent16/Main.hs
   build-depends: linear, array, containers
+
+executable advent17
+  import: common-extensions, build-directives
+  main-is: advent17/Main.hs
+  build-depends: containers, linear, array, pqueue, mtl, lens

diff --git a/advent17/Main.hs b/advent17/Main.hs
new file mode 100644 (file)
index 0000000..1197c20
--- /dev/null
+++ b/advent17/Main.hs
@@ -0,0 +1,176 @@
+-- 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