2.1.1 Description

NNCB

CH -> B
HH -> N
CB -> H
NH -> C
HB -> C
HC -> B
HN -> C
NN -> C
BH -> H
NC -> B
NB -> B
BN -> B
BB -> N
BC -> B
CC -> N
CN -> C

Template:     NNCB
After step 1: NCNBCHB
After step 2: NBCCNBBBCBHCB
After step 3: NBBBCNCCNBBNBNBBCHBHHBCHB
After step 4: NBBNBNBBCCNBCNCCNBBNBBNBBBNBBNBBCBHCBHHNHCBBCBHCB

2.1.2 Solution

We split the string in pairs of two and replace matches according to the given rules. Then we drop the first letter in each pair or triplet, as it is already present in the pair or triplet before.

format_rule <- function(rule) {
    sprintf("%s -> %s", names(rule), rule)
}

insert <- function(rule) {
    str_c(str_sub(names(rule), 1L, 1L),
            rule,
            str_sub(names(rule), 2L, 2L))
}

replace_line <- function(n, 
                                 str = puzzle_data$start,
                                 rules = puzzle_data$rules) {
    wrapper <- function(str, i) {
        idx <- seq(1L, str_length(str) - 1L)
        tokens <- str_sub(str, idx, idx + 1L)
        tokens <- insert(rules[tokens])
        tokens[-1L] <- str_sub(tokens[-1L], 2L)
        str_c(tokens, collapse = "")
    }
    all_ltrs <- str_c(rules, collapse = "") %>% 
        str_split("") %>% 
        `[[`(1) %>% 
        unique()
    reduce(seq(1L, n), wrapper, .init = str) %>% 
        str_count(fixed(all_ltrs)) %>% 
        range() %>% 
        diff()
}

replace_line(10)

## [1] 3408

2.2.1 Description

2.2.2 Solution

While the previous brute-force solution works for small n it quickly becomes not manageable, because at each step the string can potentially grow by 100 (=: k) characters. That is, while the upper bound for the string length after 10 iterations is k ^ 10 = 10^{20}, the upper bound for 40 iterations is already r length(puzzle_data$rules) ^ 40`. Of course not all 100 will hit in each of the iterations, hence we manage with 10 iterations but clearly for 40 iterations we have to find a smarter algorithm.

We will resort to a directed graph. Each node represents a tuple like HF. By applying rule HF -> O this tuple produces HOF, which eventually results in the two new tuples HO, OF. In the graph we hence connect HF with HO, OF via a directed edge. In this way we connect all tuples to its 2 resulting tuples to form a graph. We connect a dedicated start node to the tuples found in the start word. We assign an initial load of 1 to the start node. If a tuple appears k times in the start string, there will be k edges from the start node to this very tuple.

Then the algorithm works as follows:

1. For each outgoing edge, add the full load to the child node. That is, if there are two nodes P and P' say, which have an edge into C, then we add the load of P plus the load of P' to the load of C. Note, that the graph may have some loops (a rule like KN -> K will lead to such a loop). This reflects that each tuple when polymerized will create a new tuple. If there are for instance 3 KN -> H nodes and 2 NN -> H nodes we will - inter alia - have 3 + 2 = 5 new HN nodes. The amount is reflectd by the load.
2. We also have to reduce the number of “mother” polymers accordingly. In the above example we will reduce the load of KN and NN by 3 and 2 respectively. Please note, that in one run we can produce and destroy a certain tuple.
3. Once we transferred the loads to the childs, we recurse into all childs and continue until we reached the desired depth.

get_neighbor_node <- function(tuple) {
    nbs <- insert(tuple)
    from <- rep(1:2, length(tuple))
    str_sub(rep(nbs, each = 2), from, from + 1)
}

create_graph_from_rules <- function(start = puzzle_data$start,
                                                rules = puzzle_data$rules) {
    gr_dat <- data.frame(from    = rep(names(rules), each = 2L),
                                to      = get_neighbor_node(rules),
                                insert  = rep(rules, each = 2L),
                                visited = 0L,
                                load    = 0L)
    G <- gr_dat %>% 
        select(1:2) %>% 
        graph_from_data_frame(vertices = gr_dat %>% 
                                        select(-to) %>% unique())
    V(G)$color <- "orange"
    V(G)$shape <- "circle"
    idx <- seq_len(str_length(start) - 1L) 
    new_edges <- rep(str_sub(start, idx, idx + 1L), each = 2L)
    new_edges[2L * (0:(length(new_edges) / 2L - 1L)) + 1L] <- "start"
    G +
        vertices("start", 
                    color = "steelblue", 
                    shape = "square",
                    load = 1L,
                    visited = 1L) +
        edges(new_edges)
}

walk_graph <- function(max_depth,
                              start = puzzle_data$start,
                              rules = puzzle_data$rules) {
    op <- options(scipen = 99)
    on.exit(options(op))
    G <- create_graph_from_rules(start, rules)
    start_cnt <- tibble(ltr = unique(str_split(start, "")[[1L]]),
                              n   = str_count(start, ltr))
    do_walk <- function(nodes, depth) {
        if (depth == max_depth) {
            nodes <- difference(V(G), V(G)["start", visited == 0L])
            tibble(ltr = nodes$insert,
                              n   = nodes$visited) %>%
                group_by(ltr) %>% 
                summarize(n = sum(n)) %>% 
                full_join(start_cnt,
                             by = "ltr") %>% 
                transmute(ltr,
                             n = coalesce(n.x, 0L) + coalesce(n.y, 0L)) %>% 
                pull(n) %>% 
                range() %>% 
                diff()
        } else {
            incs <- incident_edges(G, nodes) %>% 
                unlist()
            nbs <- adjacent_vertices(G, nodes) %>% 
                unlist() %>% 
                unique()
            src_dest <- tibble(src  = tail_of(G, incs),
                                     dest = head_of(G, incs),
                                     load = V(G)[src]$load)
            dest <- src_dest %>% 
                group_by(dest) %>% 
                summarize(load = sum(load))
            V(G)[dest$dest]$load <<- V(G)[dest$dest]$load + dest$load
            src <- src_dest %>% 
                distinct(src, load)
            V(G)[src$src]$load <<- V(G)[src$src]$load - src$load
            V(G)[nbs]$visited <<- V(G)[nbs]$visited + V(G)[nbs]$load
            Recall(V(G)[nbs], depth + 1L)
        }
    }
    do_walk(V(G)["start"], 0L)
}

options(scipen = 1)
walk_graph(40)

[1] 3724343376942