141 lines
3.9 KiB
Haskell
141 lines
3.9 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
module Day10 (parse, solveA, solveB) where
|
|
|
|
import Data.Void (Void)
|
|
import Data.Text (Text)
|
|
import Data.Char (isSpace)
|
|
import Data.List (find)
|
|
import Data.Maybe (mapMaybe, catMaybes, fromJust)
|
|
import Data.Bifunctor (first, bimap)
|
|
import Control.Monad (join, (<=<))
|
|
import Text.Megaparsec (Parsec, errorBundlePretty, runParser, many, eof, satisfy)
|
|
import Text.Megaparsec.Char (newline)
|
|
import Misc (withCoords, pairs)
|
|
|
|
|
|
data Pipe
|
|
= E -- empty
|
|
| S -- start
|
|
| I -- vertical
|
|
| H -- horizontal
|
|
| J -- up-left
|
|
| L -- up-right
|
|
| T -- down-left
|
|
| F -- down-right
|
|
deriving (Show, Eq)
|
|
|
|
data Dir = DirL | DirR | DirU | DirD
|
|
deriving (Show, Eq)
|
|
|
|
type Row = Int
|
|
type Col = Int
|
|
type Move = (Dir, (Row, Col))
|
|
|
|
type Parser = Parsec Void Text
|
|
|
|
|
|
parse :: Text -> Either String [[Pipe]]
|
|
parse = first errorBundlePretty . runParser grid ""
|
|
where
|
|
pipe :: Char -> Pipe
|
|
pipe c = case c of
|
|
'.' -> E
|
|
'S' -> S
|
|
'|' -> I
|
|
'-' -> H
|
|
'J' -> J
|
|
'L' -> L
|
|
'7' -> T
|
|
'F' -> F
|
|
bad -> error $ "Invalid character: " <> [bad]
|
|
row :: Parser [Pipe]
|
|
row = map pipe <$> many (satisfy $ not . isSpace) <* newline
|
|
grid :: Parser [[Pipe]]
|
|
grid = many row <* eof
|
|
|
|
findStart :: [[Pipe]] -> (Row, Col)
|
|
findStart = fst . head . filter ((S ==) . snd) . withCoords
|
|
|
|
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
|
|
(I, DirD) -> Just DirD
|
|
(I, DirU) -> Just DirU
|
|
(H, DirR) -> Just DirR
|
|
(H, DirL) -> Just DirL
|
|
(J, DirD) -> Just DirL
|
|
(J, DirR) -> Just DirU
|
|
(L, DirD) -> Just DirR
|
|
(L, DirL) -> Just DirU
|
|
(T, DirU) -> Just DirL
|
|
(T, DirR) -> Just DirD
|
|
(F, DirU) -> Just DirR
|
|
(F, DirL) -> Just DirD
|
|
_ -> Nothing
|
|
|
|
nextC :: (Row, Col) -> Dir -> (Row, Col)
|
|
nextC (r, c) dir = case dir of
|
|
DirL -> (r, c - 1)
|
|
DirR -> (r, c + 1)
|
|
DirU -> (r - 1, c)
|
|
DirD -> (r + 1, c)
|
|
|
|
starts :: [[Pipe]] -> (Move, Move)
|
|
starts = do
|
|
sp <- findStart
|
|
ds <- checkDirs sp
|
|
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
|
|
checkDirs :: (Row, Col) -> [[Pipe]] -> [Move]
|
|
checkDirs sp = do
|
|
l <- check DirL $ nextC sp DirL
|
|
r <- check DirR $ nextC sp DirR
|
|
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 . fromJust . get rc $ grid of
|
|
Just dir' -> helper (dir', nextC rc dir')
|
|
Nothing -> []
|
|
|
|
solveA :: [[Pipe]] -> Int
|
|
solveA grid = (1 +) . length . takeWhile (not . isMatch) . uncurry zip . join bimap (go grid) $ starts grid
|
|
where
|
|
isMatch :: (Move, Move) -> Bool
|
|
isMatch (l, r) = snd l == snd r
|
|
|
|
verts :: [[Pipe]] -> ((Row, Col), [(Row, Col)])
|
|
verts grid = (findStart grid, findVerts grid)
|
|
where
|
|
isVertex :: (Move, Move) -> Maybe (Row, Col)
|
|
isVertex ((dir, rc), (dir', _)) = if dir /= dir' then Just rc else Nothing
|
|
findVerts :: [[Pipe]] -> [(Row, Col)]
|
|
findVerts = mapMaybe isVertex . pairs . go grid . fst . starts
|
|
|
|
-- https://en.wikipedia.org/wiki/Shoelace_formula
|
|
-- A = ((x1 * y2 - y1 * x2) + (x2 * y3 - x3 * y2) + ...) / 2
|
|
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
|
|
|
|
-- https://en.wikipedia.org/wiki/Pick%27s_theorem
|
|
-- A = i + b/2 - 1
|
|
-- i = A - b/2 + 1
|
|
solveB :: [[Pipe]] -> Double
|
|
solveB = do
|
|
vs <- verts
|
|
hb <- solveA
|
|
return $ shoelace vs - fromIntegral hb + 1
|