wip 5

1 files changed, 56 insertions, 0 deletions

diff --git a/3/2.hs b/3/2.hs
new file mode 100644
index 0000000..8a13955
--- /dev/null
+++ b/3/2.hs
@@ -0,0 +1,56 @@
+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
\ No newline at end of file