adventofcode1624/app/advent24.hs

   1 {-# LANGUAGE DeriveGeneric #-}
   2
   3 module Main(main) where
   4
   5 import GHC.Generics (Generic)
   6 import Data.Maybe (catMaybes, fromJust)
   7 import Data.List
   8 import Data.Char (isDigit)
   9 import qualified Data.Map.Strict as M
  10 import Data.Map.Strict ((!))
  11 import qualified Data.HashSet as S
  12 import Data.Graph.AStar
  13 import Data.Hashable
  14 import qualified Data.HashSet
  15 import Debug.Trace
  16
  17 type Point = (Int, Int) -- row, column, both zero based.
  18 type Grid = M.Map Point Char
  19
  20 data Path = Path { from :: Point
  21                  , to :: Point
  22                  , path :: Int
  23                  } deriving (Eq, Generic)
  24 instance Hashable Path
  25 -- instance Eq Path where
  26 --     p1 == p2 = (joins p1) == (joins p2)
  27 instance Show Path where
  28     show p = "Path { " ++ show (from p) ++ " -> " ++ show (to p) ++ ", " ++ show (path p) ++ " }"
  29
  30 type PathSet = S.HashSet Path
  31
  32 -- Grid search state
  33 data Gss = Gss { origin :: Point
  34                , current :: Point
  35                , goal :: Point
  36                , gssPath :: [Point]
  37                } deriving (Eq, Generic)
  38 instance Hashable Gss
  39 instance Ord Gss where
  40     s1 `compare` s2 = ((heuristicG s1) + (length (gssPath s1))) `compare` ((heuristicG s2) + (length (gssPath s2)))
  41 instance Show Gss where
  42     show gss = "Gss { " ++ show (origin gss) ++ " -> " ++ show (current gss) ++ " -> " ++ show (goal gss) ++ " }"
  43
  44 data Tour = Tour {at :: Point, tour :: [Path]} deriving (Show, Eq)
  45
  46
  47 littleGrid = "\
  48 \###########\n\
  49 \#0.1.....2#\n\
  50 \#.#######.#\n\
  51 \#4.......3#\n\
  52 \###########"
  53
  54 main :: IO ()
  55 main = do
  56     text <- readFile "data/advent24.txt"
  57     -- let text = littleGrid
  58     let tl = lines text
  59     let mp = M.fromList $ [((r, c), (tl!!r)!!c)| r <- [0..(length tl - 1)], c <- [0..(length (tl!!0) - 1)]]
  60     let goals = M.filter (isDigit) mp
  61     let start = head $ M.keys $ M.filter (=='0') mp
  62     let aStarSearch s g = asG [startGss s g] mp []
  63     let paths = map (fromGss) $ catMaybes $ [aStarSearch st gl | st <- (M.keys goals), gl <- (M.keys goals), st /= gl]
  64
  65     -- part0 mp
  66     part1 start (M.keys goals) paths
  67     part2 start (M.keys goals) paths
  68
  69 part0 mp = print (length allPaths, allPaths)
  70     where goals = M.filter (isDigit) mp
  71           start = head $ M.keys $ M.filter (=='0') mp
  72           -- goal = head $ M.keys goals
  73           goal = head $ M.keys $ M.filter (=='2') mp
  74           -- aStarSearch s g = aStar (successorsG mp) costG heuristicG isGoalG (startGss s g)
  75           aStarSearch s g = asG [startGss s g] mp []
  76           traceSearch s g = trace ("Trace " ++ (show s) ++ " -> " ++ (show g)) (aStarSearch s g)
  77           paths = S.fromList $ map (fromGss) $ catMaybes $ map (\gl -> aStarSearch start gl) $ M.keys goals
  78           path = aStarSearch start goal
  79           allPaths = map (fromGss) $ catMaybes $ [traceSearch st gl | st <- (M.keys goals), gl <- (M.keys goals), st /= gl]
  80
  81 fromGss :: Gss -> Path
  82 fromGss g = Path {from = origin g, to = goal g, path = (length (gssPath g)) - 1}
  83
  84 part1 :: Point -> [Point] -> [Path] ->  IO ()
  85 part1 start points paths = print $ shortestTour start points paths
  86
  87     -- where goals = M.filter (isDigit) mp
  88     --       start = head $ M.keys $ M.filter (=='0') mp
  89     --       aStarSearch s g = asG [startGss s g] mp []
  90     --       paths = nub $ map (fromGss) $ catMaybes $ [aStarSearch st gl | st <- (M.keys goals), gl <- (M.keys goals), st /= gl]
  91
  92 part2 :: Point -> [Point] -> [Path] ->  IO ()
  93 part2 start points paths = print $ shortestReturningTour start points paths
  94
  95 -- bfsG :: [Gss] -> Grid -> [Path] -> [Point] -> [Path]
  96 -- -- bfsG ps _ paths closed | trace ((show ps) ++ " :: " ++ (show paths) ++ " X " ++ (show closed)) False = undefined
  97 -- bfsG [] _ paths _ = paths
  98 -- bfsG (p:ps) g paths closed =
  99 --     if current p /= origin p && isDigit currentCell
 100 --         then bfsG ps g (newPath:paths) ((current p):closed)
 101 --         else bfsG (ps ++ extraAgenda) g paths ((current p):closed)
 102 --     where currentCell = (g!(current p))
 103 --           newPath = Path {joins = S.fromList [current p, origin p], path = gssPath p}
 104 --           nextPoints = filter (\np -> np `notElem` ((gssPath p) ++ closed)) $ gridNeighbours g $ current p
 105 --           extraAgenda = map (\n -> Gss {origin = origin p, goal = goal p, current = n, gssPath = (n:(gssPath p))}) nextPoints
 106
 107 asG :: [Gss] -> Grid -> [Point] -> Maybe Gss
 108 -- asG ps _ closed | trace ((show ps) ++ " :: " ++ (show paths) ++ " X " ++ (show closed)) False = undefined
 109 asG [] _ _ = Nothing
 110 asG (p:ps) g closed =
 111     if current p == goal p
 112         then Just p
 113         else if (head $ gssPath p) `elem` closed
 114                 then asG ps g closed
 115                 else asG newAgenda g ((current p):closed)
 116     where -- currentCell = (g!(current p))
 117           -- newPath = Path {joins = S.fromList [current p, origin p], path = gssPath p}
 118           nextPoints = filter (\np -> np `notElem` ((gssPath p) ++ closed)) $ gridNeighbours g $ current p
 119           extraAgenda = map (\n -> Gss {origin = origin p, goal = goal p, current = n, gssPath = (n:(gssPath p))}) nextPoints
 120           newAgenda = sort (ps ++ extraAgenda)
 121
 122
 123 startGss :: Point -> Point -> Gss
 124 startGss p g = Gss {origin = p, goal = g, current = p, gssPath = [p]}
 125
 126
 127 gridNeighbours :: Grid -> Point -> [Point]
 128 gridNeighbours g p@(r, c) = filter (\n -> (g!n) /= '#') ns
 129     where ns = [(r-1, c), (r+1, c), (r, c-1), (r, c+1)]
 130
 131 heuristicG :: Gss -> Int
 132 heuristicG gss = abs (rg - rc) + abs (cg - cc)
 133     where (rg, cg) = goal gss
 134           (rc, cc) = current gss
 135
 136 -- isGoalG :: Gss -> Bool
 137 -- isGoalG st = current st == goal st
 138
 139 -- successorsG :: Grid -> Gss -> Data.HashSet.HashSet Gss
 140 -- successorsG grid st = Data.HashSet.fromList extraAgenda
 141 --     where nextPoints = gridNeighbours grid $ current st
 142 --           -- nextPoints = filter (\np -> np `notElem` (gssPath st)) $ gridNeighbours grid $ current st
 143 --           extraAgenda = map (\n -> Gss {origin = origin st, goal = goal st, current = n, gssPath = (n:(gssPath st))}) nextPoints
 144
 145 -- costG :: a -> b -> Int
 146 -- costG = const $ const 1
 147
 148
 149
 150 shortestTour :: Point -> [Point] -> [Path] -> Int
 151 shortestTour p0 points paths = minimum $ map (\p -> pathLength p paths) startRight
 152     where pointPerms = permutations points
 153           startRight = filter (\p -> (head p) == p0) pointPerms
 154
 155 shortestReturningTour :: Point -> [Point] -> [Path] -> Int
 156 shortestReturningTour p0 points paths = minimum $ map (\p -> pathLength p paths) startRight
 157     where pointPerms = map (\p -> p ++ [p0]) $ permutations points
 158           startRight = filter (\p -> (head p) == p0) pointPerms
 159
 160 pathBetween :: [Path] -> Point -> Point -> Path
 161 pathBetween paths a b = head $ filter (\p -> from p == a && to p == b) paths
 162
 163 adjacents :: [a] -> [[a]]
 164 adjacents ts = filter (\t -> (length t) == 2) $ map (\t -> take 2 t) $ tails ts
 165
 166 pathLength :: [Point] -> [Path] -> Int
 167 pathLength points paths = sum $ map (path) builtPath
 168   where pairs = adjacents points
 169         builtPath = foldl (addPath paths) [] pairs
 170
 171 addPath :: [Path] -> [Path] -> [Point] -> [Path]
 172 addPath paths built posPair = built ++ [toAdd]
 173     where toAdd = pathBetween paths (posPair!!0) (posPair!!1)
 174
 175