Day 6 Solution 1

adventofcode.cabal

@@ -33,6 +33,7 @@ library
       Day3
       Day4
       Day5
+      Day6
   other-modules:
       Paths_adventofcode
   build-depends:

app/Main.hs

@@ -7,6 +7,7 @@ import Text.PrettyPrint hiding ((<>))
 
 import qualified Day1
 import qualified Day5
+import qualified Day6
 
 showSol :: [Char] -> Doc -> IO ()
 showSol txt d = putText . toS . render $
@@ -23,3 +24,6 @@ main = do
   input5 <- Day5.parseInput
   sol5 <- Day5.solution2 input5
   showSol "Solution 2" (int sol5)
+  input6 <- Day6.parseInput
+  sol6 <- Day6.solution1 input6
+  showSol "Solution 1" (int sol6)

inputs/day6.txt

@@ -0,0 +1 @@
+5	1	10	0	1	7	13	14	3	12	8	10	7	12	0	6

package.yaml

@@ -18,6 +18,7 @@ library:
   - Day3
   - Day4
   - Day5
+  - Day6
   dependencies:
   - base >=4.7 && <5
   - protolude

src/Day6.hs

@@ -0,0 +1,124 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-|
+description:
+--- Day 6: Memory Reallocation ---
+
+A debugger program here is having an issue: it is trying to repair a memory
+reallocation routine, but it keeps getting stuck in an infinite loop.
+
+In this area, there are sixteen memory banks; each memory bank can hold any
+number of blocks. The goal of the reallocation routine is to balance the blocks
+between the memory banks.
+
+The reallocation routine operates in cycles. In each cycle, it finds the memory
+bank with the most blocks (ties won by the lowest-numbered memory bank) and
+redistributes those blocks among the banks. To do this, it removes all of the
+blocks from the selected bank, then moves to the next (by index) memory bank and
+inserts one of the blocks. It continues doing this until it runs out of blocks;
+if it reaches the last memory bank, it wraps around to the first one.
+
+The debugger would like to know how many redistributions can be done before a
+blocks-in-banks configuration is produced that has been seen before.
+
+For example, imagine a scenario with only four memory banks:
+
+- The banks start with 0, 2, 7, and 0 blocks.
+  The third bank has the most blocks, so it is chosen for redistribution.
+- Starting with the next bank (the fourth bank) and then continuing to the
+  first bank, the second bank, and so on, the 7 blocks are spread out over the
+  memory banks. The fourth, first, and second banks get two blocks each, and
+  the third bank gets one back. The final result looks like this: 2 4 1 2.
+- Next, the second bank is chosen because it contains the most blocks (four).
+  Because there are four memory banks, each gets one block.
+  The result is: 3 1 2 3.
+- Now, there is a tie between the first and fourth memory banks, both of which
+  have three blocks. The first bank wins the tie, and its three blocks are
+  distributed evenly over the other three banks, leaving it with none: 0 2 3 4.
+- The fourth bank is chosen, and its four blocks are distributed such that
+  each of the four banks receives one: 1 3 4 1.
+- The third bank is chosen, and the same thing happens: 2 4 1 2.
+- At this point, we've reached a state we've seen before: 2 4 1 2
+  was already seen.
+  The infinite loop is detected after the fifth block redistribution cycle,
+  and so the answer in this example is 5.
+
+Given the initial block counts in your puzzle input,
+how many redistribution cycles must be completed before a configuration is
+produced that has been seen before?
+|-}
+module Day6 where
+
+import           Protolude
+
+import           Data.Array.IO (IOUArray)
+import qualified Data.Array.IO as Array
+import qualified Data.Set      as Set
+import qualified Data.Text     as Text
+
+type Arr = IOUArray Int Int
+
+parseInput :: IO Arr
+parseInput = do
+  inputTxt <- readFile "inputs/day6.txt"
+  let lst = inputTxt & Text.words
+            & traverse (strToInteger . toS)
+            & fromMaybe []
+      nb = length lst
+  Array.newListArray (0,nb-1) lst
+
+strToInteger :: [Char] -> Maybe Int
+strToInteger = fmap fst . head . reads
+
+nextBank :: Arr -> Int -> IO Int
+nextBank arr bank = do
+  (start,end) <- Array.getBounds arr
+  return $ if bank == end then start else bank + 1
+
+oneSpread :: (Int,Int) -> Arr -> Int -> Int -> IO Arr
+oneSpread (start,end) arr currentBank nbBlocks = do
+  if nbBlocks == 0 then
+    return arr
+  else do
+    v <- Array.readArray arr currentBank
+    Array.writeArray arr currentBank (v+1)
+    next <- nextBank arr currentBank
+    oneSpread
+      (start,end)
+      arr
+      next
+      (nbBlocks - 1)
+
+oneCycle :: Set [Int] -> Arr -> IO (Set [Int],Bool)
+oneCycle memory arr = do
+  bank <- findArgMaxBank arr
+  next <- nextBank arr bank
+  nbBlocks <- Array.readArray arr bank
+  Array.writeArray arr bank 0
+  bounds <- Array.getBounds arr
+  newArr <- oneSpread bounds arr next nbBlocks
+  elems <- Array.getElems newArr
+  let nextMemory = Set.insert elems memory
+  -- print elems
+  return (nextMemory,Set.member elems memory)
+
+findArgMaxBank :: Arr -> IO Int
+findArgMaxBank arr = do
+  lst <- Array.getAssocs arr
+  return $ lst
+    & sortBy (\x y -> compare (snd y) (snd x))
+    & head
+    & fmap fst
+    & fromMaybe 0
+
+testArray :: IO Arr
+testArray = Array.newListArray (0,3) [0,2,7,0]
+
+solution1 input =
+  go input Set.empty 0
+  where
+    go :: Arr -> Set [Int] -> Int -> IO Int
+    go arr memory n = do
+      (newMemory,isRepeated) <- oneCycle memory arr
+      if isRepeated
+        then return (n+1)
+        else go arr newMemory (n+1)