8-1

1 files changed, 82 insertions, 0 deletions

diff --git a/8-1.hs b/8-1.hs
new file mode 100644
index 0000000..d5393e9
--- /dev/null
+++ b/8-1.hs
@@ -0,0 +1,82 @@
+import Data.List (nub)
+import Data.Maybe (mapMaybe)
+
+pairs :: [a] -> [(a,a)]
+pairs = go []
+  where
+    go :: [(a,a)] -> [a] -> [(a,a)]
+    go res []     = res
+    go res (x:xs) = go (map (x,) xs ++ res) xs
+
+smul :: (Int,Int) -> Int -> (Int,Int)
+smul (p,q) x = (x*p,x*q)
+
+vplus :: (Int,Int) -> (Int,Int) -> (Int,Int)
+vplus (p,q) (u,v) = (p+u,q+v)
+
+vminus :: (Int,Int) -> (Int,Int) -> (Int,Int)
+vminus (p,q) (u,v) = (p-u,q-v)
+
+antinodes :: (Int,Int) -> (Int,Int) -> [(Int,Int)]
+antinodes u v = let p = vminus u v
+                in vplus v . smul p <$> [-1,2]
+
+separate :: [(Char,(Int,Int))] -> [[(Int,Int)]]
+separate = map snd . go []
+  where
+    go :: [(Char,[(Int,Int)])]
+       -> [(Char,(Int,Int))]
+       -> [(Char,[(Int,Int)])]
+    go res [] = res
+    go res (x:xs) = go (f res x) xs
+
+    f :: [(Char,[(Int,Int)])]
+      -> (Char,(Int,Int))
+      -> [(Char,[(Int,Int)])]
+    f xs (c,pos) = case lookup c xs of
+      Nothing   -> (c,[pos]) : xs
+      Just poss -> (c,pos:poss) : rm c xs
+
+rm :: Eq a => a -> [(a,b)] -> [(a,b)]
+rm = go []
+  where
+    go :: Eq a => [(a,b)] -> a -> [(a,b)] -> [(a,b)]
+    go res _ [] = res
+    go res x (a@(p,_):xs) | p == x = go res x xs
+                          | otherwise = go (a:res) x xs
+
+parse :: String -> [(Char,(Int,Int))]
+parse s = mapMaybe lift' . flip zip coords . concatMap (map f) . lines $ s
+  where
+    f :: Char -> Maybe Char
+    f '.' = Nothing
+    f x   = Just x
+
+    coords :: [(Int,Int)]
+    coords = let w = length . head $ lines s
+                 h = length $ lines s
+             in [ (x,y) | x <- [0..w-1], y <- [0..h-1] ]
+
+    lift' :: (Maybe a,b) -> Maybe (a,b)
+    lift' (Just p,q)  = Just (p,q)
+    lift' (Nothing,_) = Nothing
+
+inBounds :: Int -> Int -> (Int,Int) -> Bool
+inBounds w h (x,y) = x >= 0 && x < w && y >= 0 && y < h
+
+doStuff :: Int -> Int -> String -> Int
+doStuff w h = length
+  . nub
+  . concatMap (concatMap (filter (inBounds w h)
+                          . uncurry antinodes)
+               . pairs)
+  . separate
+  . parse
+
+main :: IO ()
+main = do
+  s <- getContents
+  let ls = lines s
+  let w = length . head $ ls
+  let h = length ls
+  print $ doStuff w h s