refacto(2024/Day06): Improved today's solution to run faster and multithreaded

Author: goblivend

2024/Day06/Day06.hs

@@ -1,22 +1,27 @@
 module Main where
 
+import Control.Parallel.Strategies
 import Data.List
 import System.Environment
+import Data.Matrix (Matrix, (!))
+import Data.Matrix qualified as Mat
 import Data.Set (Set)
 import Data.Set qualified as S
 -- TODO: Cleanup imports after day done
 
 
 data Heading = UP | RIGHT | DOWN | LEFT deriving(Show, Eq, Ord)
-type Input = ([String], (Int, Int), (Int, Int), Heading)
+type Input = (Matrix Char, (Int, Int), (Int, Int), Heading)
 type Output = Int
 
 parseInput :: String -> Input
-parseInput s = (lines s, (width, height), pos, UP)
+parseInput s = (mat, (width, height), pos, UP)
     where
-        height = length $ lines s
-        width =  length . head $ lines s
-        pos = head . filter (\(x, y) -> (== '^') . (!! x) . (!! y) $ lines s) $ [(x, y) | x<-[0..width-1], y<-[0..height-1]]
+        mat = Mat.fromLists $ lines s
+        height = Mat.nrows mat
+        width = Mat.ncols mat
+
+        pos = head . filter ((== '^') . (mat !)) $ [(y, x) | x<-[1..width], y<-[1..height]]
 
 
 turn :: Heading -> Heading
@@ -26,53 +31,47 @@ turn DOWN = LEFT
 turn LEFT = UP
 
 move :: Heading -> (Int, Int) -> (Int, Int)
-move UP (x, y) = (x, y-1)
-move RIGHT (x, y) = (x+1, y)
-move DOWN (x, y) = (x, y+1)
-move LEFT (x, y) = (x-1, y)
+move UP (y, x) = (y-1, x)
+move RIGHT (y, x) = (y, x+1)
+move DOWN (y, x) = (y+1, x)
+move LEFT (y, x) = (y, x-1)
 
 isOut :: (Int, Int) -> (Int, Int) -> Bool
-isOut (width, height) (x, y) = x < 0 || y < 0 || x >= width || y >= height
-
-cellAt :: [String] -> (Int, Int) -> Char
-cellAt grid (x, y) = (grid !! y) !! x
+isOut (width, height) (y, x) = x <= 0 || y <= 0 || x > width || y > height
 
 visitedCells :: Input -> Set (Int, Int)
 visitedCells (grid, dim, pos, dir) = moveOut pos dir S.empty
     where
-        moveOut xy dir positions
-            | isOut dim (move dir xy) = newPoss
-            | cellAt grid (move dir xy) == '#' = moveOut (move newDir xy) newDir newPoss
-            | otherwise = moveOut (move dir xy) dir newPoss
+        moveOut yx dir positions
+            | isOut dim (move dir yx) = newPoss
+            | grid ! (move dir yx) == '#' = moveOut yx newDir newPoss
+            | otherwise = moveOut (move dir yx) dir newPoss
                 where
-                    newPoss = (S.insert xy positions)
+                    newPoss = (S.insert yx positions)
                     newDir = turn dir
 
 
 part1 :: Input -> Output
 part1 = S.size . visitedCells
 
 part2 :: Input -> Output
-part2 (grid, (dim@(width, height)), pos, dir) = length . filter (isLoop pos dir S.empty) . map insertObstacle $ wallsPos
+part2 (grid, (dim@(width, height)), pos, dir) = length . filter id . parMap rseq (isLoop pos dir S.empty) . map insertObstacle $ wallsPos
     where
         visited = visitedCells (grid, dim, pos, dir)
-        wallsPos = [(x, y) | x<-[0..width-1], y<-[0..height-1], ((x, y) `S.member` visited) && cellAt grid (x, y) /= '#']
-
-        insertObstacle :: (Int, Int) -> [String]
-        insertObstacle (x, y) = linesBefore ++ [elemsBefore ++ "#" ++ elemsAfter] ++ linesAfter
-            where
-                (linesBefore, lineAt:linesAfter) = splitAt y grid
-                (elemsBefore, elemAt:elemsAfter) = splitAt x lineAt
-
-        isLoop :: (Int, Int) -> Heading -> Set ((Int, Int), Heading) -> [String] -> Bool
-        isLoop xy dir positions grid
-            | (xy, dir) `S.member` positions = True
-            | isOut dim xy = False
-            | isOut dim (move dir xy) = False
-            | cellAt grid (move dir xy) == '#' = isLoop xy newDir newPos grid
-            | otherwise = isLoop (move dir xy) dir newPos grid
+        wallsPos =  [(y, x) | y<-[1..height], x<-[1..width], ((y, x) `S.member` visited) && grid ! (y, x) == '.']
+
+        insertObstacle :: (Int, Int) -> Matrix Char
+        insertObstacle yx = Mat.setElem '#' yx grid
+
+        isLoop :: (Int, Int) -> Heading -> Set ((Int, Int), Heading) -> Matrix Char -> Bool
+        isLoop yx dir positions grid
+            | (yx, dir) `S.member` positions = True
+            | isOut dim yx = False
+            | isOut dim (move dir yx) = False
+            | grid ! (move dir yx) == '#' = isLoop yx newDir newPos grid
+            | otherwise = isLoop (move dir yx) dir newPos grid
                 where
-                    newPos = (S.insert (xy, dir) positions)
+                    newPos = (S.insert (yx, dir) positions)
                     newDir = turn dir
 
 

2024/README.md

@@ -91,3 +91,5 @@ For the part 2 I managed to speed up my solution :
 - Changing the memory list to a Set memory => 3mins
 - Filtering the positions to only places where the guard passes in the their usual path => 30sec
 - Adding -O2 => ~10sec
+- Switching to Matrices instead of raw `[String]` => ~5.5s
+- Multithreading => ~6s (runs slightly slower but at least I have a reference to use multithreading)