import Text.Parsec.String (Parser) import Text.Parsec import System.Environment import Control.Monad import Debug.Trace data Tile = EmptyT | Digit Int | Gear deriving (Show,Eq) tile :: Parser Tile tile = char '.' *> pure EmptyT <|> Digit <$> (read.pure <$> digit) <|> char '*' *> pure Gear <|> noneOf "\n" *> pure EmptyT board = sepBy (many1 tile) newline gearPositions l = [(x,y) | (y,r) <- zip [0..] l, (x,Gear) <- zip [0..] r] digitPositions l = [(n,x,y) | (y,r) <- zip [0..] l, (x,Digit n) <- zip [0..] r] groupBy :: (a -> a -> Bool) -> [a] -> [[a]] groupBy p = map (uncurry (:)) . groupByNonEmpty p groupByNonEmpty :: (a -> a -> Bool) -> [a] -> [(a,[a])] groupByNonEmpty p = foldr (\x0 yt -> let (xr,yr) = case yt of (x1,xs):ys -> if p x0 x1 then (x1:xs,ys) else ([],yt) [] -> ([],yt) in (x0,xr):yr) [] fromDigits :: [Int] -> Int fromDigits = foldl ((+) . (10 *)) 0 neighbours = foldMap (\(x,y) -> map (\(dx,dy) -> (x+dx,y+dy)) neigh) where neigh = liftM2 (,) [1,0,-1] [1,0,-1] findGearParts gears nums = do (x,y) <- gears let nb = neighbours [(x,y)] let adj = filter (any (\(_,x',y') -> (x',y') `elem` nb)) nums guard $ length adj == 2 let (a:b:[]) = adj return ((fromDigits.map (\(n,_,_) -> n)) a,(fromDigits.map (\(n,_,_) -> n)) b) solution :: [[Tile]] -> Int solution board = sum $ uncurry (zipWith (*)) $ unzip ratios where gears = gearPositions board digs = groupBy (\(_,x1,_) (_,x2,_) -> x2 == succ x1) $ digitPositions board ratios = findGearParts gears digs main = liftM2 (>>=) readFile (((print . solution . either (error.show) id) .) . parse board) =<< head <$> getArgs