adventofcode1624/app/advent24.hs

   1 {-# LANGUAGE DeriveGeneric #-}
   2
   3 module Main(main) where
   4
   5 import GHC.Generics (Generic)
   6 import Data.Maybe (catMaybes)
   7 import Data.List
   8 import Data.Char (isDigit)
   9 import qualified Data.Map.Strict as M
  10 import Data.Map.Strict ((!))
  11 import Data.Hashable
  12
  13 type Point = (Int, Int) -- row, column, both zero based.
  14 type Grid = M.Map Point Char
  15
  16 data Path = Path { from :: Point
  17                  , to :: Point
  18                  , path :: Int
  19                  } deriving (Eq, Generic)
  20 instance Hashable Path
  21 instance Show Path where
  22     show p = "Path { " ++ show (from p) ++ " -> " ++ show (to p) ++ ", " ++ show (path p) ++ " }"
  23
  24 -- Grid search state
  25 data Gss = Gss { origin :: Point
  26                , current :: Point
  27                , goal :: Point
  28                , gssPath :: [Point]
  29                } deriving (Eq, Generic)
  30 instance Hashable Gss
  31 instance Ord Gss where
  32     s1 `compare` s2 = ((heuristicG s1) + (length (gssPath s1))) `compare` ((heuristicG s2) + (length (gssPath s2)))
  33 instance Show Gss where
  34     show gss = "Gss { " ++ show (origin gss) ++ " -> " ++ show (current gss) ++ " -> " ++ show (goal gss) ++ " }"
  35
  36 littleGrid = "\
  37 \###########\n\
  38 \#0.1.....2#\n\
  39 \#.#######.#\n\
  40 \#4.......3#\n\
  41 \###########"
  42
  43 main :: IO ()
  44 main = do
  45     text <- readFile "data/advent24.txt"
  46     -- let text = littleGrid
  47     let tl = lines text
  48     let mp = M.fromList $ [((r, c), (tl!!r)!!c)| r <- [0..(length tl - 1)], c <- [0..(length (tl!!0) - 1)]]
  49     let goals = M.filter (isDigit) mp
  50     let start = head $ M.keys $ M.filter (=='0') mp
  51     let aStarSearch s g = asG [startGss s g] mp []
  52     let paths = map (fromGss) $ catMaybes $ [aStarSearch st gl | st <- (M.keys goals), gl <- (M.keys goals), st /= gl]
  53     part1 start (M.keys goals) paths
  54     part2 start (M.keys goals) paths
  55
  56 fromGss :: Gss -> Path
  57 fromGss g = Path {from = origin g, to = goal g, path = (length (gssPath g)) - 1}
  58
  59 part1 :: Point -> [Point] -> [Path] ->  IO ()
  60 part1 start points paths = print $ shortestTour start points paths
  61
  62 part2 :: Point -> [Point] -> [Path] ->  IO ()
  63 part2 start points paths = print $ shortestReturningTour start points paths
  64
  65 asG :: [Gss] -> Grid -> [Point] -> Maybe Gss
  66 -- asG ps _ closed | trace ((show ps) ++ " :: " ++ (show paths) ++ " X " ++ (show closed)) False = undefined
  67 asG [] _ _ = Nothing
  68 asG (p:ps) g closed =
  69     if current p == goal p
  70         then Just p
  71         else if (head $ gssPath p) `elem` closed
  72                 then asG ps g closed
  73                 else asG newAgenda g ((current p):closed)
  74     where nextPoints = filter (\np -> np `notElem` ((gssPath p) ++ closed)) $ gridNeighbours g $ current p
  75           extraAgenda = map (\n -> Gss {origin = origin p, goal = goal p, current = n, gssPath = (n:(gssPath p))}) nextPoints
  76           newAgenda = sort (ps ++ extraAgenda)
  77
  78
  79 startGss :: Point -> Point -> Gss
  80 startGss p g = Gss {origin = p, goal = g, current = p, gssPath = [p]}
  81
  82 gridNeighbours :: Grid -> Point -> [Point]
  83 gridNeighbours g p@(r, c) = filter (\n -> (g!n) /= '#') ns
  84     where ns = [(r-1, c), (r+1, c), (r, c-1), (r, c+1)]
  85
  86 heuristicG :: Gss -> Int
  87 heuristicG gss = abs (rg - rc) + abs (cg - cc)
  88     where (rg, cg) = goal gss
  89           (rc, cc) = current gss
  90
  91 shortestTour :: Point -> [Point] -> [Path] -> Int
  92 shortestTour p0 points paths = minimum $ map (\p -> pathLength p paths) startRight
  93     where pointPerms = permutations points
  94           startRight = filter (\p -> (head p) == p0) pointPerms
  95
  96 shortestReturningTour :: Point -> [Point] -> [Path] -> Int
  97 shortestReturningTour p0 points paths = minimum $ map (\p -> pathLength p paths) startRight
  98     where pointPerms = map (\p -> p ++ [p0]) $ permutations points
  99           startRight = filter (\p -> (head p) == p0) pointPerms
 100
 101 pathBetween :: [Path] -> Point -> Point -> Path
 102 pathBetween paths a b = head $ filter (\p -> from p == a && to p == b) paths
 103
 104 adjacents :: [a] -> [[a]]
 105 adjacents ts = filter (\t -> (length t) == 2) $ map (\t -> take 2 t) $ tails ts
 106
 107 pathLength :: [Point] -> [Path] -> Int
 108 pathLength points paths = sum $ map (path) builtPath
 109   where pairs = adjacents points
 110         builtPath = foldl (addPath paths) [] pairs
 111
 112 addPath :: [Path] -> [Path] -> [Point] -> [Path]
 113 addPath paths built posPair = built ++ [toAdd]
 114     where toAdd = pathBetween paths (posPair!!0) (posPair!!1)
 115
 116