diff --git a/2023/haskell/solutions/Day10.hs b/2023/haskell/solutions/Day10.hs index 97a7fa6..255f93b 100644 --- a/2023/haskell/solutions/Day10.hs +++ b/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 (r, c) = snd . head . filter ((c ==) . fst) . zip [0..] . snd . head . filter ((r ==) . fst) . zip [0..] +get :: (Row, Col) -> [[Pipe]] -> Maybe Pipe +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 -trapezoid (sp, vs) = (/2) . fromIntegral . sum . map inner . pairs $ [sp] <> vs <> [sp] +shoelace :: ((Row, Col), [(Row, Col)]) -> Double +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 diff --git a/2023/haskell/tests/Main.hs b/2023/haskell/tests/Main.hs index 162cdc8..28e10bf 100644 --- a/2023/haskell/tests/Main.hs +++ b/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 "day02" day02 - , TestLabel "day03" day03 - , TestLabel "day04" day04 - , TestLabel "day05" day05 - , TestLabel "day06" day06 - , TestLabel "day07" day07 - , TestLabel "day08" day08 - , TestLabel "day09" day09 + [ TestLabel "01" day01 + , TestLabel "02" day02 + , TestLabel "03" day03 + , TestLabel "04" day04 + , TestLabel "05" day05 + , TestLabel "06" day06 + , TestLabel "07" day07 + , TestLabel "08" day08 + , TestLabel "09" day09 + , TestLabel "10" day10 ] main :: IO ()