refactor day6 part one

aoc2024.cabal

@@ -1,16 +1,19 @@
 cabal-version: 2.2
+
+-- This file has been generated from package.yaml by hpack version 0.37.0.
+--
+-- see: https://github.com/sol/hpack
+
 name:           aoc2024
 version:        0.1.0.0
-license:            BSD-3-Clause
+description:    Please see the README on GitHub at <https://github.com/githubuser/aoc2024#readme>
-license-file:       LICENSE
-copyright:          2025 Author name here
-maintainer:         example@example.com
-author:             Author name here
 homepage:       https://github.com/githubuser/aoc2024#readme
 bug-reports:    https://github.com/githubuser/aoc2024/issues
-description:
+author:         Author name here
-    Please see the README on GitHub at <https://github.com/githubuser/aoc2024#readme>
+maintainer:     example@example.com
-
+copyright:      2025 Author name here
+license:        BSD-3-Clause
+license-file:   LICENSE
 build-type:     Simple
 extra-source-files:
     README.md
@@ -29,49 +32,47 @@ library
       Day4
       Day5
       Day6
-
+      Day6.Guard
-    hs-source-dirs:   src
+  other-modules:
-    other-modules:    Paths_aoc2024
+      Paths_aoc2024
-    autogen-modules:  Paths_aoc2024
+  autogen-modules:
-    default-language: Haskell2010
+      Paths_aoc2024
-    ghc-options:
+  hs-source-dirs:
-        -Wall -Wcompat -Widentities -Wincomplete-record-updates
+      src
-        -Wincomplete-uni-patterns -Wmissing-export-lists
+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints
-        -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints
-
   build-depends:
-        base >=4.7 && <5,
+      base >=4.7 && <5
-        containers,
+    , containers
-        regex-tdfa >=1.3.2 && <1.4,
+    , hashable
-        text >=2.0.2,
+    , regex-tdfa >=1.3.2 && <1.4
-        unordered-containers
+    , text >=2.0.2
+    , unordered-containers
+  default-language: Haskell2010
 
 test-suite aoc2024-test
   type: exitcode-stdio-1.0
   main-is: Spec.hs
-    hs-source-dirs:   test
   other-modules:
       Day1Spec
       Day2Spec
       Day3Spec
       Day4Spec
       Day5Spec
+      Day6Spec
       Paths_aoc2024
-
+  autogen-modules:
-    autogen-modules:  Paths_aoc2024
+      Paths_aoc2024
-    default-language: Haskell2010
+  hs-source-dirs:
-    ghc-options:
+      test
-        -Wall -Wcompat -Widentities -Wincomplete-record-updates
+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N
-        -Wincomplete-uni-patterns -Wmissing-export-lists
-        -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints
-        -threaded -rtsopts -with-rtsopts=-N
-
   build-depends:
-        QuickCheck >=2.14.3 && <2.15,
+      QuickCheck >=2.14.3 && <2.15
-        aoc2024,
+    , aoc2024
-        base >=4.7 && <5,
+    , base >=4.7 && <5
-        containers,
+    , containers
-        hspec >=2.0.0,
+    , hashable
-        regex-tdfa >=1.3.2 && <1.4,
+    , hspec >=2.0.0
-        text >=2.0.2,
+    , regex-tdfa >=1.3.2 && <1.4
-        unordered-containers
+    , text >=2.0.2
+    , unordered-containers
+  default-language: Haskell2010

package.yaml

@@ -25,6 +25,7 @@ dependencies:
   - text >= 2.0.2
   - containers
   - unordered-containers
+  - hashable
 
 ghc-options:
   - -Wall

src/Day6.hs

@@ -4,75 +4,59 @@ import Data.HashSet (HashSet)
 import qualified Data.HashSet as HashSet
 import Data.Matrix (Matrix, Position)
 import qualified Data.Matrix as M
-import Data.Maybe
+import Day6.Guard (Guard (..))
-import Prelude hiding (Left, Right)
+import qualified Day6.Guard as G
 
-partOne :: String -> Maybe Int
+data Error = GuardNotFoundError
+  deriving (Eq, Show)
+
+partOne :: String -> Either Error Int
 partOne input = length <$> predictGuardsRoute (parseLabMap input)
 
-partTwo :: String -> Int
+partTwo :: String -> Either Error Int
-partTwo _input = 0
+partTwo _input = Right 0
 
 -- Laboratory Map
---
 type LabMap = Matrix Char
 
-type Direction = Char
+type Visited = HashSet Guard
-
-type Guard = (Position, Direction)
-
-type Visited = HashSet (Position, Direction)
 
 parseLabMap :: String -> LabMap
 parseLabMap = M.buildMatrix . lines
 
-findGuard :: LabMap -> Maybe Guard
+findGuard :: LabMap -> Either Error Guard
 findGuard matrix =
   let mUp = M.lookupValue '^' matrix
       mDown = M.lookupValue 'v' matrix
       mRight = M.lookupValue '>' matrix
       mLeft = M.lookupValue '<' matrix
    in case [mUp, mDown, mRight, mLeft] of
-        [Just pos, _, _, _] -> Just (pos, '^')
+        [Just pos, _, _, _] -> Right (Guard pos G.Up)
-        [_, Just pos, _, _] -> Just (pos, 'v')
+        [_, Just pos, _, _] -> Right (Guard pos G.Down)
-        [_, _, Just pos, _] -> Just (pos, '>')
+        [_, _, Just pos, _] -> Right (Guard pos G.Right)
-        [_, _, _, Just pos] -> Just (pos, '<')
+        [_, _, _, Just pos] -> Right (Guard pos G.Left)
-        _ -> Nothing
+        _ -> Left GuardNotFoundError
 
-predictGuardsRoute :: LabMap -> Maybe [Position]
+predictGuardsRoute :: LabMap -> Either Error [Position]
 predictGuardsRoute labMap = do
   guard <- findGuard labMap
-  return (go guard HashSet.empty HashSet.empty)
+  return $ go guard HashSet.empty HashSet.empty
   where
     go :: Guard -> Visited -> HashSet Position -> [Position]
-    go guard@(position, _) visited acc =
+    go guard visited acc =
       let guard' = moveGuard guard
-          acc' = HashSet.insert position acc
+          acc' = HashSet.insert (position guard) acc
           visited' = HashSet.insert guard visited
        in -- If we have hit a loop or if the guard can't move anymore, finish prediction
-          if HashSet.member guard visited || guard == guard'
+          if HashSet.member guard visited || (guard == guard')
             then HashSet.toList acc'
             else go guard' visited' acc'
 
     moveGuard :: Guard -> Guard
     moveGuard guard =
-      let guard'@(position', _) = moveForward guard
+      let guard' = G.moveForward guard
-          mObstacle = M.lookup position' labMap
+          mObstacle = M.lookup (position guard') labMap
        in case mObstacle of
             Nothing -> guard
-            Just '#' -> turnRight guard
+            Just '#' -> G.turnRight guard
             Just _ -> guard'
-
-    moveForward :: Guard -> Guard
-    moveForward ((row, col), '^') = ((row - 1, col), '^')
-    moveForward ((row, col), 'v') = ((row + 1, col), 'v')
-    moveForward ((row, col), '>') = ((row, col + 1), '>')
-    moveForward ((row, col), '<') = ((row, col - 1), '<')
-    moveForward guard = guard
-
-    turnRight :: Guard -> Guard
-    turnRight (pos, '^') = (pos, '>')
-    turnRight (pos, '>') = (pos, 'v')
-    turnRight (pos, 'v') = (pos, '<')
-    turnRight (pos, '<') = (pos, '^')
-    turnRight guard = guard

src/Day6/Guard.hs

@@ -0,0 +1,30 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+module Day6.Guard (Guard (..), Direction (..), moveForward, turnRight) where
+
+import Data.Hashable
+import Data.Matrix (Position)
+import GHC.Generics (Generic)
+import Prelude hiding (Left, Right)
+
+data Direction = Up | Down | Left | Right
+  deriving (Eq, Generic)
+
+instance Hashable Direction
+
+data Guard = Guard {position :: Position, directon :: Direction}
+  deriving (Eq, Generic)
+
+instance Hashable Guard
+
+moveForward :: Guard -> Guard
+moveForward (Guard (row, col) Up) = Guard (row - 1, col) Up
+moveForward (Guard (row, col) Down) = Guard (row + 1, col) Down
+moveForward (Guard (row, col) Right) = Guard (row, col + 1) Right
+moveForward (Guard (row, col) Left) = Guard (row, col - 1) Left
+
+turnRight :: Guard -> Guard
+turnRight (Guard pos Up) = Guard pos Right
+turnRight (Guard pos Right) = Guard pos Down
+turnRight (Guard pos Down) = Guard pos Left
+turnRight (Guard pos Left) = Guard pos Up

test/Day6Spec.hs

@@ -0,0 +1,26 @@
+module Day6Spec (spec) where
+
+import Day6 (partOne, partTwo)
+import Test.Hspec
+
+spec :: Spec
+spec = do
+  describe "PartOne" $ do
+    it "works" $ do
+      partOne input `shouldBe` Right 41
+
+  describe "PartTwo" $ do
+    it "works" $ do
+      partTwo input `shouldBe` Right 6
+  where
+    input =
+     "....#.....\n\
+     \.........#\n\
+     \..........\n\
+     \..#.......\n\
+     \.......#..\n\
+     \..........\n\
+     \.#..^.....\n\
+     \........#.\n\
+     \#.........\n\
+     \......#..."