{-# Language QuasiQuotes, ImportQualifiedPost, NumDecimals #-}
{-|
Module      : Main
Description : Day 12 solution
Copyright   : (c) Eric Mertens, 2018
License     : ISC
Maintainer  : emertens@gmail.com

<https://adventofcode.com/2018/day/12>

Probably like most people I approached this program
by looking at the output and noticing that it eventually
stabilized.

This program works for inputs that eventually reach a point
where they repeatedly just shift in one direction or another.

-}
module Main (main) where

import Advent.Format (format)
import Control.Monad (replicateM)
import Data.List (dropWhileEnd, foldl', tails)
import Data.Vector.Unboxed (Vector)
import Data.Vector.Unboxed qualified as Vector

-- | Print the answers to day 12
--
-- >>> :main
-- 2823
-- 2900000001856
main :: IO ()
IO ()
main =
  do ([Char]
rawInitial, [([Char], Char)]
rawRules) <- [format|2018 12 initial state: %s%n%n(%s => %c%n)*|]
     let garden :: Garden
garden = [Bool] -> Garden
mkGarden [Char
'#' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
x | Char
x <- [Char]
rawInitial]
     let rule :: Rule
rule = [([Bool], Bool)] -> Rule
mkRule [((Char -> Bool) -> [Char] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (Char
'#'Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==) [Char]
xs, Char
'#' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
x) | ([Char]
xs,Char
x) <- [([Char], Char)]
rawRules]
     let xs :: [Garden]
xs = (Garden -> Garden) -> Garden -> [Garden]
forall a. (a -> a) -> a -> [a]
iterate (Rule -> Garden -> Garden
update Rule
rule) Garden
garden
     Int -> IO ()
forall a. Show a => a -> IO ()
print ([Garden] -> Int
part1 [Garden]
xs)
     Int -> IO ()
forall a. Show a => a -> IO ()
print ([Garden] -> Int
part2 [Garden]
xs)

------------------------------------------------------------------------

-- | Evaluate the 20th iteration of the garden
part1 :: [Garden] -> Int
part1 :: [Garden] -> Int
part1 [Garden]
xs = Garden -> Int
eval ([Garden]
xs [Garden] -> Int -> Garden
forall a. HasCallStack => [a] -> Int -> a
!! Int
20)

-- | Evaluate the 50 billionth iteration of the garden.
-- This implementation relies on the state eventually repeating
-- modulo a shift to the left or right.
part2 :: [Garden] -> Int
part2 :: [Garden] -> Int
part2 [Garden]
xs = Garden -> Int
eval (Int -> Garden -> Garden
shiftGarden (Int
step Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
50e9 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i)) Garden
row)
  where
    (Int
i, Int
step, Garden
row) = [Garden] -> (Int, Int, Garden)
loopIteration [Garden]
xs

-- | Compute the sum of the pot locations which have a plant
eval :: Garden -> Int
eval :: Garden -> Int
eval (Garden Int
n [Bool]
xs) = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ Int
i | (Int
i, Bool
True) <- [Int] -> [Bool] -> [(Int, Bool)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
n ..] [Bool]
xs ]

-- iteration logic -----------------------------------------------------

-- | Iterate a garden until it advances to a state that is identical
-- to the previous state except that it might be shifted in one direction.
-- Return the generation at which the pattern is stable, how much the garden
-- shifts when it repeats, and the garden at that iteration.
loopIteration :: [Garden] -> (Int, Int, Garden)
loopIteration :: [Garden] -> (Int, Int, Garden)
loopIteration = [(Int, Garden)] -> (Int, Int, Garden)
forall {a}. [(a, Garden)] -> (a, Int, Garden)
go ([(Int, Garden)] -> (Int, Int, Garden))
-> ([Garden] -> [(Int, Garden)]) -> [Garden] -> (Int, Int, Garden)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [Garden] -> [(Int, Garden)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..]
  where
    go :: [(a, Garden)] -> (a, Int, Garden)
go ( (a
i,Garden Int
n [Bool]
xs) : rest :: [(a, Garden)]
rest@((a
_,Garden Int
m [Bool]
ys) : [(a, Garden)]
_))
      | [Bool]
xs [Bool] -> [Bool] -> Bool
forall a. Eq a => a -> a -> Bool
== [Bool]
ys  = (a
i, Int
mInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
n, Int -> [Bool] -> Garden
Garden Int
n [Bool]
xs)
      | Bool
otherwise = [(a, Garden)] -> (a, Int, Garden)
go [(a, Garden)]
rest
    go [(a, Garden)]
_ = [Char] -> (a, Int, Garden)
forall a. HasCallStack => [Char] -> a
error [Char]
"loopIteration: bad stream"

-- | Apply the update rule to a garden producing the next generation
update :: Rule -> Garden -> Garden
update :: Rule -> Garden -> Garden
update Rule
input (Garden Int
n [Bool]
xs) = Int -> Garden -> Garden
shiftGarden (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
3) ([Bool] -> Garden
mkGarden [Bool]
xs')
  where
    -- the -3 shift accounts for the first rule match placing
    -- a plant 3 before xs because we first match the empty plot
    -- before feeding pots in one at a time.
    xs' :: [Bool]
xs' = (Int -> Bool) -> [Int] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (Rule -> Int -> Bool
matchRule Rule
input)
        ([Int] -> [Bool]) -> [Int] -> [Bool]
forall a b. (a -> b) -> a -> b
$ (Int -> Bool -> Int) -> Int -> [Bool] -> [Int]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl Int -> Bool -> Int
pushBit Int
0
        ([Bool] -> [Int]) -> [Bool] -> [Int]
forall a b. (a -> b) -> a -> b
$ [Bool]
xs [Bool] -> [Bool] -> [Bool]
forall a. [a] -> [a] -> [a]
++ Int -> Bool -> [Bool]
forall a. Int -> a -> [a]
replicate Int
4 Bool
False -- flush window with 4 more empties

-- normalized garden representation ------------------------------------

-- | Gardens are pot locations kept in a normalized form
-- that eliminates leading and trailing empty locations
data Garden = Garden !Int [Bool] -- ^ first index and pots
  deriving (ReadPrec [Garden]
ReadPrec Garden
Int -> ReadS Garden
ReadS [Garden]
(Int -> ReadS Garden)
-> ReadS [Garden]
-> ReadPrec Garden
-> ReadPrec [Garden]
-> Read Garden
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Garden
readsPrec :: Int -> ReadS Garden
$creadList :: ReadS [Garden]
readList :: ReadS [Garden]
$creadPrec :: ReadPrec Garden
readPrec :: ReadPrec Garden
$creadListPrec :: ReadPrec [Garden]
readListPrec :: ReadPrec [Garden]
Read, Int -> Garden -> ShowS
[Garden] -> ShowS
Garden -> [Char]
(Int -> Garden -> ShowS)
-> (Garden -> [Char]) -> ([Garden] -> ShowS) -> Show Garden
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Garden -> ShowS
showsPrec :: Int -> Garden -> ShowS
$cshow :: Garden -> [Char]
show :: Garden -> [Char]
$cshowList :: [Garden] -> ShowS
showList :: [Garden] -> ShowS
Show)

-- | Make a new garden value given a list of plants starting
-- with the zero pot.
--
-- >>> mkGarden [False, True, True, False]
-- Garden 1 [True,True]
mkGarden :: [Bool] -> Garden
mkGarden :: [Bool] -> Garden
mkGarden [Bool]
xs = Int -> [Bool] -> Garden
Garden ([Bool] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Bool]
a) ((Bool -> Bool) -> [Bool] -> [Bool]
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd Bool -> Bool
not [Bool]
b)
  where
    ([Bool]
a,[Bool]
b) = (Bool -> Bool) -> [Bool] -> ([Bool], [Bool])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Bool -> Bool
forall a. a -> a
id [Bool]
xs

-- | Move all pot locations in a garden by a given offset.
--
-- >>> shiftGarden 4 (Garden 3 [True, False, True])
-- Garden 7 [True,False,True]
shiftGarden :: Int -> Garden -> Garden
shiftGarden :: Int -> Garden -> Garden
shiftGarden Int
offset (Garden Int
n [Bool]
xs) = Int -> [Bool] -> Garden
Garden (Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n) [Bool]
xs

-- rule matching -------------------------------------------------------

-- | Rules take a window of 5 pots as bits forming an index between 0 and 31.
-- The vector has a True for windows where a plant should be emitted.
newtype Rule = Rule (Vector Bool)

-- | Match the prefix of a garden against a rule returning the
-- new plant to place at that location.
matchRule :: Rule -> Int {- ^ 5-bit window -} -> Bool
matchRule :: Rule -> Int -> Bool
matchRule (Rule Vector Bool
v) Int
i = Vector Bool
v Vector Bool -> Int -> Bool
forall a. Unbox a => Vector a -> Int -> a
Vector.! Int
i

-- | Construct a efficient rule lookup mechanism given a list of
-- rule productions. Each of the rule productions will correspond to
-- an element in the vector that will be True if a plant is produced.
mkRule :: [([Bool], Bool)] -> Rule
mkRule :: [([Bool], Bool)] -> Rule
mkRule [([Bool], Bool)]
entries = Vector Bool -> Rule
Rule (Int -> (Int -> Bool) -> Vector Bool
forall a. Unbox a => Int -> (Int -> a) -> Vector a
Vector.generate Int
32 (Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
plants))
  where
    plants :: [Int]
plants = [ (Int -> Bool -> Int) -> Int -> [Bool] -> Int
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Int -> Bool -> Int
pushBit Int
0 [Bool]
bs | ([Bool]
bs, Bool
True) <- [([Bool], Bool)]
entries ]

-- | Update the 5-bit window with a new low-endian bit, shifting
-- all the other bits up by one.
--
-- >>> :set -XBinaryLiterals
-- >>> pushBit 0b10011 False == 0b00110
-- True
-- >>> pushBit 0b10011 True == 0b00111
-- True
pushBit ::
  Int  {- ^ five-bit window -} ->
  Bool {- ^ new bit         -} ->
  Int  {- ^ five-bit window -}
pushBit :: Int -> Bool -> Int
pushBit Int
acc Bool
x = (Int
acc Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Bool -> Int
forall a. Enum a => a -> Int
fromEnum Bool
x) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`rem` Int
32