Advent of Code, day 12, in Haskell [spoilers]

Day 12 asks us to implement a cellular automaton. There's a lot of flavor text, but that's basically it.

The rules are part of the puzzle; I don't know if they're actually different for everyone or not. Though they're given in some random order, it's trivial to sort them and then we can use a table lookup instead of an associative array or map. Treat . as 0 and # as 1 and we get the index of the appropriate rule:

-- sorted version of input
rules = [r|..... => .
....# => .
...#. => #
...## => .
..#.. => #
..#.# => #
..##. => .
..### => .
.#... => #
.#..# => #
.#.#. => .
.#.## => #
.##.. => .
.##.# => .
.###. => #
.#### => #
#.... => .
#...# => .
#..#. => #
#..## => #
#.#.. => .
#.#.# => .
#.##. => #
#.### => .
##... => #
##..# => #
##.#. => #
##.## => .
###.. => #
###.# => #
####. => .
##### => .|]

Here's code to parse it and create the lookup table as an array:

plantToInt :: Char -> Int
plantToInt '#' = 1
plantToInt '.' = 0

intToPlant :: Int -> Char
intToPlant 1 = '#'
intToPlant 0 = '.'

ruleOutcome :: String -> Int
ruleOutcome r = plantToInt (r !! 9)

type RuleTable = UArray Int Int

parseRules :: String -> RuleTable
parseRules text =
  listArray (0,31) (map ruleOutcome (lines text))

Looking up the rule from the 5-tuple is just a bit of math, then:

-- Next state of middle cell given neighbors
nextCell:: RuleTable -> (Int,Int,Int,Int,Int) -> Int
nextCell rt (a,b,c,d,e) = rt ! (16*a + 8*b + 4*c + 2*d + e) 

Let's define a data structure for the state of our automaton. The middle attribute is a list of 0's and 1's representing the state of the system. The first element says at what offset this list begins, initially 0. The third attribute is a list of "spaceships" which were added later to solve part 2.

data CAState =
  CAState Int [Int] [Int]

showCA :: CAState -> String
showCA (CAState i ps ss) =
  (show i) ++ ": " ++ (map intToPlant ps) ++ " " ++ (show ss)

offset (CAState i _ _) = i
plants (CAState _ ps _) = ps
ships (CAState _ _ ss) = ss

startState s = CAState 0 (map plantToInt s) []

Here's the function to advance one state in the CA. Using the same trick I talked about yesterday we zip a list with four other copies of itself to get the five-cell neighborhood specified in the rules. The field of play could get bigger by 4 each time, so the offset moves back by 2. And, we need four zeros on either side of the original cells to be able to apply the rules at the edges.

-- Next state of whole CA
nextState rt (CAState i cs ss) =
  let expanded = [0,0,0,0] ++ cs ++ [0,0,0,0]
      neighborhood = zip5 expanded (drop 1 expanded) (drop 2 expanded) (drop 3 expanded) (drop 4 expanded)
      i' = i - 2 in
    trim (CAState i'
          (map (nextCell rt) neighborhood)
          (map (1+) ss))

I didn't tell you what trim does but it's not necessary to solve part 1, which only asks for 20 iterations.

iterate is a neat Haskell function that creates an infinite list of repeated application of a function to an initial value. Given f and x, it returns [x, f x, f (f x), f (f (f x)), ...] Haskell's lazy evaluation means only as many elements of that list as we actually need are generated:

allStates rt ca = iterate (nextState rt) ca  
nthState rt ca n = (allStates rt ca) !! n

Here's how to calculate the value (again, we can ignore the ships attribute for now and leave it empty):

value ca =
  let is = iterate (1+) (offset ca)
      cells = (zip is (plants ca))
      vals = map (uncurry (*)) cells in
    sum ( vals ++ map ssVal (ships ca))

That gives us part 1's answer:

part1 = 
  let gen20 = nthState (parseRules rules) (startState inputState) 20 in
     value gen20

Part 2 asks us to calculate 50,000,000,000 iterations. The code above is pretty efficient, but not good enough for that (which was probably the point.)

Before jumping in to sophisticated CA mechanisms, let's look at the untrimmed output:

0: #.#..#..###.###.#..###.#####...########.#...#####...##.#....#.####.#.#..#..#.#..###...#..#.#....##. [] value 2356
-2: .##..#####.##..###.##.##..#..##...#.....##.#...#..##....#.#..###.#.##...######..##.###.#####..#.....#.. [] value 2479
-4: .....##.#..#.#.##.##.#..#.#####..#.###......#.#.####..#..##..##.###.##.#...#...###....##..#..#####...###... [] value 2571
-6: .........#.###..##..#.#.####.#..#####.###....##..#.#.######..##....##.#.#.#.###...###.....#####.#..##...###.... [] value 2756
-8: ..........###.####..###..#.#.##.##.#..#..###.....###..#.#...###..#.....#.....#.###...###.....#..##.##..#...###..... [] value 2223
-10: .............##..#.###.#####..##..#.#.#####.###.....#####..#...######...###...###.###...###...####...#.####...###...... [] value 3033
-12: .................####.##..#..###..###..#.#..#..###.....#..#####...#...##...###...##..###...###...#.##.###.#.##...###....... [] value 2753
-14: ....................#.#.#.#####.####.#####..#####.###...####.#..##.###....#...###....##.###...###.####...###.##.#...###........ [] value 3134
-16: .....................##....#.#..#..#.#..#..###.#..#..###...#.##.##....###..###...###.......###...##..#.##...##.#.#.#...###......... [] value 2591
-18: .........................#..##..######..#####.###.#####.###.####..#.#....####.###...###.......###....#####.#....#.....#...###.......... [] value 2757
-20: ..........................####..##.#...###.#..#..##..#..#..##..#.####..#....#.#..###...###.......###....#..##.#..###...###...###........... [] value 2653
-22: .............................#.###..#.#...###.#####..########..####.#.#####..##..##.###...###.......###..####..#.##.###...###...###............ [] value 3384
-24: ..............................###.#####..#...##..#..###.#.....###.#.##.#.#..###..##....###...###.......####.#.######...###...###...###............. [] value 3160
-26: .................................##..#..#####....#####.###.#.....###.##.#...##.####..#....###...###.......#.##.#.#...##...###...###...###.............. [] value 2920
-28: .....................................#####.#..##....#..#..###.#.....##.#.#.#......#.#####....###...###.....####.#...#....#...###...###...###............... [] value 2782
-30: ........................................#..##.##..#..#######.###.#......#.....#....###.#..##....###...###.....#.##.#.###..###...###...###...###................ [] value 3071
-32: .........................................####...#.#####.#....#..###.#....###...###....###.##..#....###...###...####.#.#.####.###...###...###...###................. [] value 3472
-34: ............................................#.##.###.#..##.#..####.###.#....###...###....##.#.####....###...###...#.##...#.#.#..###...###...###...###.................. [] value 3312
-36: .............................................####...###.##..#.##.#.#..###.#....###...###.....#.#.#.##....###...###.####.#.##....##.###...###...###...###................... [] value 3462
-38: ................................................#.##...##.#.#####.#...##.###.#....###...###...##....##.#....###...##..#.##.##.#.......###...###...###...###.................... [] value 3183
-40: .................................................####.#....#.#.#..##.#......###.#....###...###....#.....#.#....###....#####..#.#.#.......###...###...###...###..................... [] value 2995

If you scroll all the way over to the right, you'll notice that some ### patterns repeat and seem to be moving rightwards. In CA terms, those are "spaceships". So we can efficiently model them just by remembering that they are there (assuming that the more chaotic pattern can't swallow them back up.) They move at one cell per turn, which looks like as fast as a pattern can propagate given my input rules. (Two cells per turn is possible using a 5-cell neighborhood.)

The code above already advances each spaceship position by one, now we need to write the code to find them on the right side of the pattern. We can pattern-match for ...### if we reverse the CA state, so that's what I did:

trim = trimLeft
-- trim x = x

trimLeft :: CAState -> CAState
trimLeft (CAState i (0:cs) ss) = trimLeft (CAState (i+1) cs ss)
trimLeft (CAState i cs ss) = trimRight i (length cs) (reverse cs) ss

---   0123456789ABC        
---   xxxxx.....###
--- i ^           ^ i + l - 1 = end position
---             ^ i + l - 3 = spaceship start position
trimRight :: Int -> Int -> [Int] -> [Int] -> CAState
trimRight i lc (0:cs) ss = trimRight i (lc-1) cs ss
trimRight i lc (1:1:1:0:0:0:cs) ss =
  let ssPos = i + lc - 3
      lc' = lc - 6 in
      trimRight i lc' cs (ssPos:ss)
trimRight i lc cs ss = CAState i (reverse cs) ss

There are rather a lot of iterations over the whole pattern here, but I'm hoping that the chaotic part of the pattern stays small.

The value of a snapshot starting at position N is N + (N+1) + (N+2) = 3N+3:

ssVal ss = 3*ss + 3

If we let that code run a while, it turns out that the left part of the pattern settles down and becomes a spaceship too, although one shaped like ###.# instead of only ###.

71: #.####....#.### [90,99,106,113,120,127,137,144,153,159,170,179,193,202,209,215,221,231,237,243,249] value 11556
70: ###.#.##..###.### [91,100,107,114,121,128,138,145,154,160,171,180,194,203,210,216,222,232,238,244,250] value 11855
71: ###.##.##.##..### [92,101,108,115,122,129,139,146,155,161,172,181,195,204,211,217,223,233,239,245,251] value 11925
72: ##.#..#..#.##.### [93,102,109,116,123,130,140,147,156,162,173,182,196,205,212,218,224,234,240,246,252] value 11850
74: #.######## [87,94,103,110,117,124,131,141,148,157,163,174,183,197,206,213,219,225,235,241,247,253] value 12080
73: ###.#.....## [88,95,104,111,118,125,132,142,149,158,164,175,184,198,207,214,220,226,236,242,248,254] value 11902
74: ###.#......# [89,96,105,112,119,126,133,143,150,159,165,176,185,199,208,215,221,227,237,243,249,255] value 11890
75: ###.# [84,90,97,106,113,120,127,134,144,151,160,166,177,186,200,209,216,222,228,238,244,250,256] value 12130
76: ###.# [85,91,98,107,114,121,128,135,145,152,161,167,178,187,201,210,217,223,229,239,245,251,257] value 12203
77: ###.# [86,92,99,108,115,122,129,136,146,153,162,168,179,188,202,211,218,224,230,240,246,252,258] value 12276

So, that's good news, we don't have to look for an arbitrary repeating pattern, we just need to find when one iteration is the same as the next (but shifted over by one.) We can iterate over the infinite list of CA states:

-- Fortunately, we don't need to handle cycles of length greater than 1
findRepeat n ((CAState i ss cs):(CAState i' ss' cs'):rest) | ss == ss' =
  (n, (CAState i ss cs))
findRepeat n (ca:rest) = findRepeat (n+1) rest

Solving part 2 is now simply a matter of putting those pieces together and calculating how many live cells there are once the pattern is in its repeating state:

part2 =
  let r = findRepeat 0 (allStates (parseRules rules) (startState inputState))
      ca = snd r
      increasePerRound = (length (ships ca)) * 3 + (sum (plants ca))
      start = fst r
      end = 50000000000
      additionalRounds = end - start
      endValue = (value ca) + ( additionalRounds * increasePerRound )
  in
    putStrLn (show (fst r) ) >>
    putStrLn (showCA (snd r) ) >>
    putStrLn ((show increasePerRound) ++ " value increase per round") >>
    putStrLn ((show endValue) ++ " after " ++ (show additionalRounds) ++ " rounds")

Full solution: https://github.com/mgritter/aoc2018/blob/master/day12/day12.hs