Day 10

Y2022.cabal

@@ -43,6 +43,7 @@ library
         Days.D07
         Days.D08
         Days.D09
+        Days.D10
     build-depends:
         bytestring
       , megaparsec              ^>=9.4.0

app/Main.hs

@@ -17,6 +17,7 @@ paths =
     , "./data/07.in"
     , "./data/08.in"
     , "./data/09.in"
+    , "./data/10.in"
     ]
 
 solutions :: [(Int, Day, FilePath)]

bench/Bench.hs

@@ -16,6 +16,7 @@ paths =
     , "./data/07.in"
     , "./data/08.in"
     , "./data/09.in"
+    , "./data/10.in"
     ]
 
 solutions :: [(Integer, [Day], FilePath)]

data/10.in

@@ -0,0 +1,140 @@
+noop
+addx 5
+noop
+noop
+noop
+addx 1
+addx 2
+addx 5
+addx 2
+addx 5
+noop
+noop
+noop
+noop
+noop
+addx -12
+addx 18
+addx -1
+noop
+addx 3
+addx 5
+addx -5
+addx 7
+noop
+addx -36
+addx 18
+addx -16
+noop
+noop
+noop
+addx 5
+addx 2
+addx 5
+addx 2
+addx 13
+addx -6
+addx -4
+addx 5
+addx 2
+addx 4
+addx -3
+addx 2
+noop
+addx 3
+addx 2
+addx 5
+addx -40
+addx 25
+addx -22
+addx 25
+addx -21
+addx 5
+addx 3
+noop
+addx 2
+addx 19
+addx -10
+addx -4
+noop
+addx -4
+addx 7
+noop
+addx 3
+addx 2
+addx 5
+addx 2
+addx -26
+addx 27
+addx -36
+noop
+noop
+noop
+noop
+addx 4
+addx 6
+noop
+addx 12
+addx -11
+addx 2
+noop
+noop
+noop
+addx 5
+addx 5
+addx 2
+noop
+noop
+addx 1
+addx 2
+addx 5
+addx 2
+addx 1
+noop
+noop
+addx -38
+noop
+addx 9
+addx -4
+noop
+noop
+addx 7
+addx 10
+addx -9
+addx 2
+noop
+addx -9
+addx 14
+addx 5
+addx 2
+addx -24
+addx 25
+addx 2
+addx 5
+addx 2
+addx -30
+addx 31
+addx -38
+addx 7
+noop
+noop
+noop
+addx 1
+addx 21
+addx -16
+addx 8
+addx -4
+addx 2
+addx 3
+noop
+noop
+addx 5
+addx -2
+addx 5
+addx 3
+addx -1
+addx -1
+addx 4
+addx 5
+addx -38
+noop

src/Days/D10.hs

@@ -0,0 +1,55 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Days.D10 where
+
+import Common
+import Parse
+
+import Data.List.Extra (chunksOf)
+import Text.Megaparsec ((<|>))
+import Text.Megaparsec.Char (space, string)
+
+data Instruction = Noop | Addx Int
+
+type Trace = [Int]
+
+parser :: Parser [Instruction]
+parser = someLines instruction
+ where
+  instruction :: Parser Instruction
+  instruction = (Noop <$ string "noop") <|> (Addx <$ string "addx" <* space <*> int)
+
+trace :: [Instruction] -> Trace
+trace =
+  scanl (+) 1
+    . foldMap
+      ( \case
+          Noop -> [0]
+          Addx x -> [0, x]
+      )
+
+snapshot :: [Int] -> [a] -> [a]
+snapshot idxs l = [l !! (ix - 1) | ix <- idxs]
+
+cycles :: [Int]
+cycles = [20, 60, 100, 140, 180, 220]
+
+part1 :: Trace -> Int
+part1 = sum . zipWith (*) cycles . snapshot cycles
+
+part2 :: Trace -> String
+part2 = parseCRT . screenCrop . zipWith ((render .) . inRange) (cycle [0 .. 39])
+ where
+  inRange :: Int -> Int -> Bool
+  inRange a b = let d = b - a in d == 0 || d == 1 || d == -1
+
+  render :: Bool -> Char
+  render True = '#'
+  render False = '.'
+
+  screenCrop :: String -> [String]
+  screenCrop = take 6 . chunksOf 40
+
+day :: Day
+day = parsecDay (trace <$> parser) (definitive . part1, definitive . part2)

src/Lib.hs

@@ -20,6 +20,7 @@ import Days.D06 qualified as D06
 import Days.D07 qualified as D07
 import Days.D08 qualified as D08
 import Days.D09 qualified as D09
+import Days.D10 qualified as D10
 
 import Data.ByteString.Char8 qualified as BS
 import Data.Text.IO qualified as T
@@ -41,4 +42,5 @@ days =
     , [D07.day]
     , [D08.day]
     , [D09.day]
+    , [D10.day]
     ]

src/Parse.hs

@@ -13,6 +13,13 @@ import Text.Megaparsec.Char qualified as MC
 import Text.Megaparsec.Char.Lexer qualified as MCL
 import Util (both)
 
+import Data.List (transpose)
+import Data.List.Extra (chunksOf)
+
+import Data.Map (Map)
+import Data.Map qualified as M
+import Data.Maybe (fromMaybe)
+
 type Parser = M.Parsec Void T.Text
 
 someLines :: Parser a -> Parser [a]
@@ -21,6 +28,9 @@ someLines p = p `M.sepEndBy1` MC.newline
 number :: Parser Int
 number = MCL.decimal
 
+int :: Parser Int
+int = MCL.signed (pure ()) number
+
 digit :: Parser Int
 digit = digitToInt <$> digitChar
 
@@ -36,3 +46,80 @@ parsecDay parser parts =
                 Right parsedInput -> Right $ both (parsedInput &) parts
             )
         )
+
+parseCRT :: [String] -> String
+parseCRT = map (\grid -> fromMaybe '?' (M.lookup grid gridToChar)) . slice
+  where
+    slice :: [String] -> [[String]]
+    slice = transpose . map (chunksOf 5)
+
+gridToChar :: Map [String] Char
+gridToChar =
+    M.fromList
+        [
+            (
+                [ ".##.."
+                , "#..#."
+                , "#..#."
+                , "####."
+                , "#..#."
+                , "#..#."
+                ]
+            , 'A'
+            )
+        ,
+            (
+                [ "###.."
+                , "#..#."
+                , "###.."
+                , "#..#."
+                , "#..#."
+                , "###.."
+                ]
+            , 'B'
+            )
+        ,
+            (
+                [ "#...."
+                , "#...."
+                , "#...."
+                , "#...."
+                , "#...."
+                , "####."
+                ]
+            , 'L'
+            )
+        ,
+            (
+                [ "###.."
+                , "#..#."
+                , "#..#."
+                , "###.."
+                , "#...."
+                , "#...."
+                ]
+            , 'P'
+            )
+        ,
+            (
+                [ "#..#."
+                , "#..#."
+                , "#..#."
+                , "#..#."
+                , "#..#."
+                , ".##.."
+                ]
+            , 'U'
+            )
+        ,
+            (
+                [ "####."
+                , "...#."
+                , "..#.."
+                , ".#..."
+                , "#...."
+                , "####."
+                ]
+            , 'Z'
+            )
+        ]