From 0598bdec7af2ad2fa8161902a8db7d107ac13e0f Mon Sep 17 00:00:00 2001
From: Neil Smith <NeilNjae@users.noreply.github.com>
Date: Thu, 5 Dec 2024 14:58:06 +0000
Subject: [PATCH] Version using custom ordering

---
 advent05/MainOrdering.hs | 101 +++++++++++++++++++++++++++++++++++++++
 adventofcode24.cabal     |   4 ++
 2 files changed, 105 insertions(+)
 create mode 100644 advent05/MainOrdering.hs

diff --git a/advent05/MainOrdering.hs b/advent05/MainOrdering.hs
new file mode 100644
index 0000000..8f2f8e9
--- /dev/null
+++ b/advent05/MainOrdering.hs
@@ -0,0 +1,101 @@
+-- Writeup at https://work.njae.me.uk/2024/12/05/advent-of-code-2024-day-5/
+
+import AoC
+import Data.Text (Text)
+import qualified Data.Text.IO as TIO
+import Data.Attoparsec.Text 
+-- import Control.Applicative
+import qualified Data.IntMap.Strict as M
+import Data.IntMap.Strict ((!))
+import qualified Data.Set as S
+import Data.List
+import Data.Maybe
+
+type Page = Int
+type Rules = M.IntMap (S.Set Page)
+
+main :: IO ()
+main = 
+  do  dataFileName <- getDataFileName
+      text <- TIO.readFile dataFileName
+      let (rulesPairs, books) = successfulParse text
+      let rules = mkRules rulesPairs
+      -- print rules
+      -- print books
+      -- print $ fmap (inValid rules) books
+      print $ part1 rules books
+      print $ part2 rules books
+
+
+part1, part2 :: Rules -> [[Page]] -> Int
+part1 rules books = sum $ fmap middlePage validBooks
+  where validBooks = filter (valid rules) books
+
+part2 rules books = sum $ fmap middlePage reorderedBooks
+  where invalidBooks = filter (not . valid rules) books
+        reorderedBooks = fmap (sortBook rules) invalidBooks
+
+-- a LT b if a must be printed before b
+-- a GT b if a must be printed after b
+-- a EQ b if there is no rule about the order of a and b  
+pageOrder :: Rules -> Page -> Page -> Ordering
+pageOrder rules a b
+  | isNothing pa && isNothing pb = EQ
+  | isNothing pa = LT
+  | isNothing pb = GT
+  | S.member a rb = LT
+  | S.member b ra = GT
+  | otherwise = EQ
+  where pa = rules M.!? a
+        pb = rules M.!? b
+        ra = fromJust pa
+        rb = fromJust pb
+
+
+middlePage :: [Page] -> Page
+middlePage b = b !! (length b `div` 2)
+
+sortBook :: Rules -> [Page] -> [Page]
+sortBook rules pages = sortBy (pageOrder rules) pages
+
+-- valid :: Rules -> [Page] -> Bool
+-- valid rules book = sortBook rules book == book
+
+valid :: Rules -> [Page] -> Bool
+valid rules book = fst $ foldr (pageValid rules) (True, []) book
+
+pageValid :: Rules -> Page -> (Bool, [Page]) -> (Bool, [Page])
+pageValid _rules _page (False, pages) = (False, pages)
+pageValid rules page (True, pages) = (allowed, page:pages)
+  where allowed = not $ any mustBeLaterThan pages
+        mustBeLaterThan other = pageOrder rules page other == GT
+
+
+
+mkRules :: [(Page, Page)] -> Rules
+mkRules = foldr go M.empty 
+  where go (a, b) m = M.insertWith S.union b (S.singleton a) m
+
+-- parse the input file
+
+rulesBooksP :: Parser ([(Page, Page)], [[Page]])
+rulesP :: Parser [(Page, Page)]
+ruleP :: Parser (Page, Page)
+booksP :: Parser [[Page]]
+bookP :: Parser [Page]
+-- pageP :: Parser Page
+
+rulesBooksP = (,) <$> rulesP <* endOfLine <* endOfLine <*> booksP
+
+rulesP = ruleP `sepBy` endOfLine
+ruleP = (,) <$> decimal <* "|" <*> decimal
+
+booksP = bookP `sepBy` endOfLine
+bookP = decimal `sepBy` ","
+
+successfulParse :: Text -> ([(Page, Page)], [[Page]])
+successfulParse input = 
+  case parseOnly rulesBooksP input of
+    Left  _err -> ([], []) -- TIO.putStr $ T.pack $ parseErrorPretty err
+    Right rulesBooks -> rulesBooks
+
diff --git a/adventofcode24.cabal b/adventofcode24.cabal
index b11f307..19d7cef 100644
--- a/adventofcode24.cabal
+++ b/adventofcode24.cabal
@@ -95,3 +95,7 @@ executable advent05
   import: warnings, common-extensions, build-directives, common-modules
   main-is: advent05/Main.hs  
   build-depends: attoparsec, text, containers
+executable advent05ord
+  import: warnings, common-extensions, build-directives, common-modules
+  main-is: advent05/MainOrdering.hs  
+  build-depends: attoparsec, text, containers
-- 
2.34.1