feat(day5): Implement part 2 (7.46s of execution, we ain't ballin)

day5/Main.hs

@@ -2,21 +2,22 @@ module Main where
 
 import System.Environment (getArgs)
 import Data.Maybe (mapMaybe)
+import Data.List (find)
 
 import Text.Parsec (parse, Parsec, endBy, sepBy1, char, newline, many)
 import Text.ParserCombinators.Parsec.Number (decimal)
 
-type PageOrdering = (Int, Int)
+type OrderingRule = (Int, Int)
 type PagesUpdate = [Int]
 
-printInfo :: Parsec String () ([PageOrdering], [PagesUpdate])
-printInfo = (,) <$> orderings <*> (newline *> pagesUpdates) <* many (char '\n')
+printInfo :: Parsec String () ([OrderingRule], [PagesUpdate])
+printInfo = (,) <$> orderingRules <*> (newline *> pagesUpdates) <* many (char '\n')
     where
         pagesUpdates :: Parsec String () [PagesUpdate]
         pagesUpdates = endBy (sepBy1 decimal $ char ',') newline
 
-        orderings :: Parsec String () [PageOrdering]
-        orderings = endBy ((,) <$> decimal <*> (char '|' *> decimal)) $ char '\n'
+        orderingRules :: Parsec String () [OrderingRule]
+        orderingRules = endBy ((,) <$> decimal <*> (char '|' *> decimal)) $ char '\n'
 
 allDependencies :: [a] -> [(a, a)]
 allDependencies (h:tl) = map (flip (,) h) tl ++ allDependencies tl
@@ -29,16 +30,40 @@ middleElement (_:h':tl) = case reverse (h':tl) of
     (_:middle) -> middleElement middle
     [] -> Nothing
 
-part1 :: FilePath -> IO Int
-part1 fp = do
-    content <- readFile fp
-    (requiredOrderings, pagesUpdates) <- either (fail . show) return $ parse printInfo fp content
-    let wellOrdered = filter (all (`notElem` requiredOrderings) . allDependencies) pagesUpdates
-    return $ sum $ mapMaybe middleElement wellOrdered
+isWellOrdered :: [OrderingRule] -> PagesUpdate -> Bool
+isWellOrdered orderingRules = all (`notElem` orderingRules) . allDependencies
+
+part1 :: [OrderingRule] -> [PagesUpdate] -> Int
+part1 orderingRules pagesUpdates = (sum . mapMaybe middleElement) onlyWellOrdered
+    where onlyWellOrdered = filter (isWellOrdered orderingRules) pagesUpdates
+
+partitions :: [a] -> [([a], a, [a])]
+partitions (h:tl) = ([], h, tl) : map (\(as, a, bs) -> (h:as, a, bs)) (partitions tl)
+partitions [] = []
+
+doublePartitions :: [a] -> [([a], a, [a], a, [a])]
+doublePartitions ls = [(as, a, bs, b, cs)
+    | (as, a, bs') <- partitions ls
+    , (bs, b, cs) <- partitions bs']
+
+reorder :: [OrderingRule] -> PagesUpdate -> PagesUpdate
+reorder orderingRules pagesUpdate = case find badlyOrdered $ doublePartitions pagesUpdate of
+    Just (as, a, bs, b, cs) -> reorder orderingRules (as ++ b : bs ++ a : cs)
+    Nothing -> pagesUpdate
+    where
+        badlyOrdered :: ([Int], Int, [Int], Int, [Int]) -> Bool
+        badlyOrdered (_, a, _, b, _) = (b, a) `elem` orderingRules
+
+part2 :: [OrderingRule] -> [PagesUpdate] -> Int
+part2 orderingRules = sum
+    . mapMaybe (middleElement . reorder orderingRules)
+    . filter (not . isWellOrdered orderingRules)
 
 main :: IO ()
 main = do
     args <- getArgs
     (fp:_) <- return args
-    resPart1 <- part1 fp
-    putStrLn $ "Solution (Part 1) : " ++ show resPart1
+    content <- readFile fp
+    input <- either (fail . show) return $ parse printInfo fp content
+    -- putStrLn $ "Solution (Part 1) : " ++ show (uncurry part1 input)
+    putStrLn $ "Solution (Part 2) : " ++ show (uncurry part2 input)