Finish day9

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
 
@@ -33,6 +33,7 @@ library
       Day6Lib
       Day7Lib
       Day8Lib
+      Day9Lib
   other-modules:
       Paths_aoc2022
   hs-source-dirs:
@@ -236,6 +237,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

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,30 @@ 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
+
 tests:
   Day1-test:
     main:                Day1.hs

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