Day 24 + Day 25

Y2022.cabal

@@ -56,8 +56,11 @@ library
         Days.D19
         Days.D20
         Days.D21
+        Days.D24
+        Days.D25
     build-depends:
-        bytestring
+        array
+      , bytestring
       , either
       , hashable
       , hashtables              ^>=1.3.1
@@ -67,9 +70,11 @@ library
       , monad-loops             ^>=0.4.3
       , mtl
       , parser-combinators
-      , scanf                    ^>=0.1.0.0
+      , scanf                   ^>=0.1.0.0
       , text
       , vector                  ^>=0.13.0.0
+      , wide-word
+      
 
 executable Y2022
     import:           warnings, defaults

app/Main.hs

@@ -5,6 +5,8 @@ module Main where
 import Lib
 
 import System.Environment (getArgs)
+import Data.List (uncons)
+import Data.Maybe (mapMaybe)
 
 paths :: [FilePath]
 paths =
@@ -29,10 +31,19 @@ paths =
     , "./data/19.in"
     , "./data/20.in"
     , "./data/21.in"
+    , ""
+    , ""
+    , "./data/24.in"
+    , "./data/25.in"
     ]
 
 solutions :: [(Int, Day, FilePath)]
-solutions = zip3 [1 ..] (map head days) paths
+solutions =
+  let maybeSolutions = zip3 [1 ..] days paths
+      available (num, daySolutions, filepath) = do
+        (firstSolution, _) <- uncons daySolutions
+        return (num, firstSolution, filepath)
+   in mapMaybe available maybeSolutions
 
 runAll :: [(Int, Day, FilePath)] -> IO ()
 runAll = mapM_ (\(dayNum, day, path) -> run day path >>= printDR dayNum)

bench/Bench.hs

@@ -28,6 +28,10 @@ paths =
     , "./data/19.in"
     , "./data/20.in"
     , "./data/21.in"
+    , ""
+    , ""
+    , "./data/24.in"
+    , "./data/25.in"
     ]
 
 solutions :: [(Integer, [Day], FilePath)]

data/24.in

@@ -0,0 +1,37 @@
+#.####################################################################################################
+#<>^<v<<vv^^v>^^<v>>v.<<^.v<v>>^v>v>>vv<.>>>^^v>^.><^>>v<>>>>v^^^.v^v<>^^v><^vv<vv<>v<^v>><<^.<<^>^<>#
+#>^v<^^>.<v<<^.<<<<^v<^<<><<<v^>^>>>^^>v>^^>v>^><^>^>vv^>vv>.^^<>.>>vv<^>.<<vv<vv<v^^><v<vv^^^<<>v<^>#
+#.^<.>v^>.>>>.<>^><vv>^^v^<<^<>v<v^.vv.>>>vv^<.<v<<<<.<.v<^<^v^>.vv>><<..v>>.v><^>v>^>^>^^><.<^<>>vv>#
+#>v^<<^v>vv<<.>>^<<<><>v>vv.<>v^vv<>v^^.<>vvv>^<<<>v^><>v<^.^^^.<v<^><>^v>>.v<<<^v<>.^v<>>vv<^v^<v>><#
+#.<><<>vv>><>.><<.>><>v>v^v^vv>.^^v>>>^v.><>>>>v^v^<v<><^.v>^v>><<^<>^v>..<<>^<v<^v.>^<>><.<^v^v.^><>#
+#><..v^v><<<v<^v^<<<<><<<>.<><v..<>v<<^^v>^^vvv^<v^v.v^<>v^<<><<v<<^vv>.v><<vv.v<.vvv>..>vv^v<<^<^^^>#
+#<>^>^>.v<>>v^^v>^>v^><v>.>><<>vv^^v>>v<v>><^v><<>>>^.^<v<..<<>.^^<.^>.><<<^v^><v^v>v..^^>^v<^.<v<<<>#
+#>^^.v^v<>.>><>vv>.<>><>>><<>v><.v<^^^<>v>^v><^^<^.v.>>>v>v.vv>v>>v^.>.^>v^^<><vvv>>v>^v^<.v>^.>v><^>#
+#<^<<>..<<v<.v^<v<vv^^.<^^.<>>.vvv>>^.vv<><v.vv^>><>^<<>v.<.^v>v>^><>^^<v<><><>^^.vv<v^<>.>^v>^^v<><>#
+#><.><v>^v><>..v>vv<<v<<.v<<<v^^<vv.<>^<><v.^^v.v<^<<v.v^vv>>^.^v<<v.v<v<.<v^vv>^vv<^>>^vvvv>^^>>^^><#
+#<^<>vvv>^.>v>>.><>><v>^.>v<>v^v^<^<^^><>>v<v<vv>^><^>.^v^v<^^v><>>v^^<<<vvv.^^>>>^><<<^v><>^^^.v<<v>#
+#.^^.<v>>v.>^.v<^.^.^vv^<>>.v>^<>v<v^v>>^v><<vv^^.v>^v>vvv^^^<>^<>^>vv>vvv.<>vv>^<.v>.<>.vv<>>.>vvv<>#
+#<^^<.^>>v><><^v<.<.><<v^v>v>>v>v^.<.v<.v.v<.>><^>^v<<^^<^^^.^.>>.v>^><v<^><<^>^.>^v^^>v^v<>^>^<.>.><#
+#<.^v>>>.v<<<^.v.>v^^<^>v<<v<^>^v^v^.^<>><v^v<<v.<vv<>^v>^v.^><^.v>><>vvv^^<<^>.<v<<<v<>^vv.^v.vv<..<#
+#.v^v>>v^vv^v>v.v<v>v>^<<v^v><..v<<>>vv^<<v><^^<<<<^>v>vv^<^v^vv><.^^<v^<^vv^<<>>v^><v.^^^vvv>^>^>^v>#
+#<>.>^vv<>v^<vv<<^<.^^^.v>^><>><^^>v<<^^>^>.^^<.v><>v<v>^^v>>^>>.>>.<>vv><^^<^<<>><^vv>>v>^^.^><.<vv<#
+#<^>^v^<^<><<^vv>><v^.v<>>.v<v<><>^v^^<<><>v>^v^v>^^^vvv>>v^<v^^v.v.v<>>>v>><>><>>^..v<>><^v^>><.>^<<#
+#<v^^>>^^<^>.<^>>>v<<v.<.^>vv^^><<vvv<>vvvv^<v^<^<<<v<>>^>vv<^<.v<<<>><v<<v>^v>>.<v<vv^.>.><v^vv<>^.>#
+#>>v>^<.>.v<v.<<<<<v.>^>>>.>v<v>.vv^>^>v>^<>^.^^<v>^^>><><v^^.^>..^.>v>^<v<^v^.>v.v.^<><<><<v<<<^>>><#
+#<>v>>.v>.^>^<<><^v<.>^vv.>^.<v.>.>v<<^^>^><vvv>>vv<>^v.<^v<^>><<<<^^v^v<<^^v.<>^<v^>vvv>^<v>><<>^>^<#
+#<><<v<<<.v>^><^.v<>^vv>v><vv.v><v<v^v>^>^^<.>^^^^vv<>v<^.vvv.^v^>>^.v>><v^>.>v^v<.><>.>>v>v<>>>v^<^<#
+#<^<<<v..<>^<v^<>v>v<vv<v^<<.v^<<<^><v^^>><<v>^v.>>^.vv>>^v<.vv^v<^v^.^^.<.vv>>v>>^<^<<.>>><<<<vv^vv<#
+#<><>vv>^.vv><^^>^>^v^><v<>v>.<>>^v^<>^^^^v^v>>v<<<^v^>>^v^v<vv>vv>v>.><<^^>^<><><<<^<v>vv<<<^<>>^^v>#
+#<><<<<v>>v><^>vv<^><><>^<<^^>^.^^><.vvv<^<>^v^v^v>><>^<vv><^>>><.v<^^>>^vvv^^^v<.>vv^v>v^<<>v.^<.>v<#
+#.>>vv<.<vvv^>v^^v>v<v<^^v^^^.v^>>..^<<^^>><^<>v>.>>.<^><v>><><>v^<^^^v^>v^v>^<><<^>><^<..v><>>^<<v<>#
+#>v.>v>v^^v.v<v^<<<<>><>.<^v>^^<>^^>v^^>>..v^.v<>v>^v>..<v>><^<<><v<^<<.>^>^^<^v>.<v^^<>v..>v^v^^..><#
+#<v.><^v<><^^<.>><<>^^<v<v.v><><.<.>^.vv><v.<>^vv><v>>.<><>^^>><vv^^vvv>>v<^^v.><<>><>^^<^><<><>>>>^.#
+#><<v<v^v<<>^<>v<^><><<<><<v<>^<v^.v>>^<^>^^v<><<<v.v><<>>><>.^.>v<v<^^.^.>v>v>^<v>^<<>^>.<^<vv^<.v>>#
+#.v<<<.v<^>>^<>>v<>v.><>^^v>v<vvvv<<>v<<^.v<^^v>.v>^v>^..^<<.<..^>^.<v<.<<<.<vv^<v<>^.v^^><>>>^..^vv>#
+#<>^>>^^v^>>>.>v^v<^^<<v^^><^<><v.^^v^v<>v>>.>><vv><<<><^v.v<>v><><v<.v<>^v>>>^^v<<v<v>^>vv^v>^v>^.<<#
+#><v^<><v<>vvvv.>vvvvv^.<<<><v.><^^v<v><<>^^.<^>v<^v>.^><>>v.<^.<<.^^.>vv<<<<^.>^^v<v^....v>>>><v.><<#
+#<^>.<<^^^<<>.<>v^^^v<<^>>vv<^.<>>v.^v<^^.<v>v<>^^v>>v.^>vv<<<<>vvv<<.^>v<v<.>>v<^v^vv^<^.^>v.>^.>^^<#
+#<><^<v.^><><v^<<><.>>^^>>v><^<^^v>>^>>^>^<>^>v<^><.<>v^<^v^<<<v^.>..<<vvv<>..v^>>>v>v<<>..<>>>vvv><<#
+#<>>vv>v.^v>.^<><>.v..<<^v><v^>v^v>^^><.>>><<^>v<v<>^^^^vv.<>v.vv>>^<^.>^<>.<^>^<<^v^^<v<>v>^>vv>^<>.#
+#<v<>><v^^v.^^^<^v>^>>v>v<>^<v.^^><.<.>><^^<.vvv<<<.vv^>^>^<v^v.>^vv<^>^>vvv^^^.v<<<^^<>v<<><vv^<<<>>#
+####################################################################################################.#

data/25.in

@@ -0,0 +1,107 @@
+21211-122
+1=--02-10=-=00=-0
+1=-2
+1-1-1-===2=0--1-
+1211=
+1=22=-=
+1-0-=0210
+2-0-02
+1=1--1=-0210---=-1
+200-0=02--2
+20112=02
+1201--=-022
+1-100==
+1-
+1=-1=22===200101-2
+1==0010221-=22--0-02
+1002=11022
+1=02
+222=---112-=21=02=
+21==10--=01-1-=1
+1===--11=102
+2==2=0022=1=102
+101221=-2-=-00-12
+10=12220==---
+1-2
+2--01112
+11=01-=1002-
+1==-00-=10
+10=2==-=
+10-1=-=20-2-=
+1=1
+2120-
+2-2-=-0==-
+1-2-22=001-=-000
+21222-2222=102-2--
+101010
+1=0110
+1-21
+10
+1=022==2-
+102-21==010
+20=-2-
+1==-==
+1=-0212===101
+111202220=12-1-=-2
+1-11110-==0=0-0=2
+2=2-0=0=02-2=-0-0=0
+10=22=11-1-1-21-021
+1212
+20=1=00202-==2--
+1==2
+100--
+122=-
+2=220010
+202-222=212100-110
+20021=222==1--==-=
+1==2212=-
+1=-11--221===1==
+21=21021-=1
+2-
+11=02-=-----1=0=
+10=2-00200
+111-
+12=1=12121==-=-=-
+1==0-
+2--2-0=0-=2=21
+1==02-0=022-1=2-
+1-112
+1--01--2=2=
+221=1=20-=0-==
+1=2-0-21--
+1=11
+1120-=00-==2=
+1-=1-02101-02
+221-1=
+1---=-=1211
+22=
+221-=21=2010
+2-2102=
+2--121=11-011
+1-1-01-1=2=001
+2-=-=22-=01--
+1-0=20=22
+2002122211=02
+1-2-21-21211012=
+2=0200201=
+2=-102-
+1==202=-2==1=
+1=0=010120=
+2==1100-01==-0
+1220112102111=0
+1=10=1-=-2=
+1=-200020=-1001
+11=11-=2
+1==01=11=0=2-2==
+2=0-0-1=11-222=
+1221=0-1=
+1-=1-022
+10-1=22---021=1
+1011-1-=22-12
+1=0-122=-1==
+2111-0=20=
+1==01100-=
+200111102
+12=0-2=2112--121=1
+2=01
+1==221=2211--2011

src/Days/D24.hs

@@ -0,0 +1,114 @@
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+
+module Days.D24 where
+
+import Common
+import Control.Monad (foldM_)
+import Control.Monad.ST (ST, runST)
+import Data.Bits
+import Data.Text (Text)
+import Data.Text qualified as Text
+import Data.Vector.Storable qualified as UnVector
+import Data.Vector.Storable.Mutable qualified as MUnVector
+import Data.WideWord.Word128
+
+data Input = Input
+  { width :: Int,
+    height :: Int,
+    horizontal :: UnVector.Vector Word128,
+    vertical :: UnVector.Vector Word128
+  }
+  deriving (Show)
+
+parse :: Text -> Either String Input
+parse text =
+  let inner = tail . init . map (Text.tail . Text.init) . Text.lines $ text
+      height = length inner
+      width = Text.length (head inner)
+      [l, r, u, d] = map (`construct` inner) ['<', '>', '^', 'v']
+      hMerge time lrow rrow =
+        let left_ = (lrow `shiftL` time) .|. (lrow `shiftR` (width - time))
+            right = (rrow `shiftR` time) .|. (rrow `shiftL` (width - time))
+         in left_ .&. right
+      horizontal =
+        UnVector.fromList $
+          concatMap (\time -> zipWith (hMerge time) (UnVector.toList l) (UnVector.toList r)) [0 .. width - 1]
+      vertical =
+        UnVector.fromList
+          [ let up__ = u UnVector.! ((row + time) `mod` height)
+                down = d UnVector.! ((row - time) `mod` height)
+             in up__ .&. down
+            | time <- [0 .. height - 1],
+              row <- [0 .. height - 1]
+          ]
+   in Right (Input {width, height, horizontal, vertical})
+  where
+    setBitIf bitmap bool = (bitmap `shiftL` 1) .|. (if bool then 0 else 1)
+    construct char = UnVector.fromList . map (foldl setBitIf 0 . map (char ==) . Text.unpack)
+
+type Restart = forall s. MUnVector.MVector s Word128 -> ST s Bool
+
+explore :: Restart -> Input -> Int -> Int
+explore restart (Input {..}) initTime = runST $ MUnVector.replicate (height + 1) 0 >>= flip go initTime
+  where
+    go :: MUnVector.MVector s Word128 -> Int -> ST s Int
+    go state time =
+      restart state >>= \case
+        True -> return time
+        False -> do
+          () <-
+            foldM_
+              ( \prevRow row ->
+                  do
+                    curRow <- MUnVector.read state row
+                    nextRow <- MUnVector.read state (row + 1)
+
+                    let newOpts = curRow .|. (curRow `shiftL` 1) .|. (curRow `shiftR` 1) .|. prevRow .|. nextRow
+                    let pruned =
+                          newOpts
+                            .&. (horizontal UnVector.! (height * (time `mod` width) + row))
+                            .&. (vertical UnVector.! (height * (time `mod` height) + row))
+
+                    MUnVector.write state row pruned
+
+                    return curRow
+              )
+              0
+              [0 .. height - 1]
+
+          go state (time + 1)
+
+restartStart :: Input -> Restart
+restartStart Input {..} state = do
+  start <- MUnVector.read state 0
+  MUnVector.write state 0 (setBit start (width - 1))
+  flip testBit 0 <$> MUnVector.read state (height - 1)
+
+restartEnd :: Input -> Restart
+restartEnd Input {..} state = do
+  start <- MUnVector.read state (height - 1)
+  MUnVector.write state (height - 1) (start .|. 1)
+  flip testBit (width - 1) <$> MUnVector.read state 0
+
+part1 :: Input -> Int
+part1 input = explore (restartStart input) input 0
+
+part2 :: Input -> Int
+part2 input =
+  explore (restartStart input) input
+    . explore (restartEnd input) input
+    . explore (restartStart input) input
+    $ 0
+
+day :: Day
+day =
+  TextDay
+    ( \text -> do
+        input <- parse text
+        return (definitive $ part1 input, definitive $ part2 input)
+    )

src/Days/D25.hs

@@ -0,0 +1,37 @@
+module Days.D25 where
+
+import Common
+
+snafu :: Int -> String
+snafu = reverse . encode
+  where
+    encode 0 = []
+    encode n =
+      let (d, m) = (n + 2) `divMod` 5
+       in ( case m of
+              0 -> '='
+              1 -> '-'
+              2 -> '0'
+              3 -> '1'
+              4 -> '2'
+              _ -> error "unreachable"
+          )
+            : encode d
+
+decimal :: String -> Maybe Int
+decimal = fmap (foldl ((+) . (5 *)) 0) . mapM fromDigit
+  where
+    fromDigit :: Char -> Maybe Int
+    fromDigit '=' = Just (-2)
+    fromDigit '-' = Just (-1)
+    fromDigit '0' = Just 0
+    fromDigit '1' = Just 1
+    fromDigit '2' = Just 2
+    fromDigit _ = Nothing
+
+
+part1 :: String -> Maybe String
+part1 = fmap (snafu . sum) . mapM decimal . lines
+
+day :: Day
+day = StringDay (\string -> Right (Answer <$> part1 string, definitive "MERRY CHRISTMAS"))

src/Lib.hs

@@ -33,6 +33,8 @@ 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.D24 qualified as D24
+import Days.D25 qualified as D25
 
 import Data.ByteString.Char8 qualified as BS
 import Data.Text.IO qualified as T
@@ -66,4 +68,8 @@ days =
     , [D19.day]
     , [D20.day]
     , [D21.day]
+    , []
+    , []
+    , [D24.day]
+    , [D25.day]
     ]

src/Print.hs

@@ -4,14 +4,14 @@ import Common
 import Text.Printf (printf)
 
 printHeader :: IO ()
-printHeader = putStrLn "[ Day ]-------(1)------+-------(2)------"
+printHeader = putStrLn "[ Day ]-----------(1)----------+-----------(2)----------"
 
 printFooter :: IO ()
-printFooter = putStrLn "[-----]----------------+----------------"
+printFooter = putStrLn "[-----]------------------------+------------------------"
 
 printDR :: Int -> DayResult -> IO ()
 printDR day (Left errorString) = printf "[  %2d ] ====== PARSER ERROR =======\n%s" day errorString
 printDR day (Right (sol1, sol2)) =
     let r1 = maybe "unsolved" show sol1
         r2 = maybe "unsolved" show sol2
-     in printf "[  %2d ] %14s | %14s\n" day r1 r2
+     in printf "[  %2d ] %22s | %22s\n" day r1 r2