From 128c209cee3a5efa7b4fc1070ac0e53dca80a55b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl?= Date: Mon, 23 Dec 2024 16:57:15 +0100 Subject: [PATCH] feat(2024/Day_23): Day_23 --- 2024/Day_23/Day_23.hs | 49 +++++++++++++++ 2024/Day_23/README.md | 138 ++++++++++++++++++++++++++++++++++++++++++ 2024/Day_23/sample | 32 ++++++++++ 2024/README.md | 6 +- 4 files changed, 224 insertions(+), 1 deletion(-) create mode 100644 2024/Day_23/Day_23.hs create mode 100644 2024/Day_23/README.md create mode 100644 2024/Day_23/sample diff --git a/2024/Day_23/Day_23.hs b/2024/Day_23/Day_23.hs new file mode 100644 index 0000000..581b972 --- /dev/null +++ b/2024/Day_23/Day_23.hs @@ -0,0 +1,49 @@ +module Main where + +import System.Environment +import Data.List +import Data.List.Split +import Data.Maybe +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Algorithm.MaximalCliques +import Data.Function + +type Input = Map String [String] +type Output = Int + +parseInput :: String -> Input +parseInput input = graph + where alterVertex a Nothing = Just [a] + alterVertex a (Just xs) = Just (a : xs) + addMap [a, b] m = Map.alter (alterVertex a) b $ Map.alter (alterVertex b) a m + edges = map (splitOn "-") . lines $ input + graph = foldr addMap Map.empty edges + +findConnected :: Input -> String -> [[String]] +findConnected graph t = [sort [t, a, b] | a <- neighbours, + b <- neighbours, + a < b, + b `elem` (graph Map.! a)] + where neighbours = graph Map.! t + +partOne :: Input -> Output +partOne input = length . nub $ concatMap (findConnected input) ts + where ts = filter (('t' ==) . head) $ Map.keys input + +partTwo :: Input -> String +partTwo input = intercalate "," . sort $ maxClique + where nodes = Map.keys input + isAdjacent a = (`elem` (input Map.! a)) + maxClique = maximumBy (compare `on` length) $ getMaximalCliques isAdjacent nodes + +compute :: Input -> String -> IO () +compute input "parse" = print input +compute input "one" = print . partOne $ input +compute input "two" = putStrLn . partTwo $ input +compute input _ = error "Unknown part" + +main = do + args <- getArgs + input <- parseInput <$> readFile (last args) + mapM (compute input) $ init args diff --git a/2024/Day_23/README.md b/2024/Day_23/README.md new file mode 100644 index 0000000..d00cc07 --- /dev/null +++ b/2024/Day_23/README.md @@ -0,0 +1,138 @@ +## Day 23 + +Part 2 be like: +```hs +import Thing.That.Solves.The.Problem (solveTheProblem) + +partTwo :: Input -> String +partTwo = solveTheProblem +``` + +--- + +## The input + +The input is a list of edges in the form "a-b". + +I represent this graph as a [Data.Map](https://hackage.haskell.org/package/containers-0.7/docs/Data-Map-Strict.html). +The keys of my Map are the nodes, and the values are the lists of adjacent nodes. + +To parse the input, I start by retrieving each edge by splitting the input into lines, +and then splitting each line by "-". + +Next, I create a Map, starting from an empty one. For each edge "a-b", I add +b to the adjacent nodes of a, and a to the adjacent nodes of b. + +```hs +parseInput :: String -> Input +parseInput input = graph + where alterVertex a Nothing = Just [a] + alterVertex a (Just xs) = Just (a : xs) + addMap [a, b] m = Map.alter (alterVertex a) b $ Map.alter (alterVertex b) a m + edges = map (splitOn "-") . lines $ input + graph = foldr addMap Map.empty edges +``` + +--- + +## Part 1 + +### The problem + +We need to find all the loops of three nodes where at least one of the nodes starts with a t. + +--- + +### The solution + +#### Solving a subproblem first + +Let’s start with this subproblem: +Given a node starting with t, find all loops of three nodes containing it. + +To do this, I iterate through each (ordered) pair (a, b) of +adjacent vertices to my t-node: +- t - a - b is a loop if the edges t-a, t-b, and a-b all exist. +- Since a and b are adjacent to t by definition, we only need to check if + the edge a-b exists. +- Because the graph is undirected, this simply means checking if b is in the adjacency list of a. + +```hs +findConnected :: Input -> String -> [[String]] +findConnected graph t = [sort [t, a, b] | a <- neighbours, + b <- neighbours, + a < b, + b `elem` (graph Map.! a)] + where neighbours = graph Map.! t +``` + +--- + +Note: I sort the loop to get a "canonical" form. + +--- + +#### Getting all the loops + +Now that we can find all the loops for a given t-node, +we can find all the loops for all t-nodes. + +```hs +partOne :: Input -> Output +partOne input = length . nub $ concatMap (findConnected input) ts + where ts = filter (('t' ==) . head) $ Map.keys input +``` + +--- + +## Part 2 + +### The problem + +We need to find the largest subset of nodes such that all nodes in that subset +are adjacent to each other. + +--- + +### The solution + +A subset of nodes in a graph where all nodes are adjacent to each other is called a +[clique](https://en.wikipedia.org/wiki/Clique_(graph_theory)). + +What we need to find is the largest maximal clique, which is a clique +that is not a subset of any other clique. + +Finding maximal cliques can be done using the +[Bron-Kerbosch algorithm](https://en.wikipedia.org/wiki/Bron–Kerbosch_algorithm). + +This isn’t too hard to implement in Haskell, but why reinvent the wheel +when the [Data.Algorithms.MaximalCliques](https://hackage.haskell.org/package/maximal-cliques-0.1.1/docs/Data-Algorithm-MaximalCliques.html) +library exists? + +All we need to do to use that library is provide two things: +1. A function that checks whether a node is adjacent to another: +```hs + isAdjacent a = (`elem` (input Map.! a)) +``` +2. A list of nodes: +```hs + where nodes = Map.keys input +``` + +--- + +```hs +partTwo :: Input -> String +partTwo input = intercalate "," . sort $ maxClique + where nodes = Map.keys input + isAdjacent a = (`elem` (input Map.! a)) + maxClique = maximumBy (compare `on` length) $ getMaximalCliques isAdjacent nodes +``` + +--- + +## The end part + +Maybe I’ll code the algorithm myself. Maybe. + +I’m happy to have learned a new concept, though—I didn’t know what a clique was before! diff --git a/2024/Day_23/sample b/2024/Day_23/sample new file mode 100644 index 0000000..3d49766 --- /dev/null +++ b/2024/Day_23/sample @@ -0,0 +1,32 @@ +kh-tc +qp-kh +de-cg +ka-co +yn-aq +qp-ub +cg-tb +vc-aq +tb-ka +wh-tc +yn-cg +kh-ub +ta-co +de-co +tc-td +tb-wq +wh-td +ta-ka +td-qp +aq-cg +wq-ub +ub-vc +de-ta +wq-aq +wq-vc +wh-yn +ka-de +kh-ta +co-tc +wh-qp +tb-vc +td-yn diff --git a/2024/README.md b/2024/README.md index 7bf6fcb..3c20a8f 100644 --- a/2024/README.md +++ b/2024/README.md @@ -9,7 +9,7 @@ Watch me code in Haskell for 25 days straight | [Day 02](./Day_02) | ✅ | ✅ | [Day 11](./Day_11) | ✅ | ✅ | [Day 20](./Day_20) | ✅ | ✅ | | [Day 03](./Day_03) | ✅ | ✅ | [Day 12](./Day_12) | ✅ | ✅ | [Day 21](./Day_21) | ✅ | ✅ | | [Day 04](./Day_04) | ✅ | ✅ | [Day 13](./Day_13) | ✅ | ✅ | [Day 22](./Day_22) | ✅ | ✅ | -| [Day 05](./Day_05) | ✅ | ✅ | [Day 14](./Day_14) | ✅ | ✅ | [Day 23](./Day_23) | | | +| [Day 05](./Day_05) | ✅ | ✅ | [Day 14](./Day_14) | ✅ | ✅ | [Day 23](./Day_23) | ✅ | ✅ | | [Day 06](./Day_06) | ✅ | ✅ | [Day 15](./Day_15) | ✅ | ✅ | [Day 24](./Day_24) | | | | [Day 07](./Day_07) | ✅ | ✅ | [Day 16](./Day_16) | ✅ | ✅ | [Day 25](./Day_25) | | | | [Day 08](./Day_08) | ✅ | ✅ | [Day 17](./Day_17) | ✅ | ✅ | | | | @@ -107,3 +107,7 @@ Too hard .w. ### [Day 22](./Day_22) Optimisation is useless when you can wait 2 minutes + +### [Day 23](./Day_23) + +Bron–Kerbosch algorithm