Not sure where I’m going to go with this one. We have an interesting parameter lambda which denotes the fraction of transitions in the rule table that have a non-zero output. In other words, for the elementary rules, how many have an output of 1? This can give us a shortcut to find class 4 patterns. The second point is that we’ve still skirted around how to quantify class 4 behavior aside from looking for entities that move around and interact. In other words, higher-order computational objects. These can make a Turing Machine, which also has not been touched. First, let’s take our 1d cellular automata and set the lambda to near 1/2 and see how much time that saves us.

Wolfram’s rules

Today, we’re going to use base R and the pheatmap package to produce elementary cellular automata and see if we can figure out how to evaluate the complexity of what we see. First, we’ll set up the functioon:

library(tidyverse)
## ── Attaching packages ───────────────────────────────────────────────── tidyverse 1.3.0 ──
## ✓ ggplot2 3.2.1     ✓ purrr   0.3.3
## ✓ tibble  2.1.3     ✓ dplyr   0.8.4
## ✓ tidyr   1.0.2     ✓ stringr 1.4.0
## ✓ readr   1.3.1     ✓ forcats 0.5.0
## ── Conflicts ──────────────────────────────────────────────────── tidyverse_conflicts() ──
## x dplyr::filter() masks stats::filter()
## x dplyr::lag()    masks stats::lag()
set.seed(1)

# Define a rule
state <- lapply(seq(0, 7), function(i) {
    result <- intToBits(i)[1:3] %>% as.numeric() %>% rev() %>% paste(collapse = "")
    return(result)
}) %>% as.character() 

outcome <- lapply(seq(0, 255), function(i) {
    result <- intToBits(i)[1:8] %>% as.numeric()
    return(result)
}) %>% do.call(cbind, .) %>% as_tibble()
## Warning: `as_tibble.matrix()` requires a matrix with column names or a `.name_repair` argument. Using compatibility `.name_repair`.
## This warning is displayed once per session.
names(outcome) <- paste("rule", seq(0, 255), sep = "_")

Now, we’re going to explore rule space a little bit. We see a bell curve around the number of 1’s present in the data. Trimming by lambda between 3/8 and 5/8 won’t cut our computational time down much, so we won’t bother.

# Trim by lambda 3/8 to 5/8
rule_space <- colSums(outcome) %>% table()
rule_space
## .
##  0  1  2  3  4  5  6  7  8 
##  1  8 28 56 70 56 28  8  1

Now, let’s go into Rule 110 and think of it in terms of entropy.

rule_set <- bind_cols(state = state, outcome = outcome)

# The procedure
ApplyRule <- function(v, rule_set, rule_num, probability = 1) {
    # Set the rule
    rule <- tibble(state = state, outcome = rule_set[[rule_num + 2]])
    
    # Iterate through the vector
    result <- lapply(seq_along(v), function(i) {
        # Edge case
        if(i == 1 | i == length(v)) {
            return(0)
        }
        
        # The rule
        curr <- paste(v[i - 1], v[i], v[i + 1], sep = "") 
        out <- rule[rule$state == curr,]$outcome
        
        # Simulate probabilistic rule by having a small chance of flipping the bit
        if(out == 1) {
            out <- sample(c(0, 1), 
                          size = 1,
                          prob = c(1 - probability, probability))
        } else if(out == 0) {
            out <- sample(c(1, 0), 
                          size = 1,
                          prob = c(1 - probability, probability))
        }
        
        return(out)
    }) %>% unlist()
}
# Define a vector 
v <- c(rep(0, 1200), 1)
v <- sample(c(0, 1), 1200, replace = TRUE)

# Define an output matrix
top <- v
mat <- lapply(seq(1200), function(i) {
    curr <- ApplyRule(v = v, rule_set = rule_set, rule = 110)
    v <<- curr
    return(curr)
}) %>% do.call(rbind, .)

mat <- rbind(top, mat)


# Visualize
pheatmap::pheatmap(mat, cluster_rows = FALSE, cluster_cols = FALSE, color = c("red", "black"))

Now, we’re going to play around with the matrix a little bit, to see if we can flesh out the “computational subunits”.

# Convolution based nn summer
# Generates a kernel to be used across the "space" matrix
# Args:
#   side: the length of the side of the kernel
# Returns:
#   result: a matrix of only 0. 
GenerateKernel <- function(side) {
    result <- matrix(rep(0, side^2), nrow = side)
    return(result)
}

# Makes the nn matrix given space and a kernel matrix
# Args:
#   space: the matrix representing the space of the CA
#   kernel: the matrix representing the kernel to be iterated across space
# Returns: 
#   result: the nn matrix generated by the kernal iterating across space
Convolution <- function(space, kernel) {
    
    tmp <- space
    # Make sure the kernel stays within bounds of the matrix 
    # Note tha this only really works for an odd numbered matrix
    if(nrow(kernel) %% 2 == 0) {
        stop("Please choose a kernel with an odd number of sides")
    }
    
    # Find the dimensions for the for loop
    start <- nrow(kernel) %/% 2 + 1
    end <- nrow(space) - start
    to.edge <- start - 1
    
    # The loop
    for(i in start:end) {
        for(j in start:end) {
            piece <- space[(j - to.edge):(j + to.edge), (i - to.edge):(i + to.edge)]
            tmp[j, i] <- sum(piece * kernel)
        }
    }
    
    return(tmp)
}

Now, we get to work.

# Small kernel
kernel <- GenerateKernel(side = 5)
kernel <- kernel + 1

conv_mat <- Convolution(space = mat, kernel = kernel) %>% as_tibble()
pheatmap::pheatmap(conv_mat, cluster_rows = FALSE, cluster_cols = FALSE)

So we have a convolution that effectively reveals the computational regions. Now we clean this up to isolate them.

mat2 <- ifelse(conv_mat > 8 & conv_mat < 12, 1, 0)
pheatmap::pheatmap(mat2, cluster_cols = FALSE, cluster_rows = FALSE)

Ok, so now you can see the weird types of gliders we’re interested in. The problem is that there are many other “gliders” that simply slide out of existence here, meaning they’re zero.

So now we’ve shown that a “randomness” based measure was able to bring out SOME of the computational patterns here, but overall the initial convolution we did on the Rule 110 output brought clarity to what we were seeing. The question remains regarding how to get the computer to recognize these symbols.

On the other hand, we want to determine whether we’re at class 1, 2, 3, or 4. We just have Shannon Entropy.

Or perhaps that’s not the right question. The symbols themselves are so-called computers. So then the question is how to perform computation with these symbols.

Probabilistic modification of Rule 110

Here, we make a probabilistic modification of Rule 110 to test the hypothesis that emergent complexity is more likely with probabilistic cellular automata setup, which mirrors the computational schemes that occur in biological life. This hypothesis is relevant if not critical to understanding my unvolvement in Company A.

# Define a vector 
v <- sample(c(0, 1), 1200, replace = TRUE)

# Define an output matrix
top <- v
mat <- lapply(seq(1200), function(i) {
    curr <- ApplyRule(v = v, rule_set = rule_set, rule = 110, probability = 0.99999)
    v <<- curr
    return(curr)
}) %>% do.call(rbind, .)

mat <- rbind(top, mat)

# Visualize
pheatmap::pheatmap(mat, cluster_rows = FALSE, cluster_cols = FALSE, color = c("red", "black"))

# Small kernel
kernel <- GenerateKernel(side = 5)
kernel <- kernel + 1

conv_mat <- Convolution(space = mat, kernel = kernel) %>% as_tibble()
pheatmap::pheatmap(conv_mat, cluster_rows = FALSE, cluster_cols = FALSE)

We then repeat for the start from a single point to round this off.

# Define a vector 
v <- c(rep(0, 1200), 1)

# Define an output matrix
top <- v
mat <- lapply(seq(1200), function(i) {
    curr <- ApplyRule(v = v, rule_set = rule_set, rule = 110, probability = 0.99999)
    v <<- curr
    return(curr)
}) %>% do.call(rbind, .)

mat <- rbind(top, mat)

# Visualize
pheatmap::pheatmap(mat, cluster_rows = FALSE, cluster_cols = FALSE, color = c("red", "black"))

# Small kernel
kernel <- GenerateKernel(side = 5)
kernel <- kernel + 1

conv_mat <- Convolution(space = mat, kernel = kernel) %>% as_tibble()
pheatmap::pheatmap(conv_mat, cluster_rows = FALSE, cluster_cols = FALSE)

When we introduce prbability, we can see things like production of gliders out of the blue. We see lots of interactions between gliders and in the end they all seem to be moving to the left. Left-moving gliders seem to be stable and robust to right-moving gliders but not the other way around. We also observe that glider collisions sometimes do not affect gliders, and sometimes will change one glider into another glider. This means that there is robustness in the system, and information can travel from point A to point B even in the presence of “insult” or “damage” to the system. For a probabilistic system, I’ll conjecture that this robustness is very important to the maintenance of the system.

Just to be complete, I’ll lower the probability to show a more chaotic version of what we see above.

# Define a vector 
v <- c(rep(0, 1200), 1)

# Define an output matrix
top <- v
mat <- lapply(seq(1200), function(i) {
    curr <- ApplyRule(v = v, rule_set = rule_set, rule = 110, probability = 0.9999)
    v <<- curr
    return(curr)
}) %>% do.call(rbind, .)

mat <- rbind(top, mat)

# Visualize
pheatmap::pheatmap(mat, cluster_rows = FALSE, cluster_cols = FALSE, color = c("red", "black"))

# Small kernel
kernel <- GenerateKernel(side = 5)
kernel <- kernel + 1

conv_mat <- Convolution(space = mat, kernel = kernel) %>% as_tibble()
pheatmap::pheatmap(conv_mat, cluster_rows = FALSE, cluster_cols = FALSE)

There’s a strange right-direction glider that shows up particularly in this one. It’s possible that it’s a lower probability event in normal circumstances, and this probabilistic rule scheme makes glider collisions more common and therefore produces this one with incrased frequency. It’s the only spotted glider I’ve seen that’s right-facing. On the other hand, the left-facing gliders are overwhelmingly spotted.

And a more chaotic one.

# Define a vector 
v <- c(rep(0, 1200), 1)

# Define an output matrix
top <- v
mat <- lapply(seq(1200), function(i) {
    curr <- ApplyRule(v = v, rule_set = rule_set, rule = 110, probability = 0.999)
    v <<- curr
    return(curr)
}) %>% do.call(rbind, .)

mat <- rbind(top, mat)

# Visualize
pheatmap::pheatmap(mat, cluster_rows = FALSE, cluster_cols = FALSE, color = c("red", "black"))

# Small kernel
kernel <- GenerateKernel(side = 5)
kernel <- kernel + 1

conv_mat <- Convolution(space = mat, kernel = kernel) %>% as_tibble()
pheatmap::pheatmap(conv_mat, cluster_rows = FALSE, cluster_cols = FALSE)

Here, we see the formation and destruction of gliders, but the rule is now too chaotic for information to travel meaningfully from point A to point B.