Solved day 25

day25a/.gitignore

@@ -0,0 +1,2 @@
+.stack-work/
+*~

day25a/day25a.cabal

@@ -0,0 +1,30 @@
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.35.2.
+--
+-- see: https://github.com/sol/hpack
+
+name:           day25a
+version:        0.1.0.0
+description:    Please see the README at <https://git.astolfo.cool/natty/aoc23#readme>
+author:         Natty
+maintainer:     natty.sh.git@gmail.com
+copyright:      2023 Natty
+build-type:     Simple
+
+executable day25a
+  main-is: Main.hs
+  other-modules:
+      Paths_day25a
+  hs-source-dirs:
+      src
+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N
+  build-depends:
+      MonadRandom
+    , base >=4.7 && <5
+    , containers
+    , megaparsec
+    , random
+    , random-shuffle
+    , text
+  default-language: Haskell2010

day25a/package.yaml

@@ -0,0 +1,36 @@
+name:                day25a
+version:             0.1.0.0
+author:              "Natty"
+maintainer:          "natty.sh.git@gmail.com"
+copyright:           "2023 Natty"
+
+description:         Please see the README at <https://git.astolfo.cool/natty/aoc23#readme>
+
+dependencies:
+- base >= 4.7 && < 5
+- megaparsec
+- containers
+- text
+- random-shuffle
+- random
+- MonadRandom
+
+ghc-options:
+- -Wall
+- -Wcompat
+- -Widentities
+- -Wincomplete-record-updates
+- -Wincomplete-uni-patterns
+- -Wmissing-export-lists
+- -Wmissing-home-modules
+- -Wpartial-fields
+- -Wredundant-constraints
+
+executables:
+  day25a:
+    main:                Main.hs
+    source-dirs:         src
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N

day25a/src/Main.hs

@@ -0,0 +1,72 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module Main (main) where
+
+import Control.Applicative (Alternative ((<|>)), Applicative (liftA2))
+import Control.Monad.Random (evalRand)
+import Data.Bifunctor (Bifunctor (bimap, first))
+import Data.List (sortBy, union)
+import Data.Map qualified as M
+import Data.Maybe (isNothing)
+import Data.Ord (Down (Down), comparing)
+import Data.Set qualified as S
+import Data.Text qualified as T
+import System.Random (RandomGen, newStdGen)
+import System.Random.Shuffle (shuffleM)
+
+parseGraph :: [T.Text] -> M.Map T.Text [T.Text]
+parseGraph =
+  (M.fromListWith union . concatMap (liftA2 fmap (flip (,) . pure . fst) snd) . M.assocs >>= M.unionWith union)
+    . M.fromList
+    . fmap parseLine
+  where
+    parseLine (T.splitOn ": " -> [name, T.words -> nodes]) = (name, nodes)
+    parseLine _ = error "parseLine error"
+
+bfsWalk :: ([T.Text] -> [T.Text]) -> T.Text -> M.Map T.Text [T.Text] -> M.Map (T.Text, T.Text) Integer
+bfsWalk shuffleMapper start graph = go [start] S.empty
+  where
+    go (node : xs) visited = foldl (flip (M.alter (fmap (+ 1) . (<|> Just 0)))) next (fmap (node,) neighbors)
+      where
+        neighbors = shuffleMapper $ filter (isNothing . flip S.lookupIndex visited) (graph M.! node)
+        next = go (xs ++ neighbors) (foldl (flip S.insert) visited neighbors)
+    go [] _ = M.empty
+
+shuffleList :: (RandomGen g) => g -> [a] -> [a]
+shuffleList = flip (evalRand . shuffleM)
+
+genFlipped :: [(T.Text, T.Text)] -> [(T.Text, T.Text)]
+genFlipped = (++) =<< fmap (uncurry (flip (,)))
+
+nodeCnt :: M.Map (T.Text, T.Text) Integer -> Integer
+nodeCnt = M.foldl (+) 0
+
+main :: IO ()
+main =
+  do
+    rng <- newStdGen
+    graph <- parseGraph . fmap T.pack . lines <$> getContents
+
+    let walkGraph = flip (bfsWalk (shuffleList rng))
+    let connectingEdges =
+          take 3
+            . sortBy (comparing (Down . snd))
+            . M.toList
+            . M.fromListWith (+)
+            . fmap (first ((,) <$> uncurry min <*> uncurry max))
+            . M.toList
+            . M.unionsWith (+)
+            $ walkGraph graph
+              <$> M.keys graph
+
+    let edgesToDrop = genFlipped $ fmap fst connectingEdges
+    let bisectedGraph = foldl (flip (\i -> M.adjust (filter (snd i /=)) (fst i))) graph edgesToDrop
+
+    print $ length . M.keysSet $ graph
+    let parts = bimap (nodeCnt . walkGraph bisectedGraph) (nodeCnt . walkGraph bisectedGraph) (head edgesToDrop)
+    print parts
+    print $ uncurry (*) parts

day25a/stack.yaml

@@ -0,0 +1,6 @@
+resolver: lts-21.21
+
+packages:
+- .
+
+extra-deps: []

day25a/stack.yaml.lock

@@ -0,0 +1,12 @@
+# This file was autogenerated by Stack.
+# You should not edit this file by hand.
+# For more information, please see the documentation at:
+#   https://docs.haskellstack.org/en/stable/lock_files
+
+packages: []
+snapshots:
+- completed:
+    sha256: 7d4b649cf368f9076d8aa049aa44efe58950971d105892734e9957b2a26a2186
+    size: 640060
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/21.yaml
+  original: lts-21.21

day25a/test.txt

@@ -0,0 +1,13 @@
+jqt: rhn xhk nvd
+rsh: frs pzl lsr
+xhk: hfx
+cmg: qnr nvd lhk bvb
+rhn: xhk bvb hfx
+bvb: xhk hfx
+pzl: lsr hfx nvd
+qnr: nvd
+ntq: jqt hfx bvb xhk
+nvd: lhk
+lsr: lhk
+rzs: qnr cmg lsr rsh
+frs: qnr lhk lsr

run.sh

@@ -30,7 +30,8 @@ case "$1" in
     "day08a" | "day08b" | \
     "day09a" | "day09b" | \
     "day10a" | "day10b" | \
-    "day11a" | "day11b") stack run <input.txt
+    "day11a" | "day11b" | \
+    "day25a") stack run <input.txt
        ;;
     # Default solutions -- Java
     *) ./gradlew run <input.txt

test.sh

@@ -30,7 +30,8 @@ case "$1" in
     "day08a" | "day08b" | \
     "day09a" | "day09b" | \
     "day10a" | "day10b" | \
-    "day11a" | "day11b") stack run <test.txt
+    "day11a" | "day11b" | \
+    "day25a" ) stack run <test.txt
        ;;
     # Default solutions -- Java
     *) ./gradlew run <test.txt