haskell: 2023 10 refactor

2023/haskell/solutions/Day10.hs

@@ -1,12 +1,13 @@
 {-# LANGUAGE OverloadedStrings #-}
-module Day10 where
+module Day10 (parse, solveA, solveB) where
 
 import Data.Void (Void)
 import Data.Text (Text)
 import Data.Char (isSpace)
-import Data.Maybe (mapMaybe, catMaybes)
+import Data.List (find)
+import Data.Maybe (mapMaybe, catMaybes, fromJust)
 import Data.Bifunctor (first, bimap)
-import Control.Monad (join)
+import Control.Monad (join, (<=<))
 import Text.Megaparsec (Parsec, errorBundlePretty, runParser, many, eof, satisfy)
 import Text.Megaparsec.Char (newline)
 import Misc (withCoords, pairs)
@@ -55,8 +56,10 @@ parse = first errorBundlePretty . runParser grid ""
 findStart :: [[Pipe]] -> (Row, Col)
 findStart = fst . head . filter ((S ==) . snd) . withCoords
 
-get :: (Row, Col) -> [[Pipe]] -> Pipe
+get :: (Row, Col) -> [[Pipe]] -> Maybe Pipe
-get (r, c) = snd . head . filter ((c ==) . fst) . zip [0..] . snd . head . filter ((r ==) . fst) . zip [0..]
+get (r, c) = nth c <=< nth r
+  where
+    nth n = fmap snd . find ((n ==) . fst) . zip [0..]
 
 nextD :: Dir -> Pipe -> Maybe Dir
 nextD dir pipe = case (pipe, dir) of
@@ -88,20 +91,20 @@ starts = do
   return (head ds, head $ tail ds)
   where
     check :: Dir -> (Row, Col) -> [[Pipe]] -> Maybe Move
-    check dir rc = fmap (const (dir, rc)) . nextD dir . get rc
+    check dir rc = fmap (const (dir, rc)) . nextD dir <=< get rc
     checkDirs :: (Row, Col) -> [[Pipe]] -> [Move]
     checkDirs sp = do
-      u <- check DirU $ nextC sp DirU
-      d <- check DirD $ nextC sp DirD
       l <- check DirL $ nextC sp DirL
       r <- check DirR $ nextC sp DirR
-      return $ catMaybes [u, d, l, r]
+      u <- check DirU $ nextC sp DirU
+      d <- check DirD $ nextC sp DirD
+      return $ catMaybes [l, r, u, d]
 
 go :: [[Pipe]] -> (Dir, (Row, Col)) -> [(Dir, (Row, Col))]
 go grid = helper
   where
     helper :: (Dir, (Row, Col)) -> [(Dir, (Row, Col))]
-    helper (dir, rc) = (dir, rc) : case nextD dir $ get rc grid of
+    helper (dir, rc) = (dir, rc) : case nextD dir . fromJust . get rc $ grid of
       Just dir' -> helper (dir', nextC rc dir')
       Nothing   -> []
 
@@ -121,8 +124,8 @@ verts grid = (findStart grid, findVerts grid)
 
 -- https://en.wikipedia.org/wiki/Shoelace_formula
 -- A = ((x1 * y2 - y1 * x2) + (x2 * y3 - x3 * y2) + ...) / 2
-trapezoid :: ((Row, Col), [(Row, Col)]) -> Double
+shoelace :: ((Row, Col), [(Row, Col)]) -> Double
-trapezoid (sp, vs) = (/2) . fromIntegral . sum . map inner . pairs $ [sp] <> vs <> [sp]
+shoelace (sp, vs) = (/2) . fromIntegral . abs . sum . map inner . pairs $ [sp] <> vs <> [sp]
   where
     inner :: ((Row, Col), (Row, Col)) -> Int
     inner ((r1, c1), (r2, c2)) = r1 * c2 - r2 * c1
@@ -130,8 +133,8 @@ trapezoid (sp, vs) = (/2) . fromIntegral . sum . map inner . pairs $ [sp] <> vs
 -- https://en.wikipedia.org/wiki/Pick%27s_theorem
 -- A = i + b/2 - 1
 -- i = A - b/2 + 1
-interior :: ((Row, Col), [(Row, Col)]) -> Int -> Double
-interior vs path = abs $ trapezoid vs - fromIntegral path + 1
-
 solveB :: [[Pipe]] -> Double
-solveB grid = interior (verts grid) (solveA grid)
+solveB = do
+  vs <- verts
+  hb <- solveA
+  return $ shoelace vs - fromIntegral hb + 1

2023/haskell/tests/Main.hs

@@ -12,6 +12,7 @@ import qualified Day06
 import qualified Day07
 import qualified Day08
 import qualified Day09
+import qualified Day10
 
 
 day01 :: Test
@@ -210,17 +211,82 @@ day09 =
       \1 3 6 10 15 21\n\
       \10 13 16 21 30 45\n"
 
+day10 :: Test
+day10 =
+  let parsedA  = Day10.parse inputA
+      parsedB1 = Day10.parse inputB1
+      parsedB2 = Day10.parse inputB2
+      parsedB3 = Day10.parse inputB3
+      parsedB4 = Day10.parse inputB4
+  in TestList
+    [ TestCase $ assertEqual "A" (Right 4)  (Day10.solveA <$> parsedA)
+    , TestCase $ assertEqual "B" (Right 4)  (Day10.solveB <$> parsedB1)
+    , TestCase $ assertEqual "B" (Right 4)  (Day10.solveB <$> parsedB2)
+    , TestCase $ assertEqual "B" (Right 8)  (Day10.solveB <$> parsedB3)
+    , TestCase $ assertEqual "B" (Right 10) (Day10.solveB <$> parsedB4)
+    ]
+  where
+    inputA =
+      ".....\n\
+      \.S-7.\n\
+      \.|.|.\n\
+      \.L-J.\n\
+      \.....\n"
+    inputB1 =
+      "...........\n\
+      \.S-------7.\n\
+      \.|F-----7|.\n\
+      \.||.....||.\n\
+      \.||.....||.\n\
+      \.|L-7.F-J|.\n\
+      \.|..|.|..|.\n\
+      \.L--J.L--J.\n\
+      \...........\n"
+    inputB2 =
+      "..........\n\
+      \.S------7.\n\
+      \.|F----7|.\n\
+      \.||OOOO||.\n\
+      \.||OOOO||.\n\
+      \.|L-7F-J|.\n\
+      \.|II||II|.\n\
+      \.L--JL--J.\n\
+      \..........\n"
+    inputB3 =
+      ".F----7F7F7F7F-7....\n\
+      \.|F--7||||||||FJ....\n\
+      \.||.FJ||||||||L7....\n\
+      \FJL7L7LJLJ||LJ.L-7..\n\
+      \L--J.L7...LJS7F-7L7.\n\
+      \....F-J..F7FJ|L7L7L7\n\
+      \....L7.F7||L7|.L7L7|\n\
+      \.....|FJLJ|FJ|F7|.LJ\n\
+      \....FJL-7.||.||||...\n\
+      \....L---J.LJ.LJLJ...\n"
+    inputB4 =
+      "FF7FSF7F7F7F7F7F---7\n\
+      \L|LJ||||||||||||F--J\n\
+      \FL-7LJLJ||||||LJL-77\n\
+      \F--JF--7||LJLJ7F7FJ-\n\
+      \L---JF-JLJ.||-FJLJJ7\n\
+      \|F|F-JF---7F7-L7L|7|\n\
+      \|FFJF7L7F-JF7|JL---7\n\
+      \7-L-JL7||F7|L7F-7F7|\n\
+      \L.L7LFJ|||||FJL7||LJ\n\
+      \L7JLJL-JLJLJL--JLJ.L\n"
+
 tests :: Test
 tests = TestList
-  [ TestLabel "day01" day01
+  [ TestLabel "01" day01
-  , TestLabel "day02" day02
+  , TestLabel "02" day02
-  , TestLabel "day03" day03
+  , TestLabel "03" day03
-  , TestLabel "day04" day04
+  , TestLabel "04" day04
-  , TestLabel "day05" day05
+  , TestLabel "05" day05
-  , TestLabel "day06" day06
+  , TestLabel "06" day06
-  , TestLabel "day07" day07
+  , TestLabel "07" day07
-  , TestLabel "day08" day08
+  , TestLabel "08" day08
-  , TestLabel "day09" day09
+  , TestLabel "09" day09
+  , TestLabel "10" day10
   ]
 
 main :: IO ()