Bell-CHSH urn experiment

This is a simple R simulation of an urn model to which the Bell-CHSH inequality can be applied. To begin with I am going to fill an urn in a quite random way. Let me do that first, and then I’ll explain what I have done with this code fragment.

set.seed(110951)
urn <- sample(10:100, 16, replace = TRUE)
urn
##  [1] 11 75 48 41 76 35 32 63 27 77 59 89 90 35 15 73
barplot(urn)

sum(urn)
## [1] 846

The urn contains 846 slips of paper.

slips <- sample(1:16, 1000, replace = TRUE, prob = urn)
library(MASS)
truehist(slips, h = 1)

a <- sample(c(1, 2), size = 1000, replace = TRUE)
head(a)
## [1] 2 2 2 1 1 2
b <- sample(c(1, 2), size = 1000, replace = TRUE)
head(b)
## [1] 1 2 1 2 1 2
library(R.utils)
slips.string <- intToBin(slips - 1)
head(slips.string)
## [1] "1111" "0001" "0100" "1001" "1011" "1000"
x <- rep(0, 1000)
y <- rep(0, 1000)
for (i in 1:1000) {x[i] <- as.numeric(substr(slips.string[i], a[i], a[i])); 
                   y[i] <- as.numeric(substr(slips.string[i], b[i]+2, b[i]+2))}
head(x)
## [1] 1 0 1 1 1 0
head(y)
## [1] 1 1 0 1 1 0
x <- 2 * x - 1
y <- 2 * y - 1
corr11 <- mean((x*y)[a == 1 & b == 1])
corr12 <- mean((x*y)[a == 1 & b == 2])
corr21 <- mean((x*y)[a == 2 & b == 1])
corr22 <- mean((x*y)[a == 2 & b == 2])
corrs <- c(corr11, corr12, corr21, corr22)
corrs
## [1]  0.06463878  0.11111111 -0.05791506 -0.22529644
chsh <- corr11 + corr12 + corr21 - corr22
chsh
## [1] 0.3431313

Now we’ll create a new urn which will do a whole lot better

urn<- c(1,1,0,0, 1,0,1,0, 0,1,0,1, 0,0,1,1)
urn
##  [1] 1 1 0 0 1 0 1 0 0 1 0 1 0 0 1 1
barplot(urn)

sum(urn)
## [1] 8

The urn contains 8 slips of paper.

slips <- sample(1:16, 1000, replace = TRUE, prob = urn)
truehist(slips, h = 1)

a <- sample(c(1, 2), size = 1000, replace = TRUE)
head(a)
## [1] 1 2 1 2 1 1
b <- sample(c(1, 2), size = 1000, replace = TRUE)
head(b)
## [1] 1 2 1 2 1 1
slips.string <- intToBin(slips - 1)
head(slips.string)
## [1] "0100" "1011" "1110" "1011" "0000" "0110"
x <- rep(0, 1000)
y <- rep(0, 1000)
for (i in 1:1000) {x[i] <- as.numeric(substr(slips.string[i], a[i], a[i])); 
                   y[i] <- as.numeric(substr(slips.string[i], b[i]+2, b[i]+2))}
head(x)
## [1] 0 0 1 0 0 0
head(y)
## [1] 0 1 1 1 0 1
x <- 2 * x - 1
y <- 2 * y - 1
corr11 <- mean((x*y)[a == 1 & b == 1])
corr12 <- mean((x*y)[a == 1 & b == 2])
corr21 <- mean((x*y)[a == 2 & b == 1])
corr22 <- mean((x*y)[a == 2 & b == 2])
corrs <- c(corr11, corr12, corr21, corr22)
corrs
## [1]  0.5627240  0.5967742  0.5870445 -0.6725664
chsh <- corr11 + corr12 + corr21 - corr22
chsh
## [1] 2.419109

Wow! CHSH inequality violated, but not close to 2 sqrt 2. Let’s try again with the same urn. But I’ll restart the RNG

set.seed(110951)
slips <- sample(1:16, 1000, replace = TRUE, prob = urn)
truehist(slips, h = 1)

a <- sample(c(1, 2), size = 1000, replace = TRUE)
head(a)
## [1] 2 2 1 2 1 2
b <- sample(c(1, 2), size = 1000, replace = TRUE)
head(b)
## [1] 1 1 2 2 1 2
slips.string <- intToBin(slips - 1)
head(slips.string)
## [1] "1001" "0100" "1110" "1110" "0001" "1111"
x <- rep(0, 1000)
y <- rep(0, 1000)
for (i in 1:1000) {x[i] <- as.numeric(substr(slips.string[i], a[i], a[i])); 
                   y[i] <- as.numeric(substr(slips.string[i], b[i]+2, b[i]+2))}
head(x)
## [1] 0 1 1 1 0 1
head(y)
## [1] 0 0 0 0 0 1
x <- 2 * x - 1
y <- 2 * y - 1
corr11 <- mean((x*y)[a == 1 & b == 1])
corr12 <- mean((x*y)[a == 1 & b == 2])
corr21 <- mean((x*y)[a == 2 & b == 1])
corr22 <- mean((x*y)[a == 2 & b == 2])
corrs <- c(corr11, corr12, corr21, corr22)
corrs
## [1]  0.5419847  0.5446429  0.4517375 -0.4352941
chsh <- corr11 + corr12 + corr21 - corr22
chsh
## [1] 1.973659

Bit boring. CHSH inequality not quite violated.