Day 23

Sadly too slow

Y2022.cabal

@@ -56,6 +56,7 @@ library
         Days.D19
         Days.D20
         Days.D21
+        Days.D23
         Days.D24
         Days.D25
     build-depends:

app/Main.hs

@@ -2,40 +2,39 @@
 
 module Main where
 
-import Lib
-
-import System.Environment (getArgs)
 import Data.List (uncons)
 import Data.Maybe (mapMaybe)
+import Lib
+import System.Environment (getArgs)
 
 paths :: [FilePath]
 paths =
-    [ "./data/01.in"
+  [ "./data/01.in",
-    , "./data/02.in"
+    "./data/02.in",
-    , "./data/03.in"
+    "./data/03.in",
-    , "./data/04.in"
+    "./data/04.in",
-    , "./data/05.in"
+    "./data/05.in",
-    , "./data/06.in"
+    "./data/06.in",
-    , "./data/07.in"
+    "./data/07.in",
-    , "./data/08.in"
+    "./data/08.in",
-    , "./data/09.in"
+    "./data/09.in",
-    , "./data/10.in"
+    "./data/10.in",
-    , "./data/11.in"
+    "./data/11.in",
-    , "./data/12.in"
+    "./data/12.in",
-    , "./data/13.in"
+    "./data/13.in",
-    , "./data/14.in"
+    "./data/14.in",
-    , "./data/15.in"
+    "./data/15.in",
-    , "./data/16.in"
+    "./data/16.in",
-    , "./data/17.in"
+    "./data/17.in",
-    , "./data/18.in"
+    "./data/18.in",
-    , "./data/19.in"
+    "./data/19.in",
-    , "./data/20.in"
+    "./data/20.in",
-    , "./data/21.in"
+    "./data/21.in",
-    , ""
+    "",
-    , ""
+    "./data/23.in",
-    , "./data/24.in"
+    "./data/24.in",
-    , "./data/25.in"
+    "./data/25.in"
-    ]
+  ]
 
 solutions :: [(Int, Day, FilePath)]
 solutions =
@@ -51,12 +50,15 @@ runAll = mapM_ (\(dayNum, day, path) -> run day path >>= printDR dayNum)
 usage :: IO ()
 usage = putStrLn "./Main"
 
-
 main :: IO ()
 main =
-    printHeader
+  printHeader
-        >> getArgs
+    >> getArgs
-        >>= (\case
+    >>= ( \case
             ["all"] -> runAll solutions
-            _ -> runAll [last solutions])
+            ("day" : dayNumStrs) ->
-        >> printFooter
+              let dayNums = map read dayNumStrs
+               in runAll (filter (\(a, _, _) -> a `elem` dayNums) solutions)
+            _ -> runAll [last solutions]
+        )
+    >> printFooter

bench/Bench.hs

@@ -29,7 +29,7 @@ paths =
     , "./data/20.in"
     , "./data/21.in"
     , ""
-    , ""
+    , "./data/23.in"
     , "./data/24.in"
     , "./data/25.in"
     ]

data/23.in

@@ -0,0 +1,75 @@
+.#..###.##..##.####.#.....##.##.#..#.##.#..#.#.#.####..#####.#......#...#..
+###...#.#..##...#.##...#.###.###....##..##..######.#.#..#.#...#.##...#.#.#.
+.......#.###.....#.##.....##..#.#...##..#####.###.##......#.###.##.#####.##
+##.##...##..####.##.........#.##.#.#..####.##....#.#####.####.####..##..##.
+#..#.###...###...#..#..#..#.#.##.######.###..##########.#..#.##.#.#.##....#
+.#..#..##..#.#.......#.#....#######..#.##.##..##.#.#.#..#.##....#..##.#####
+.#.##..##.##...#.##.##..##.##.##..##...###..###.#...##..##....#.##....#####
+.###.###.#.##.###....#..###..###..##.#.#.#.#....#####.###.######...###.###.
+#...####.###.....#.....###...#..##.##...########.#.#.######...#..#.###....#
+..###.#.###..#.#.........#....#.#.#####.#.#.#....###.##..###...####.#.#...#
+###.#.######.##.#.##....##.##..##.#.#..#.#..##..#..##.###..##.########.#.#.
+.#...##.....###...##..###.#.##.....#.##..#.#.#..##.#...#.#.#.###.#....#.##.
+..####.#.#.###....###.#.....##...#.##.#...#..#.#..#####...######....#..##.#
+.##.#..##.###.###..#.#.#####.#.###......###..#.#..#..###..###..#.....#..##.
+#.#.#####..##.##...#...#...#..#...#.#.#..#........######.##.#...#..#.#..##.
+.#.####....#.#..##.##..#...##.##...##.....###.###.###..#.#....#.#.####.#..#
+##.#..#.###..###........#...##.#..##...####.##..#..#.##.#....##..##..#####.
+...#..##.#..##.####..###...#.#.#.......#####..######....###..#.#..###.###..
+.#.##...#.#.#........##..#.#####.#####...##......#.##.....#..####..#####...
+.#.#..#..#.#.#.####.#...###.###.#..###...###.##..##...##..####.#.....#.#.##
+##...#.#...##..##..##..##.####..######...##..#...##..##.##....##...#.#.....
+..####.#####..##.####...#...#...#.#.#..##.##..#...###.#..#...#...#.#...#.##
+..###.#....#.########...##....#..#.#.#..#.##..#...#.##.....#.###..#..#..#.#
+#.##....###.#..##.#.##..####..###......####.###.##..###....#..#.#.#...####.
+.######.#....#....#####...#..#..###.#..#...#.###.#.##..#.###..#..###......#
+#..##.#.#####.#.#.##.#..###.#..#..#.#..#.#..#.#.....##########.#..#..#..#.#
+###.##....#...####.###..##..#....#.#......#.#.#......#..##.#..####...#..#.#
+..#.###..#.###.##.#..#....#..#####.#.#.####.#...#....#.##.#.#..###.########
+..#.#.....##.##...#..##...#.#..##.####.###.#.#..#..####...#..##..##..#.###.
+.###..#.###....#.####.#..#...###.#....#...#....###.#.######.####..#.#..###.
+.#.##.##.....#.###.#...#..#.#.##.##..#.#..###.##..#.##....##....#.#...#.##.
+#.##.#..#.#.#....##...####.#..#.###..######.###.#..##.#.#.#####...##..#.##.
+#.###.##.#..#...#..##..#.##.....#...#....#...##....#..#..##..##.##....##.##
+..###..#...#.#..##.##..#####.#..#.#..#...#...##.#.#..#..#.###....#.####.###
+###.###...####..###..#..#.##..#.#.#.....#....#.#####.#..###.#..####....##.#
+#.###.#.#.##.###.##.........###.#..#######.####..........#.#.###..#.#.##.#.
+####.##.#####.##.#.#.##......#...#.#.##..###..#...#...###..###.#####..##...
+.##...#####.##########.#....##.......#.#.#.#.###..#####....#..#.####..#####
+####..#..####.###..###..#####.###....#.#.#.....#.####..#..###.#..##.##..##.
+###.#.#....##..#.##.#.....##..##.##..##.###.##.#.#...####...#.##..####..##.
+#..#..##.#....###..##.#..#...#.#.#.#.######.##..#...##.#.#.....####..##.##.
+....####..###.#.##..#...#..##..#####.....##.##..#.##..##...#####.....##..#.
+.##...##...######..##..#.##..##.#.#..##.##..###.#.####...#######..##....#..
+.###.##.#......###....#####.#.#.##...#####..#..##.###...##...###.#.##...##.
+.#....####..#..#..##...##....#.##...###..##.#..#.#.#.#.####.....###...#.###
+##.###..#....##....#.##..#.#.....#...###..##..###....#.....###...##.....###
+##......#.##.#.###...##..###.....#.##.#..#.###..###.#.##...#####..###..#.##
+##.##.#####........#..##........#..##..##......#.###.#.#..##.######.#....##
+##.....#.##...#.####.####...#.###.#....#.######.#....#.#.##....#...##..##.#
+#.##.....#####.###.###.##.#.#.#..#....#.....#.#..###.####.#####...#.......#
+...#######......###.##.#.#.#.....######.#.##.#.#...#..#.#....#.#.#.##..###.
+#.###..#.##.#####..#.#...##.####.###.#####..#.....#...#.#..##.#.####.##.#..
+.##..##...##....#####.#...####..#....#..##.#...#####.#.##...#.####.###...##
+..####.###...##.##.#..#.###.##..#....#.#....###.#..##.#.....#.###....##.#..
+#.##.#...#..##.####.######.##..#.#......#.###...#..##.#..##..###.#..#.#.#.#
+..##.##..#..#.####.###.#...##.###.###.##..##.###....##...##.#..##.###...##.
+.####..#....#####..#..##....#.#.##.#####.#####..#.....###.#..###.####......
+##...#.#.#..##..##....##.###...#.##..#..#....###....#####.##..##.....####.#
+#..####...####..##..#..#..#.#.....##.#..#####..#.#.###.#..###.....#.#.###.#
+.##..####.####...#.#....##..#####..#...#...#..###..##......#...#..#.##.###.
+#..##..###.###.#.#..##..#.#.###....##..##.###.#..#....#.#.#..#..##.#..####.
+#.####..##....#...#.#...###..#..##...##.#.#.#.#...#..#...##...#...#.#....#.
+#..###.###...###.#.###.#....#..##....#.#.#..#.##.###.#####..##.###...#.#...
+.#..###.#.#..#.#.#...####.#.#.##.###.#..##.##.......#.#.#.#.#...#..#.#...##
+######.....###...#..#..###.#.#...#...##..##.##.#..#.#...###.##.##....#.#...
+#..##...#...##...###..#....#...###.#.###.###..#..##.##..####..#.###.##....#
+..##...#..#.#.#######..#.###..#.#.#.#.##.#..#.....#.##.###.#####.#.######..
+#.#.#..##.#.###.#....#..#..######.#....##.#..###.####.#......#..##.##.##.##
+######....##......#..#...####..###..######.#.#.##....#...##.#.#..#.#.#.##..
+###.####.###.#####.....######..#...#.##.#....##.#.##..#.#.##.#.##..###..###
+..######....####..###..##..##.##...#.###..#.##..#.#...#.##.##.....#..#..###
+.##..##..#.##....#...##.###.##..#...##..##.##.#.#..###...##....#.#.#..#...#
+..#..##.########.##..#####.#....#..##.##.##.#...#.##..##.#..#..###...#.#.##
+#.##....#..#.#..##.#......#.#..##.#.............#.##.#...##.#..#...##.#.###
+#..#..###.#.##.#..#....##..#..#..##.##..#.##...###.......#..###..####...##.

src/Days/D23.hs

@@ -0,0 +1,87 @@
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TupleSections #-}
+{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+
+module Days.D23 where
+
+import Common
+import Control.Monad (zipWithM)
+import Control.Monad.ST.Strict (runST)
+import Data.Functor ((<&>))
+import Data.HashTable.Class qualified as HT
+import Data.HashTable.ST.Basic qualified as HTB
+import Data.List (tails)
+import Data.List.Extra (scanl')
+import Data.Maybe (fromMaybe, isJust)
+
+type V2 = (Int, Int)
+
+preprocess :: String -> [V2]
+preprocess =
+  concatMap (\(row, line) -> [(row, col) | (col, ch) <- zip [0 ..] line, ch == '#'])
+    . zip [0 ..]
+    . lines
+
+data Direction = N | S | E | W
+
+dance :: [Direction] -> [V2] -> [V2]
+dance directions pts =
+  runST $ do
+    proposals <- HTB.newSized (length pts)
+    elfSet <- HT.fromList $ map (,()) pts
+    dsts <-
+      mapM
+        ( \(x, y) -> do
+            neighbours <- sequence [isJust <$> HTB.lookup elfSet (x + xd, y + yd) | xd <- [-1 .. 1], yd <- [-1 .. 1], not (xd == 0 && yd == 0)]
+            let [nw, n, ne, w, e, sw, s, se] = neighbours
+
+            ( if or neighbours
+                then
+                  ( let move dirs =
+                          case dirs of
+                            [] -> (x, y)
+                            (dir : rest) -> case dir of
+                              N -> if nw || n || ne then move rest else (x - 1, y)
+                              S -> if sw || s || se then move rest else (x + 1, y)
+                              W -> if nw || w || sw then move rest else (x, y - 1)
+                              E -> if ne || e || se then move rest else (x, y + 1)
+                        dst = move directions
+                     in HT.mutate proposals dst (\old -> (Just . ((1 :: Int) +) . fromMaybe 0 $ old, dst))
+                  )
+                else return (x, y)
+              )
+        )
+        pts
+
+    let update old new = HT.lookup proposals new <&> (\case Nothing -> new; Just n -> if n > 1 then old else new)
+    zipWithM update pts dsts
+
+procession :: [V2] -> [[V2]]
+procession initial =
+  let choreo = map (take 4) . tails . cycle $ [N, S, W, E]
+   in scanl' (flip dance) initial choreo
+
+part2 :: [V2] -> Int
+part2 = findDup 1 . procession
+  where
+    findDup :: (Eq a) => Int -> [a] -> Int
+    findDup acc (x : y : xs) = if x == y then acc else findDup (acc + 1) (y : xs)
+
+part1 :: [V2] -> Int
+part1 = score . (!! 10) . procession
+  where
+    score pts =
+      let (fsts, snds) = (map fst pts, map snd pts)
+          (fmin, fmax) = (minimum fsts, maximum fsts)
+          (smin, smax) = (minimum snds, maximum snds)
+       in (fmax - fmin + 1) * (smax - smin + 1) - length pts
+
+day :: Day
+day =
+  StringDay
+    ( \string ->
+        let input = preprocess string
+         in Right (definitive $ part1 input, definitive $ part2 input)
+    )

src/Lib.hs

@@ -33,6 +33,7 @@ import Days.D18 qualified as D18
 import Days.D19 qualified as D19
 import Days.D20 qualified as D20
 import Days.D21 qualified as D21
+import Days.D23 qualified as D23
 import Days.D24 qualified as D24
 import Days.D25 qualified as D25
 
@@ -69,7 +70,7 @@ days =
     , [D20.day]
     , [D21.day]
     , []
-    , []
+    , [D23.day]
     , [D24.day]
     , [D25.day]
     ]