-cabal-version: 3.6
--- Initial package description 'advent-of-code21.cabal' generated by 'cabal
--- init'. For further documentation, see
--- http://haskell.org/cabal/users-guide/
-
-name: advent-of-code21
-version: 0.1.0.0
-synopsis: Advent of Code 21 solutions
+ cabal-version: 3.6
+ -- Initial package description 'advent-of-code21.cabal' generated by 'cabal
+ -- init'. For further documentation, see
+ -- http://haskell.org/cabal/users-guide/
+
+ name: advent-of-code21
+ version: 0.1.0.0
+ synopsis: Advent of Code 21 solutions
-- description:
-- bug-reports:
license: MIT
import: common-extensions, build-directives
main-is: advent15/Main.hs
build-depends: text, containers, linear, array, pqueue, mtl, lens
+
+executable advent15slow
+ import: common-extensions, build-directives
+ main-is: advent15/MainSlow.hs
+ build-depends: text, containers, linear, array, pqueue, mtl, lens
+
+executable advent15prof
+ import: common-extensions, build-directives
+ main-is: advent15/Main.hs
+ build-depends: text, containers, linear, array, pqueue, mtl, lens
+ profiling: True
+ library-profiling: True
+ profiling-detail: toplevel-functions
+ ghc-options: -O2
+ -Wall
+ -threaded
+ -rtsopts "-with-rtsopts=-N -p -s -hT"
import Data.Maybe (fromMaybe)
import Linear (V2(..), (^+^), (^-^), (*^), (^*))
import Data.Array.IArray
+-- import Data.List
pattern Empty <- (Q.viewl -> Q.EmptyL) where Empty = Q.empty
data Agendum s =
Agendum { _current :: s
, _trail :: Q.Seq s
+ , _trailCost :: Int
, _cost :: Int
} deriving (Show, Eq)
makeLenses ''Agendum
let (tileR, gridR) = r `divMod` (maxR + 1)
let (tileC, gridC) = c `divMod` (maxC + 1)
let gridCost = grid ! (V2 gridR gridC)
- let cost = (gridCost - 1 + tileR + tileC) `mod` 9 + 1
+ let !cost = (gridCost - 1 + tileR + tileC) `mod` 9 + 1
return cost
tileScale :: BasePosition -> BasePosition
tileScale (V2 r c) = V2 (ts r) (ts c)
where ts n = (n + 1) * 5 - 1
--- enTilePosition :: Position -> TiledPosition
--- enTilePosition (V2 a b) = V2 a b
-
------------------------------
main :: IO ()
part1 :: Cave -> Int
--- part1 :: Maze -> Maybe (Agendum Portal)
part1 cave = maybe 0 _cost result
where result = runReader searchCave cave :: Maybe (Agendum Position)
part2 :: Cave -> Int
--- part1 :: Maze -> Maybe (Agendum Portal)
part2 cave = maybe 0 _cost result
where result = runReader searchCave cave :: Maybe (Agendum TiledPosition)
--- part2 :: Maze -> Int
--- -- part2 :: Maze -> Maybe (Agendum LevelledSearchState)
--- part2 maze = maybe 0 _cost result
--- where result = runReader searchMaze maze :: Maybe (Agendum LevelledSearchState)
-
searchCave :: SearchState s => CaveContext (Maybe (Agendum s))
searchCave =
initAgenda =
do let ss = emptySearchState
c <- estimateCost ss
- return $ P.singleton c Agendum { _current = ss, _trail = Q.empty, _cost = c}
+ return $ P.singleton c Agendum { _current = ss, _trail = Q.empty, _trailCost = 0, _cost = c}
aStar :: SearchState s => Agenda s -> ExploredStates s -> CaveContext (Maybe (Agendum s))
candidates agendum closed =
do let candidate = agendum ^. current
let previous = agendum ^. trail
- -- let prevCost = agendum ^. cost
+ let prevCost = agendum ^. trailCost
succs <- successors candidate
let nonloops = Q.filter (\s -> s `S.notMember` closed) succs
- mapM (makeAgendum previous) nonloops
+ mapM (makeAgendum previous prevCost) nonloops
+
-makeAgendum :: SearchState s => (Q.Seq s) -> s -> CaveContext (Agendum s)
-makeAgendum previous newPosition =
+makeAgendum :: SearchState s => (Q.Seq s) -> Int -> s -> CaveContext (Agendum s)
+makeAgendum previous prevCost newPosition =
do predicted <- estimateCost newPosition
grid <- asks _grid
let newTrail = previous |> newPosition
- let _ :< entered = newTrail
- -- let incurred = foldr (+) 0 $ mapM entryCost entered
- incurredQ <- mapM entryCost newTrail
- let incurred = foldr (+) 0 incurredQ
+ newPositionCost <- entryCost newPosition
+ let incurred = prevCost + newPositionCost
return Agendum { _current = newPosition
, _trail = newTrail
+ , _trailCost = incurred
, _cost = incurred + predicted
}
+
\ No newline at end of file
--- /dev/null
+-- Writeup at https://work.njae.me.uk/2021/12/13/advent-of-code-2021-day-13/
+
+
+import Debug.Trace
+
+-- import qualified Data.Text.IO as TIO
+
+-- import qualified Data.Map.Strict as M
+-- import Data.Map.Strict ((!))
+import qualified Data.PQueue.Prio.Min as P
+import qualified Data.Set as S
+import qualified Data.Sequence as Q
+import Data.Sequence ((<|), (|>), (><)) --, ViewR( (:>) ), ViewL( (:<) ))
+import Data.Foldable (foldl', sum) -- (toList, foldr', foldl', all)
+import Data.Char
+import Control.Monad.Reader
+import Control.Lens hiding ((<|), (|>), (:>), (:<))
+import Data.Maybe (fromMaybe)
+import Linear (V2(..), (^+^), (^-^), (*^), (^*))
+import Data.Array.IArray
+-- import Data.List
+
+
+pattern Empty <- (Q.viewl -> Q.EmptyL) where Empty = Q.empty
+pattern x :< xs <- (Q.viewl -> x Q.:< xs) where (:<) = (Q.<|)
+pattern xs :> x <- (Q.viewr -> xs Q.:> x) where (:>) = (Q.|>)
+
+type BasePosition = V2 Int -- r, c
+newtype Position = Position BasePosition -- r, c
+ deriving (Eq, Ord, Show)
+newtype TiledPosition = TiledPosition BasePosition -- r, c
+ deriving (Eq, Ord, Show)
+type Grid = Array BasePosition Int
+
+data Cave = Cave
+ { _grid :: Grid
+ , _goal :: BasePosition
+ } deriving (Eq, Ord, Show)
+makeLenses ''Cave
+
+type CaveContext = Reader Cave
+
+
+data Agendum s =
+ Agendum { _current :: s
+ , _trail :: Q.Seq s
+ , _cost :: Int
+ } deriving (Show, Eq)
+makeLenses ''Agendum
+
+type Agenda s = P.MinPQueue Int (Agendum s)
+
+type ExploredStates s = S.Set s
+
+class (Eq s, Ord s, Show s) => SearchState s where
+ unwrapPos :: s -> BasePosition
+ successors :: s -> CaveContext (Q.Seq s)
+ estimateCost :: s -> CaveContext Int
+ emptySearchState :: s
+ isGoal :: s -> CaveContext Bool
+ entryCost :: s -> CaveContext Int
+
+
+instance SearchState Position where
+
+ unwrapPos (Position p) = p
+
+ emptySearchState = Position (V2 0 0)
+
+ -- successors :: Position -> CaveContext (Q.Seq Position)
+ successors here =
+ do grid <- asks _grid
+ let neighbours =
+ filter (inRange (bounds grid))
+ [ (unwrapPos here) ^+^ delta
+ | delta <- [V2 -1 0, V2 1 0, V2 0 -1, V2 0 1]
+ ]
+ let succs = Q.fromList $ map Position neighbours
+ return succs
+
+ -- estimateCost :: Position -> CaveContext Int
+ estimateCost here =
+ do goal <- asks _goal
+ let (V2 dr dc) = (unwrapPos here) ^-^ goal
+ return $ (abs dr) + (abs dc)
+
+ -- isGoal :: here -> CaveContext Bool
+ isGoal here =
+ do goal <- asks _goal
+ return $ (unwrapPos here) == goal
+
+ entryCost here =
+ do grid <- asks _grid
+ return $ grid ! (unwrapPos here)
+
+instance SearchState TiledPosition where
+
+ emptySearchState = TiledPosition (V2 0 0)
+
+ unwrapPos (TiledPosition p) = p
+
+ -- successors :: Position -> CaveContext (Q.Seq Position)
+ successors (TiledPosition here) =
+ do grid <- asks _grid
+ let (lowBound, highBound) = bounds grid
+ let extendedBounds = ( lowBound
+ , tileScale highBound
+ )
+ let neighbours =
+ filter (inRange extendedBounds)
+ [ here ^+^ delta
+ | delta <- [V2 -1 0, V2 1 0, V2 0 -1, V2 0 1]
+ ]
+ let succs = Q.fromList $ map TiledPosition neighbours
+ return succs
+
+ -- estimateCost :: Position -> CaveContext Int
+ estimateCost (TiledPosition here) =
+ do goal <- asks _goal
+ let (V2 dr dc) = here ^-^ (tileScale goal)
+ return $ (abs dr) + (abs dc)
+
+ -- isGoal :: here -> CaveContext Bool
+ isGoal (TiledPosition here) =
+ do goal <- asks _goal
+ return $ here == (tileScale goal)
+
+ entryCost (TiledPosition (V2 r c)) =
+ do grid <- asks _grid
+ let (_, V2 maxR maxC) = bounds grid
+ let (tileR, gridR) = r `divMod` (maxR + 1)
+ let (tileC, gridC) = c `divMod` (maxC + 1)
+ let gridCost = grid ! (V2 gridR gridC)
+ let !cost = (gridCost - 1 + tileR + tileC) `mod` 9 + 1
+ return cost
+
+tileScale :: BasePosition -> BasePosition
+tileScale (V2 r c) = V2 (ts r) (ts c)
+ where ts n = (n + 1) * 5 - 1
+
+------------------------------
+
+main :: IO ()
+main =
+ do text <- readFile "data/advent15.txt"
+ let cave = mkCave text
+ print $ part1 cave
+ print $ part2 cave
+ -- print $ part2 grid
+
+mkCave :: String -> Cave
+mkCave text = Cave { _grid = grid, _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 mkCell $ concat rows
+ mkCell e = digitToInt e
+
+
+part1 :: Cave -> Int
+part1 cave = maybe 0 _cost result
+ where result = runReader searchCave cave :: Maybe (Agendum Position)
+
+part2 :: Cave -> Int
+part2 cave = maybe 0 _cost result
+ where result = runReader searchCave cave :: Maybe (Agendum TiledPosition)
+
+
+searchCave :: SearchState s => CaveContext (Maybe (Agendum s))
+searchCave =
+ do agenda <- initAgenda
+ aStar agenda S.empty
+
+initAgenda :: SearchState s => CaveContext (Agenda s)
+initAgenda =
+ do let ss = emptySearchState
+ c <- estimateCost ss
+ return $ P.singleton c Agendum { _current = ss, _trail = Q.empty, _cost = c}
+
+
+aStar :: SearchState s => Agenda s -> ExploredStates s -> CaveContext (Maybe (Agendum s))
+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
+ | 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 :: SearchState s => Agendum s -> ExploredStates s -> CaveContext (Q.Seq (Agendum s))
+candidates agendum closed =
+ do let candidate = agendum ^. current
+ let previous = agendum ^. trail
+ let prevCost = agendum ^. cost
+ succs <- successors candidate
+ let nonloops = Q.filter (\s -> s `S.notMember` closed) succs
+ mapM (makeAgendum previous) nonloops
+ -- mapM (makeAgendum previous prevCost) nonloops
+
+makeAgendum :: SearchState s => (Q.Seq s) -> s -> CaveContext (Agendum s)
+makeAgendum previous newPosition =
+ do predicted <- estimateCost newPosition
+ grid <- asks _grid
+ let newTrail = previous |> newPosition
+ incurredQ <- mapM entryCost newTrail
+ let !incurred = foldr (+) 0 incurredQ
+ return Agendum { _current = newPosition
+ , _trail = newTrail
+ , _cost = incurred + predicted
+ }
+-- makeAgendum :: SearchState s => (Q.Seq s) -> Int -> s -> CaveContext (Agendum s)
+-- makeAgendum previous prevCost newPosition =
+-- do predicted <- estimateCost newPosition
+-- grid <- asks _grid
+-- let newTrail = previous |> newPosition
+-- newPositionCost <- entryCost newPosition
+-- let incurred = prevCost + newPositionCost
+-- return Agendum { _current = newPosition
+-- , _trail = newTrail
+-- , _cost = incurred + predicted
+-- }
+--
\ No newline at end of file
projects / advent-of-code-21.git / commitdiff