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

<https://adventofcode.com/2015/day/19>

We get a bunch of reaction rules and a final string. Our goal is to find
the smallest application of rules to produce that final string from an
initial empty string.

This solution uses dynamic programming to build the answer up out of all
the most efficient ways to build the substrings of the final string out
of individual starting atoms.

-}
module Main (main) where

import Advent (minimumMaybe, counts, format)
import Data.Array (Ix(range), Array, (!), array, bounds, listArray)
import Data.Char (isLower)
import Data.List (groupBy, inits, tails)
import Data.Map (Map)
import Data.Map.Strict qualified as Map
import Data.Maybe (mapMaybe, maybeToList)
import Data.Set qualified as Set

newtype Atom = Atom String
  deriving (Atom -> Atom -> Bool
(Atom -> Atom -> Bool) -> (Atom -> Atom -> Bool) -> Eq Atom
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Atom -> Atom -> Bool
== :: Atom -> Atom -> Bool
$c/= :: Atom -> Atom -> Bool
/= :: Atom -> Atom -> Bool
Eq,Eq Atom
Eq Atom =>
(Atom -> Atom -> Ordering)
-> (Atom -> Atom -> Bool)
-> (Atom -> Atom -> Bool)
-> (Atom -> Atom -> Bool)
-> (Atom -> Atom -> Bool)
-> (Atom -> Atom -> Atom)
-> (Atom -> Atom -> Atom)
-> Ord Atom
Atom -> Atom -> Bool
Atom -> Atom -> Ordering
Atom -> Atom -> Atom
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Atom -> Atom -> Ordering
compare :: Atom -> Atom -> Ordering
$c< :: Atom -> Atom -> Bool
< :: Atom -> Atom -> Bool
$c<= :: Atom -> Atom -> Bool
<= :: Atom -> Atom -> Bool
$c> :: Atom -> Atom -> Bool
> :: Atom -> Atom -> Bool
$c>= :: Atom -> Atom -> Bool
>= :: Atom -> Atom -> Bool
$cmax :: Atom -> Atom -> Atom
max :: Atom -> Atom -> Atom
$cmin :: Atom -> Atom -> Atom
min :: Atom -> Atom -> Atom
Ord)

-- | >>> :main
-- 518
-- Just 200
main :: IO ()
IO ()
main =
  do ([(String, String)]
rules_, String
input_) <- [format|2015 19 (%s => %s%n)*%n%s%n|]
     let rules :: Map Atom [[Atom]]
rules = ([[Atom]] -> [[Atom]] -> [[Atom]])
-> [(Atom, [[Atom]])] -> Map Atom [[Atom]]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [[Atom]] -> [[Atom]] -> [[Atom]]
forall a. [a] -> [a] -> [a]
(++) [(String -> Atom
Atom String
a, [String -> [Atom]
parseMolecule String
b]) | (String
a,String
b) <- [(String, String)]
rules_]
     let input :: [Atom]
input = String -> [Atom]
parseMolecule String
input_
     Int -> IO ()
forall a. Show a => a -> IO ()
print (Map [Atom] Int -> Int
forall a. Map [Atom] a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([[Atom]] -> Map [Atom] Int
forall (f :: * -> *) a. (Foldable f, Ord a) => f a -> Map a Int
counts (Map Atom [[Atom]] -> [Atom] -> [[Atom]]
forall a. Ord a => Map a [[a]] -> [a] -> [[a]]
oneStep Map Atom [[Atom]]
rules [Atom]
input)))
     Maybe Int -> IO ()
forall a. Show a => a -> IO ()
print (Map Atom [[Atom]] -> [Atom] -> Atom -> Maybe Int
forall a. Ord a => Map a [[a]] -> [a] -> a -> Maybe Int
minRulesNeeded Map Atom [[Atom]]
rules [Atom]
input (String -> Atom
Atom String
"e"))

-- | Returns all the ways a sequence can be expanded with a single application
-- of one of the input rules.
oneStep :: Ord a => Map a [[a]] -> [a] -> [[a]]
oneStep :: forall a. Ord a => Map a [[a]] -> [a] -> [[a]]
oneStep Map a [[a]]
rules [a]
input =
  [ [a]
xs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
z [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
ys
    | ([a]
xs,a
y:[a]
ys) <- [[a]] -> [[a]] -> [([a], [a])]
forall a b. [a] -> [b] -> [(a, b)]
zip ([a] -> [[a]]
forall a. [a] -> [[a]]
inits [a]
input) ([a] -> [[a]]
forall a. [a] -> [[a]]
tails [a]
input)
    , [a]
z <- [[a]] -> a -> Map a [[a]] -> [[a]]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] a
y Map a [[a]]
rules
  ]

-- | Add empty elements to the map so that every @a@ that occurs in
-- the values of the map also occurs in the keys.
extendRules :: Ord a => Map a [[a]] -> Map a [[a]]
extendRules :: forall a. Ord a => Map a [[a]] -> Map a [[a]]
extendRules Map a [[a]]
rules
  = Map a [[a]] -> Map a [[a]] -> Map a [[a]]
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map a [[a]]
rules
  (Map a [[a]] -> Map a [[a]]) -> Map a [[a]] -> Map a [[a]]
forall a b. (a -> b) -> a -> b
$ (a -> [[a]]) -> Set a -> Map a [[a]]
forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet ([[a]] -> a -> [[a]]
forall a b. a -> b -> a
const [])
  (Set a -> Map a [[a]]) -> Set a -> Map a [[a]]
forall a b. (a -> b) -> a -> b
$ [a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList ([[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[[a]]] -> [[a]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Map a [[a]] -> [[[a]]]
forall k a. Map k a -> [a]
Map.elems Map a [[a]]
rules)))

-- |
-- > parseMolecule "AbCdEF"
-- [Atom "Ab", Atom "Cd", Atom "E", Atom "F"]
parseMolecule :: String -> [Atom]
parseMolecule :: String -> [Atom]
parseMolecule = (String -> Atom) -> [String] -> [Atom]
forall a b. (a -> b) -> [a] -> [b]
map String -> Atom
Atom ([String] -> [Atom]) -> (String -> [String]) -> String -> [Atom]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char -> Bool) -> String -> [String]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (\Char
_ Char
y -> Char -> Bool
isLower Char
y)

-- | Given a map of rewrite rules rewriting the keys to any of the
-- alternatives, return the minimum number of rewrites needed to rewrite
-- the start symbol into the input.
minRulesNeeded ::
  Ord a =>
  Map a [[a]] {- ^ rules, sum of products -} ->
  [a]         {- ^ input                  -} ->
  a           {- ^ start state            -} ->
  Maybe Int
minRulesNeeded :: forall a. Ord a => Map a [[a]] -> [a] -> a -> Maybe Int
minRulesNeeded Map a [[a]]
rules [a]
input a
start = Array Int [[Int]] -> Array Int Int -> Int -> Maybe Int
forall i. Ix i => Array i [[i]] -> Array Int i -> i -> Maybe Int
minRulesNeededInt Array Int [[Int]]
ruleArr Array Int Int
inputArr (a -> Int
toInt a
start)
  where
  rules' :: Map a [[a]]
rules'  = Map a [[a]] -> Map a [[a]]
forall a. Ord a => Map a [[a]] -> Map a [[a]]
extendRules Map a [[a]]
rules
  toInt :: a -> Int
toInt a
x = a -> Map a [[a]] -> Int
forall k a. Ord k => k -> Map k a -> Int
Map.findIndex a
x Map a [[a]]
rules'

  inputArr :: Array Int Int
inputArr = [Int] -> Array Int Int
forall a. [a] -> Array Int a
toArray ((a -> Int) -> [a] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map a -> Int
toInt [a]
input)
  ruleArr :: Array Int [[Int]]
ruleArr  = [[[Int]]] -> Array Int [[Int]]
forall a. [a] -> Array Int a
toArray (([[a]] -> [[Int]]) -> [[[a]]] -> [[[Int]]]
forall a b. (a -> b) -> [a] -> [b]
map (([a] -> [Int]) -> [[a]] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> Int) -> [a] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map a -> Int
toInt)) (Map a [[a]] -> [[[a]]]
forall k a. Map k a -> [a]
Map.elems Map a [[a]]
rules'))

-- | Given an array of inputs determine how many rule applications
-- are required to transform the start state into the input.
--
-- This solution uses dynamic programming. The solutions are memoized
-- as about how many steps, if any, each substring of the input takes to
-- match each of the symbols in the alphabet.
minRulesNeededInt ::
  Ix i =>
  Array i [[i]] {- ^ rules, sum of products -} ->
  Array Int i   {- ^ input -} ->
  i             {- ^ start -} ->
  Maybe Int     {- ^ minimum rules needed -}
minRulesNeededInt :: forall i. Ix i => Array i [[i]] -> Array Int i -> i -> Maybe Int
minRulesNeededInt Array i [[i]]
rules Array Int i
input = Int -> Int -> i -> Maybe Int
cost Int
inputLo Int
inputHi
  where
  (Int
inputLo,Int
inputHi) = Array Int i -> (Int, Int)
forall i e. Array i e -> (i, i)
bounds Array Int i
input
  (i
rulesLo,i
rulesHi) = Array i [[i]] -> (i, i)
forall i e. Array i e -> (i, i)
bounds Array i [[i]]
rules
  costBounds :: ((Int, Int, i), (Int, Int, i))
costBounds        = ((Int
inputLo,Int
inputLo,i
rulesLo)
                      ,(Int
inputHi,Int
inputHi,i
rulesHi))

  costArray :: Array (Int, Int, i) (Maybe Int)
costArray =
    ((Int, Int, i), (Int, Int, i))
-> ((Int, Int, i) -> Maybe Int) -> Array (Int, Int, i) (Maybe Int)
forall i e. Ix i => (i, i) -> (i -> e) -> Array i e
generate ((Int, Int, i), (Int, Int, i))
costBounds \(Int
start,Int
end,i
ruleIx) ->
      if Int
start Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
end Bool -> Bool -> Bool
&& Array Int i
input Array Int i -> Int -> i
forall i e. Ix i => Array i e -> i -> e
! Int
start i -> i -> Bool
forall a. Eq a => a -> a -> Bool
== i
ruleIx
        then Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0
        else (Int -> Int) -> Maybe Int -> Maybe Int
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int
1Int -> Int -> Int
forall a. Num a => a -> a -> a
+)
           (Maybe Int -> Maybe Int) -> Maybe Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ [Int] -> Maybe Int
forall a. Ord a => [a] -> Maybe a
minimumMaybe
           ([Int] -> Maybe Int) -> [Int] -> Maybe Int
forall a b. (a -> b) -> a -> b
$ ([i] -> Maybe Int) -> [[i]] -> [Int]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Int -> Int -> [i] -> Maybe Int
nonTerm Int
start Int
end)
           ([[i]] -> [Int]) -> [[i]] -> [Int]
forall a b. (a -> b) -> a -> b
$ Array i [[i]]
rules Array i [[i]] -> i -> [[i]]
forall i e. Ix i => Array i e -> i -> e
! i
ruleIx

  cost :: Int -> Int -> i -> Maybe Int
cost Int
start Int
end i
rule = Array (Int, Int, i) (Maybe Int)
costArray Array (Int, Int, i) (Maybe Int) -> (Int, Int, i) -> Maybe Int
forall i e. Ix i => Array i e -> i -> e
! (Int
start,Int
end,i
rule)

  nonTerm :: Int -> Int -> [i] -> Maybe Int
nonTerm Int
start Int
end [i]
rhs =
    case [i]
rhs of
     []   -> Maybe Int
forall a. Maybe a
Nothing
     [i
x]  -> Int -> Int -> i -> Maybe Int
cost Int
start Int
end i
x
     i
x:[i]
xs -> [Int] -> Maybe Int
forall a. Ord a => [a] -> Maybe a
minimumMaybe
               [ Int
cost1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
cost2
               | Int
mid   <- [Int
start .. Int
end Int -> Int -> Int
forall a. Num a => a -> a -> a
- [i] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [i]
xs]
               , Int
cost1 <- Maybe Int -> [Int]
forall a. Maybe a -> [a]
maybeToList (Int -> Int -> i -> Maybe Int
cost Int
start Int
mid i
x)
               , Int
cost2 <- Maybe Int -> [Int]
forall a. Maybe a -> [a]
maybeToList (Int -> Int -> [i] -> Maybe Int
nonTerm (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
mid) Int
end [i]
xs)
               ]

-- * Array helpers

-- | Generate an array given the bounds an a function from indexes to elements.
generate :: Ix i => (i,i) -> (i -> e) -> Array i e
generate :: forall i e. Ix i => (i, i) -> (i -> e) -> Array i e
generate (i, i)
bnd i -> e
f = (i, i) -> [e] -> Array i e
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (i, i)
bnd ((i -> e) -> [i] -> [e]
forall a b. (a -> b) -> [a] -> [b]
map i -> e
f ((i, i) -> [i]
forall a. Ix a => (a, a) -> [a]
range (i, i)
bnd))

-- | Make a zero-indexed array from a list
toArray :: [a] -> Array Int a
toArray :: forall a. [a] -> Array Int a
toArray [a]
xs = (Int, Int) -> [a] -> Array Int a
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0, [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [a]
xs