Day 2, part 2: Optimized solution using HashSet.

Day2/Part2.hs

@@ -2,22 +2,20 @@
 -- stack --resolver lts-12.20 --install-ghc script
 module Main where
 
-loopRight :: b -> (b -> Either a b) -> a
-loopRight b f = case f b of
-   Left  a  -> a
-   Right b' -> loopRight b' f
+import Control.Arrow ((***))
+import qualified Data.List    as L
+import qualified Data.HashSet as S
 
 main :: IO ()
-main = interact $ show . \input ->
-   let codes = lines input :: [[Char]]
-   in loopRight ([], codes) $ \(seen, c:cs) ->
-         case filter (`isSimilarTo` c) seen of
-            []    -> Right (c:seen, cs)
-            (x:_) -> Left (c, x, foldMap (\(a,b) -> if a == b then [a] else [])
-                                         (zip c x))
+main = interact $ (show .) $ (. lines) $ \codes ->
+   loopRight (S.empty, L.concatMap deletions codes) $ \(seen, d:ds) ->
+      if S.member d seen
+      then Left  (snd d)
+      else Right (S.insert d seen, ds)
 
-isSimilarTo :: (Eq a) => [a] -> [a] -> Bool
-(x:xs) `isSimilarTo` (y:ys)
-   | x == y    = xs `isSimilarTo` ys
-   | otherwise = xs == ys
-_ `isSimilarTo` _ = False
+loopRight :: b -> (b -> Either a b) -> a
+loopRight b f = either id (`loopRight` f) (f b)
+
+deletions :: [a] -> [(Int, [a])]
+deletions []     = []
+deletions (x:xs) = (0, xs) : map ((+1) *** (x:)) (deletions xs)