Do the modulos good

.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

day11/Day11Part1.hs

@@ -0,0 +1,11 @@
+module Day11Part1 (main) where
+
+import Day11Lib
+
+convertToString :: Integer -> String
+convertToString i = show i
+
+main :: IO ()
+main = do
+  contents <- getContents
+  putStrLn $ convertToString $ day11 contents

day11/Day11Part2.hs

@@ -0,0 +1,11 @@
+module Day11Part2 (main) where
+
+import Day11Lib
+
+convertToString :: Integer -> String
+convertToString i = show i
+
+main :: IO ()
+main = do
+  contents <- getContents
+  putStrLn $ convertToString $ day11' contents

day11/input

@@ -0,0 +1,55 @@
+Monkey 0:
+  Starting items: 98, 97, 98, 55, 56, 72
+  Operation: new = old * 13
+  Test: divisible by 11
+    If true: throw to monkey 4
+    If false: throw to monkey 7
+
+Monkey 1:
+  Starting items: 73, 99, 55, 54, 88, 50, 55
+  Operation: new = old + 4
+  Test: divisible by 17
+    If true: throw to monkey 2
+    If false: throw to monkey 6
+
+Monkey 2:
+  Starting items: 67, 98
+  Operation: new = old * 11
+  Test: divisible by 5
+    If true: throw to monkey 6
+    If false: throw to monkey 5
+
+Monkey 3:
+  Starting items: 82, 91, 92, 53, 99
+  Operation: new = old + 8
+  Test: divisible by 13
+    If true: throw to monkey 1
+    If false: throw to monkey 2
+
+Monkey 4:
+  Starting items: 52, 62, 94, 96, 52, 87, 53, 60
+  Operation: new = old * old
+  Test: divisible by 19
+    If true: throw to monkey 3
+    If false: throw to monkey 1
+
+Monkey 5:
+  Starting items: 94, 80, 84, 79
+  Operation: new = old + 5
+  Test: divisible by 2
+    If true: throw to monkey 7
+    If false: throw to monkey 0
+
+Monkey 6:
+  Starting items: 89
+  Operation: new = old + 1
+  Test: divisible by 3
+    If true: throw to monkey 0
+    If false: throw to monkey 5
+
+Monkey 7:
+  Starting items: 70, 59, 63
+  Operation: new = old + 3
+  Test: divisible by 7
+    If true: throw to monkey 4
+    If false: throw to monkey 3

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,78 @@ 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
+
+  Day11Part1:
+    main:                Day11Part1.hs
+    other-modules:       []
+    source-dirs:         day11
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    - -main-is Day11Part1
+    dependencies:
+    - aoc2022
+
+  Day11Part2:
+    main:                Day11Part2.hs
+    other-modules:       []
+    source-dirs:         day11
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    - -main-is Day11Part2
+    dependencies:
+    - aoc2022
+
 tests:
   Day1-test:
     main:                Day1.hs

src/Day10Lib.hs

@@ -0,0 +1,96 @@
+module Day10Lib
+    ( day10
+    , day10'
+    ) 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/Day11Lib.hs

@@ -0,0 +1,213 @@
+module Day11Lib where
+
+import Data.Char (isDigit)
+import Data.List (sort)
+import Data.List.Split (splitOn)
+import Data.Map (Map)
+import qualified Data.Map as M
+
+type Worry = Int
+type Item = Int
+type Target = Int
+type Inspections = Int
+type WorryBound = Int
+
+data Monkey = Monkey
+    { monkeyId :: Target
+    , worryFunction :: (Worry -> Worry)
+    , divisor :: Int
+    , trueTarget :: Int
+    , falseTarget :: Int
+    }
+instance Show Monkey where
+    show Monkey{monkeyId = mId, divisor=d, trueTarget = tT, falseTarget = fT} =
+        "<monkey: " ++ show mId ++ " d: " ++ show d ++ " tT: " ++ show tT ++ " fT: " ++ show fT ++ ">"
+
+-- PARSING
+
+convertToInt :: String -> Int
+convertToInt s = read s :: Int
+
+parseOperator ::  Char -> (Int -> Int -> Int)
+parseOperator '+' = (+)
+parseOperator '-' = (-)
+parseOperator '*' = (*)
+parseOperator '/' = div
+parseOperator otherwise = error "Oops invalid operator, this shouldn't happen"
+
+parseWorryFunction :: String -> (Worry -> Worry)
+parseWorryFunction s
+    | arg1 == "old" && arg2 == "old" = \x -> x `operator` x
+    | arg1 /= "old" && arg2 == "old" = \x -> (convertToInt arg1) `operator` x
+    | arg1 == "old" && arg2 /= "old" = \x -> x `operator` (convertToInt arg2)
+    | arg1 /= "old" && arg2 == "old" = \x -> (convertToInt arg1) `operator` (convertToInt arg2)
+    | otherwise = error "Oops invalid worry function, this shouldn't happen"
+    where
+        equation = last $ splitOn "=" s
+        equationWords = words equation
+        arg1 = head equationWords
+        arg2 = last equationWords
+        operator = parseOperator $ head (equationWords !! 1)
+
+-- Helper function to parse value from a line
+getValue:: String -> String
+getValue x = last $ splitOn ": " x
+
+parseTestFunction :: String -> (Int, Target, Target)
+parseTestFunction s = (divisibleBy, trueValue, falseValue)
+    where
+        sLines = lines s
+        divisibleBy = convertToInt $ last $ words $ getValue $ head sLines
+        trueValue = parseTestResult $ getValue (sLines !! 1)
+        falseValue = parseTestResult $ getValue (sLines !! 2)
+        parseTestResult = \s -> convertToInt $ last $ words s 
+
+parseMonkey :: String -> (Monkey, [Item], Inspections)
+parseMonkey i = (parsedMonkey, parsedItems, 0)
+    where
+        iSplitOnLines = lines i
+        parsedItems = map convertToInt $ splitOn "," $ getValue (iSplitOnLines !! 1)
+        parsedId = convertToInt $ filter isDigit $ last $ words $ head iSplitOnLines
+        parsedWorryFunction = parseWorryFunction $ getValue (iSplitOnLines !! 2)
+        (pDivisor, pTrueTarget, pFalseTarget) = parseTestFunction $ unlines [iSplitOnLines !! 3, iSplitOnLines !! 4, iSplitOnLines !! 5]
+        parsedMonkey = Monkey { monkeyId = parsedId, worryFunction = parsedWorryFunction, divisor = pDivisor, trueTarget = pTrueTarget, falseTarget = pFalseTarget}
+
+parseInput :: String -> [(Monkey, [Item], Inspections)]
+parseInput i = map parseMonkey $ splitOn "\n\n" i
+
+-- PROCESSING
+
+processThrow :: [(Monkey, [Item], Inspections)] -> (Target, Item) -> [(Monkey, [Item], Inspections)] 
+processThrow [] (target, item) = error "It should never get here"
+processThrow (ms@(m@(Monkey{monkeyId = monkeId}), items, inspections):[]) (target, item) =
+    if monkeId == target
+    then [(m, items ++ [item], inspections)]
+    else [ms]
+processThrow (ms@(m@(Monkey{monkeyId = monkeId}), items, inspections):monkeys) (target, item) =
+    if monkeId == target
+    then (m, items ++ [item], inspections) : monkeys
+    else ms : processThrow monkeys (target, item)
+
+processThrowList :: [(Monkey, [Item], Inspections)] -> [(Target, Item)] -> [(Monkey, [Item], Inspections)]
+processThrowList monkeyList [] = monkeyList
+processThrowList monkeyList (throw:throws) = processThrowList (processThrow monkeyList throw) throws
+
+processMonkeyForRound :: (Monkey, [Item], Inspections) -> (Monkey, [(Target, Item)], Inspections)
+processMonkeyForRound (monke@(Monkey monkeId worryF d tT fT), items, inspections) = 
+    (monke, thrownItems, newInspectionCount)
+    where
+        newInspectionCount = inspections + length items
+        newItems = map (inspect monke) items
+        itemTargets = map testFunction newItems
+        thrownItems = zip itemTargets newItems
+        testFunction = \x -> if x `mod` d == 0
+                             then tT 
+                             else fT
+
+processMonkeyForRound' :: WorryBound -> (Monkey, [Item], Inspections) -> (Monkey, [(Target, Item)], Inspections)
+processMonkeyForRound' worrybound (monke@(Monkey monkeId worryF d tT fT), items, inspections) = 
+    (monke, thrownItems, newInspectionCount)
+    where
+        newInspectionCount = inspections + length items
+        newItems = map (inspectAlter worrybound monke) items
+        itemTargets = map testFunction newItems
+        thrownItems = zip itemTargets newItems
+        testFunction = \x -> if x `mod` d == 0
+                             then tT 
+                             else fT
+
+-- part 1
+processRound :: [(Monkey, [Item], Inspections)] -> [(Monkey, [Item], Inspections)]
+processRound ms = processRound' ms []
+
+processRound' :: [(Monkey, [Item], Inspections)] -> [(Monkey, [Item], Inspections)] -> [(Monkey, [Item], Inspections)]
+processRound' [] newMs = newMs
+processRound' ms@((m, items, inspections):monkeys) newMs =
+    (processRound' nextTurnToProcess realNewMonkeyList)
+    where
+        (newM, throwList, newInspections) = processMonkeyForRound (m, items, inspections)
+        newMonkey = (newM, [], newInspections)
+        newMonkeyList = newMs ++ [newMonkey]
+        throwProcessedList = processThrowList (newMonkeyList ++ monkeys) throwList
+        nextTurnToProcess = drop (length newMonkeyList) throwProcessedList
+        realNewMonkeyList = take (length newMonkeyList) throwProcessedList
+
+processRoundAlter :: [(Monkey, [Item], Inspections)] -> [(Monkey, [Item], Inspections)]
+processRoundAlter ms = processRoundAlter' wb ms []
+    where
+        monkeyInspector = \(a,b,c) -> a
+        monkeys = map monkeyInspector ms
+        wb = getWorryBound monkeys
+    
+
+processRoundAlter' :: WorryBound -> [(Monkey, [Item], Inspections)] -> [(Monkey, [Item], Inspections)] -> [(Monkey, [Item], Inspections)]
+processRoundAlter' _ [] newMs = newMs
+processRoundAlter' wb ms@((m, items, inspections):monkeys) newMs =
+    (processRoundAlter' wb nextTurnToProcess realNewMonkeyList)
+    where
+        (newM, throwList, newInspections) = processMonkeyForRound' wb (m, items, inspections)
+        newMonkey = (newM, [], newInspections)
+        newMonkeyList = newMs ++ [newMonkey]
+        throwProcessedList = processThrowList (newMonkeyList ++ monkeys) throwList
+        nextTurnToProcess = drop (length newMonkeyList) throwProcessedList
+        realNewMonkeyList = take (length newMonkeyList) throwProcessedList
+
+-- part 1
+rounds :: [(Monkey, [Item], Inspections)] -> [[(Monkey, [Item], Inspections)]]
+rounds inputState = rounds' inputState []
+
+rounds' :: [(Monkey, [Item], Inspections)] -> [[(Monkey, [Item], Inspections)]] -> [[(Monkey, [Item], Inspections)]]
+rounds' inputState previousState = thisRound : (rounds' thisRound newPreviousState)
+    where
+        thisRound = processRound inputState
+        newPreviousState = thisRound : previousState
+
+-- part 2
+roundsAlter :: [(Monkey, [Item], Inspections)] -> [[(Monkey, [Item], Inspections)]]
+roundsAlter inputState = roundsAlter' inputState []
+
+roundsAlter' :: [(Monkey, [Item], Inspections)] -> [[(Monkey, [Item], Inspections)]] -> [[(Monkey, [Item], Inspections)]]
+roundsAlter' inputState previousState = thisRound : (roundsAlter' thisRound newPreviousState)
+    where
+        thisRound = processRoundAlter inputState
+        newPreviousState = thisRound : previousState
+
+
+relief :: Worry -> Worry
+relief w = w `div` 3
+
+inspect :: Monkey -> Item -> Item
+inspect Monkey{worryFunction = worryF} item = relief $ worryF item
+
+inspectAlter :: WorryBound -> Monkey -> Item -> Item
+inspectAlter wb Monkey{worryFunction = worryF} item =
+    worryMitigationApplied
+        where
+            worriedItem = worryF item 
+            worryMitigationApplied = worriedItem `mod` wb
+
+getWorryBound :: [Monkey] -> Int
+getWorryBound monkeys = product $ map divisor monkeys
+
+monkeyBusiness :: [(Monkey, [Item], Inspections)] -> Integer
+monkeyBusiness monkeys = foldl (*) 1 topTwoInspections
+    where
+        inspectionPeeler = \(x,y,z) -> z
+        inspections = map inspectionPeeler monkeys
+        topTwoInspections = map fromIntegral $ take 2 $ reverse $ sort inspections
+
+day11 :: String -> Integer
+day11 input = monkeyBusinessResult
+    where
+        monkeys = parseInput input
+        allRounds = rounds monkeys
+        twentiethRound = allRounds !! 19
+        monkeyBusinessResult = monkeyBusiness twentiethRound
+
+day11' :: String -> Integer
+day11' input = monkeyBusinessResult
+    where
+        monkeys = parseInput input
+        allRounds = roundsAlter monkeys
+        tenThousandthRound = allRounds !! 9999
+        monkeyBusinessResult = monkeyBusiness tenThousandthRound

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