Finish day 10

.gitignore

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

aoc2022.cabal

@@ -1,6 +1,6 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.35.0.
+-- This file has been generated from package.yaml by hpack version 0.34.7.
 --
 -- see: https://github.com/sol/hpack
 
@@ -25,6 +25,7 @@ source-repository head
 
 library
   exposed-modules:
+      Day10Lib
       Day1Lib
       Day2Lib
       Day3Lib
@@ -33,6 +34,7 @@ library
       Day6Lib
       Day7Lib
       Day8Lib
+      Day9Lib
   other-modules:
       Paths_aoc2022
   hs-source-dirs:
@@ -44,6 +46,30 @@ library
     , split
   default-language: Haskell2010
 
+executable Day10Part1
+  main-is: Day10Part1.hs
+  hs-source-dirs:
+      day10
+  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 -main-is Day10Part1
+  build-depends:
+      aoc2022
+    , base >=4.7 && <5
+    , containers
+    , split
+  default-language: Haskell2010
+
+executable Day10Part2
+  main-is: Day10Part2.hs
+  hs-source-dirs:
+      day10
+  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 -main-is Day10Part2
+  build-depends:
+      aoc2022
+    , base >=4.7 && <5
+    , containers
+    , split
+  default-language: Haskell2010
+
 executable Day1Part1
   main-is: Day1Part1.hs
   hs-source-dirs:
@@ -236,6 +262,30 @@ executable Day8Part2
     , split
   default-language: Haskell2010
 
+executable Day9Part1
+  main-is: Day9Part1.hs
+  hs-source-dirs:
+      day9
+  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 -main-is Day9Part1
+  build-depends:
+      aoc2022
+    , base >=4.7 && <5
+    , containers
+    , split
+  default-language: Haskell2010
+
+executable Day9Part2
+  main-is: Day9Part2.hs
+  hs-source-dirs:
+      day9
+  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 -main-is Day9Part2
+  build-depends:
+      aoc2022
+    , base >=4.7 && <5
+    , containers
+    , split
+  default-language: Haskell2010
+
 test-suite Day1-test
   type: exitcode-stdio-1.0
   main-is: Day1.hs

day10/Day10Part1.hs

@@ -0,0 +1,11 @@
+module Day10Part1 (main) where
+
+import Day10Lib
+
+convertToString :: Int -> String
+convertToString = show
+
+main :: IO ()
+main = do
+  input <- getContents
+  putStrLn $ convertToString $ day10 input

day10/Day10Part2.hs

@@ -0,0 +1,8 @@
+module Day10Part2 (main) where
+
+import Day10Lib
+
+main :: IO ()
+main = do
+  input <- getContents
+  putStrLn $ day10' input

day10/input

@@ -0,0 +1,146 @@
+noop
+addx 5
+addx -2
+noop
+noop
+addx 7
+addx 15
+addx -14
+addx 2
+addx 7
+noop
+addx -2
+noop
+addx 3
+addx 4
+noop
+noop
+addx 5
+noop
+noop
+addx 1
+addx 2
+addx 5
+addx -40
+noop
+addx 5
+addx 2
+addx 15
+noop
+addx -10
+addx 3
+noop
+addx 2
+addx -15
+addx 20
+addx -2
+addx 2
+addx 5
+addx 3
+addx -2
+noop
+noop
+noop
+addx 5
+addx 2
+addx 5
+addx -38
+addx 3
+noop
+addx 2
+addx 5
+noop
+noop
+addx -2
+addx 5
+addx 2
+addx -2
+noop
+addx 7
+noop
+addx 10
+addx -5
+noop
+noop
+noop
+addx -15
+addx 22
+addx 3
+noop
+noop
+addx 2
+addx -37
+noop
+noop
+addx 13
+addx -10
+noop
+addx -5
+addx 10
+addx 5
+addx 2
+addx -6
+addx 11
+addx -2
+addx 2
+addx 5
+addx 3
+noop
+addx 3
+addx -2
+noop
+addx 6
+addx -22
+addx 23
+addx -38
+noop
+addx 7
+noop
+addx 5
+noop
+noop
+noop
+addx 9
+addx -8
+addx 2
+addx 7
+noop
+noop
+addx 2
+addx -4
+addx 5
+addx 5
+addx 2
+addx -26
+addx 31
+noop
+addx 3
+noop
+addx -40
+addx 7
+noop
+noop
+noop
+noop
+addx 2
+addx 4
+noop
+addx -1
+addx 5
+noop
+addx 1
+noop
+addx 2
+addx 5
+addx 2
+noop
+noop
+noop
+addx 5
+addx 1
+noop
+addx 4
+addx 3
+noop
+addx -24
+noop

day9/Day9Part1.hs

@@ -0,0 +1,11 @@
+module Day9Part1 (main) where
+
+import Day9Lib
+
+convertToString :: Int -> String
+convertToString = show
+
+main :: IO ()
+main = do
+  input <- getContents
+  putStrLn $ convertToString $ day9 input

day9/Day9Part2.hs

@@ -0,0 +1,11 @@
+module Day9Part2 (main) where
+
+import Day9Lib
+
+convertToString :: Int -> String
+convertToString = show
+
+main :: IO ()
+main = do
+  input <- getContents
+  putStrLn $ convertToString $ day9' input

package.yaml

@@ -231,6 +231,54 @@ executables:
     dependencies:
     - aoc2022
 
+  Day9Part1:
+    main:                Day9Part1.hs
+    other-modules:       []
+    source-dirs:         day9
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    - -main-is Day9Part1
+    dependencies:
+    - aoc2022
+
+  Day9Part2:
+    main:                Day9Part2.hs
+    other-modules:       []
+    source-dirs:         day9
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    - -main-is Day9Part2
+    dependencies:
+    - aoc2022
+
+  Day10Part1:
+    main:                Day10Part1.hs
+    other-modules:       []
+    source-dirs:         day10
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    - -main-is Day10Part1
+    dependencies:
+    - aoc2022
+
+  Day10Part2:
+    main:                Day10Part2.hs
+    other-modules:       []
+    source-dirs:         day10
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    - -main-is Day10Part2
+    dependencies:
+    - aoc2022
+
 tests:
   Day1-test:
     main:                Day1.hs

src/Day10Lib.hs

@@ -0,0 +1,93 @@
+module Day10Lib where
+
+import Data.List (transpose)
+
+data Instruction = Noop | Addx Int deriving (Show)
+type Register = Int
+type Cycle = Int
+
+type Computer = (Register, Cycle)
+
+processInstruction :: Computer -> Instruction -> [Computer]
+processInstruction (r, c) (Addx x) = [(r,c + 1), (r + x, c + 2)] 
+processInstruction (r, c) Noop = [(r,c + 1)] 
+
+processInstructions :: Computer -> [Instruction] -> [Computer]
+processInstructions comp@(r,c) (ins:inss) = processedComps ++ processInstructions processedComp inss
+    -- | c == 220 = [processedComp]
+    -- -- | c == 20 = processedComp : r * c + processInstructions processedComp inss
+    -- -- | c `mod` 40 == 0 = r * c + processInstructions processedComp inss
+    -- | otherwise = processedComp : processInstructions processedComp inss
+    where
+        processedComps = processInstruction comp ins
+        processedComp = last processedComps
+
+-- PARSING
+convertToInt :: String -> Int
+convertToInt s = read s :: Int
+
+parseInstruction :: String -> Instruction
+parseInstruction s = case firstPart of
+    "noop" -> Noop
+    "addx" -> Addx lastPart
+    where
+        asWords = words s
+        firstPart = head asWords
+        lastPart = convertToInt $ last asWords
+
+parseInput :: String -> [Instruction]
+parseInput i = map parseInstruction $ lines i
+
+-- Increment cycle by 1 to account for offset of looking at previous cycle to determine during cycle value
+accountForDuringCycleOffset :: Computer -> Computer
+accountForDuringCycleOffset (r, c) = (r, c + 1)
+
+getSignalStrength :: Computer -> Int
+getSignalStrength (r, c) = r * c
+
+day10 :: String -> Int
+day10 input = registerSum
+    where
+        -- There are less instructions than cycles we are interested in
+        -- The problem isn't clear about this but I believe the program loops
+        instructions = cycle $ parseInput input
+        -- Infinite computer list
+        startingState = (1,0)
+        icl = processInstructions (1, 0) instructions
+        -- -2 on all indexs, one for zero indexing the other for being about the value _during_ the cycle
+        cyclesOfInterest = [icl !! 18, icl !! 58, icl !! 98, icl !! 138, icl !! 178, icl !! 218]
+        registers = map getSignalStrength $ map accountForDuringCycleOffset cyclesOfInterest
+        registerSum = sum registers
+
+type Pixel = Bool
+
+drawPixel :: Pixel -> Char
+drawPixel False = '.'
+drawPixel True = '#'
+
+drawPixelGrid :: [[Pixel]] -> String
+drawPixelGrid grid = unlines $ map (map drawPixel) grid
+
+rowifyPixelList :: [Pixel] -> [[Pixel]]
+rowifyPixelList pl = [r1, r2, r3, r4, r5, r6]
+    where
+        r1 = take 40 pl
+        r2 = take 40 $ drop 40 pl
+        r3 = take 40 $ drop 80 pl
+        r4 = take 40 $ drop 120 pl
+        r5 = take 40 $ drop 160 pl
+        r6 = take 40 $ drop 200 pl
+
+zipPixelListWithComputerList :: Computer -> Int -> Pixel
+zipPixelListWithComputerList (r, c) pindex = if r == horizontalPostion || r - horizontalPostion == 1 || r - horizontalPostion == -1
+                                             then True
+                                             else False
+    where horizontalPostion = pindex `mod` 40
+
+day10' :: String -> String
+day10' input = drawPixelGrid $ rowifyPixelList $ zipWith zipPixelListWithComputerList icl pixelgrid
+    where
+        instructions = cycle $ parseInput input
+        startingState = (1,0)
+        icl = startingState : processInstructions (1, 0) instructions
+        pixelgrid = [0..239]

src/Day8Lib.hs

@@ -1,4 +1,7 @@
-module Day8Lib where
+module Day8Lib
+    ( day8
+    , day8'
+    ) where
 
 import Data.Char (digitToInt)
 import Data.List (findIndex, transpose, zip4, zipWith4)

src/Day9Lib.hs

@@ -0,0 +1,158 @@
+module Day9Lib 
+    ( day9
+    , day9'
+    ) where
+
+import qualified Prelude
+import Prelude hiding (Left, Right)
+import Data.List (nub)
+import Data.Maybe (Maybe)
+
+import Debug.Trace
+
+data Command =
+    Right Int
+    | Left Int
+    | Down Int
+    | Up Int
+    deriving (Show, Eq)
+type Coordinate = (Int, Int)
+
+moveCoord :: Coordinate -> Command -> Coordinate
+moveCoord (x,y) cmd = case cmd of
+    Right move -> (x + move, y)
+    Left move -> (x - move, y)
+    Down move -> (x, y - move)
+    Up move -> (x, y + move)
+
+multiMoveCoord :: Coordinate -> [Command] -> Coordinate
+multiMoveCoord (x,y) [] = (x,y)
+multiMoveCoord (x,y) (cmd:cmds) = multiMoveCoord (moveCoord (x,y) cmd) cmds
+
+-- coordinateDistance :: Coordinate -> Coordinate -> Double
+-- coordinateDistance (x1, y1) (x2, y2) = sqrt (((x1 + x2) ^ 2) + ((y1 + y2) ^ 2))
+
+-- Returns a list of commands the tail must execute if it has to move
+tailMoves :: (Coordinate, Coordinate) -> [Command]
+tailMoves ((hx, hy), (tx, ty))
+    -- Direct moves
+    | hx - tx > 1 && hy == ty = [Right 1]
+    | tx - hx > 1 && hy == ty = [Left 1]
+    | tx == hx && hy - ty > 1 = [Up 1]
+    | tx == hx && ty - hy > 1 = [Down 1]
+    -- Diagonal moves
+    | diagonalBool && hx > tx && hy > ty  = upRight
+    | diagonalBool && hx < tx && hy > ty  = upLeft
+    | diagonalBool && hx > tx && hy < ty  = downRight
+    | diagonalBool && hx < tx && hy < ty  = downLeft
+    -- No move, could be more complicated logic here, but using it as a catchall seems sufficient
+    | otherwise = []
+    where
+        diagonalBool = (hx /= tx && hy /= ty) && (abs (hx - tx) > 1 || abs (hy - ty) > 1)
+        upRight = [Up 1, Right 1]
+        upLeft = [Up 1, Left 1]
+        downRight = [Down 1, Right 1]
+        downLeft = [Down 1, Left 1]
+
+commandDistance :: Command -> Int
+commandDistance (Right d) = d
+commandDistance (Left d) = d
+commandDistance (Up d) = d
+commandDistance (Down d) = d
+
+distanceInCommands :: [Command] -> Int
+distanceInCommands commands = sum $ map commandDistance commands
+
+processCommands :: (Coordinate, Coordinate) -> [Command] -> [Coordinate] -> [Coordinate]
+processCommands (head, tail) [] tailPositions = tail : tailPositions
+processCommands (head, tail) (cmd:[]) tailPositions = processCommands (processedHead, processedTail) [] processedTailPositions
+    where
+        processedHead = moveCoord head cmd
+        processedTail = multiMoveCoord tail tailCommands
+        tailCommands = tailMoves (processedHead, tail)
+        tailCommandsDistance = distanceInCommands tailCommands
+        processedTailPositions = tail : tailPositions
+processCommands (head, tail) (cmd:cmds) tailPositions = processCommands (processedHead, processedTail) cmds processedTailPositions
+    where
+        processedHead = moveCoord head cmd
+        processedTail = multiMoveCoord tail tailCommands
+        tailCommands = tailMoves (processedHead, tail)
+        tailCommandsDistance = distanceInCommands tailCommands
+        processedTailPositions = tail : tailPositions
+
+
+type Snake = [Coordinate]
+
+-- Used for snake
+tuplify2List :: [a] -> [(a,a)]
+tuplify2List (x:[]) = []
+tuplify2List (x:y:[]) = (x,y) : tuplify2List (y:[])
+tuplify2List (x:y:rest) = (x,y) : tuplify2List (y:rest)
+
+moveSnakeHead :: Snake -> Command -> Snake
+moveSnakeHead (head:tail) cmd = moveCoord head cmd : tail 
+
+-- Move the snakes tail after the head has moved
+moveSnakeTail :: Snake -> Snake
+moveSnakeTail snake@(head:tail) = if null $ concat snakeMoves
+                                  then head : newtail
+                                  else moveSnakeTail (head : newtail)
+    where
+        snakeMoves = map tailMoves $ tuplify2List snake
+        newtail = zipWith (multiMoveCoord) tail snakeMoves
+
+-- Now for the big snake
+processCommands' :: Snake -> [Command] -> [Coordinate] -> [Coordinate]
+processCommands' (h:tails) [] tailPositions = last tails : tailPositions
+processCommands' snake@(h:tails) (cmd:[]) tailPositions = processCommands' snakeMovedTail [] processedTailPositions
+    where
+        snakeMovedHead = moveSnakeHead snake cmd
+        snakeMovedTail = moveSnakeTail snakeMovedHead
+        processedTailPositions = last tails : tailPositions
+processCommands' snake@(h:tails) (cmd:cmds) tailPositions = processCommands' snakeMovedTail cmds processedTailPositions
+    where
+        snakeMovedHead = moveSnakeHead snake cmd
+        snakeMovedTail = moveSnakeTail snakeMovedHead
+        processedTailPositions = last tails : tailPositions
+
+convertToInt :: String -> Int
+convertToInt s = read s :: Int
+
+-- Since each move is independent, this breaks all larger moves into single steps
+downPlayCommand :: Command -> [Command]
+downPlayCommand (Right d) = take d $ repeat (Right 1)
+downPlayCommand (Left d) = take d $ repeat (Left 1)
+downPlayCommand (Up d) = take d $ repeat (Up 1)
+downPlayCommand (Down d) = take d $ repeat (Down 1)
+
+downPlayCommands :: [Command] -> [Command]
+downPlayCommands commands = concat $ map downPlayCommand commands
+
+parseCommand :: String -> Command
+parseCommand s = case firstPart of
+    "R" -> Right lastPart
+    "L" -> Left lastPart
+    "D" -> Down lastPart
+    "U" -> Up lastPart
+    where
+        stringAsWords = words s
+        firstPart = head stringAsWords
+        lastPart = convertToInt $ last stringAsWords
+
+parseInput :: String -> [Command]
+parseInput input = map parseCommand $ lines input
+
+day9 :: String -> Int
+day9 input = uniqueTailPositions
+    where
+        commands = downPlayCommands $ parseInput input
+        tailPositions = processCommands ((0,0), (0,0)) commands []
+        uniqueTailPositions = length $ nub tailPositions
+
+day9' :: String -> Int
+day9' input = uniqueTailPositions
+    where
+        commands = downPlayCommands $ parseInput input
+        tailPositions = processCommands' startingSnake commands []
+        startingSnake = take 10 $ repeat (0,0)
+        uniqueTailPositions = length $ nub tailPositions

stack.yaml.lock

@@ -11,6 +11,13 @@ packages:
       size: 439
   original:
     hackage: split-0.2.3.5
+- completed:
+    hackage: containers-0.6.4.1@sha256:e9ca297369c207ff40ed561877c15928292b957a01c8551a7cbd50d665a03429,2520
+    pantry-tree:
+      sha256: cd4689c9caa5b9774b3ec4603c3b2c06eb04b184db590afa6d107441e25cc634
+      size: 2823
+  original:
+    hackage: containers-0.6.4.1
 snapshots:
 - completed:
     sha256: 6d1532d40621957a25bad5195bfca7938e8a06d923c91bc52aa0f3c41181f2d4