Usando R para resolver o jogo Lucky 26

Estou tentando mostrar ao meu filho como a codificação pode ser usada para resolver um problema apresentado por um jogo, além de ver como o R lida com o big data. O jogo em questão é chamado "Lucky 26". Neste jogo, os números (1 a 12 sem duplicatas) são posicionados em 12 pontos em uma estrela de David (6 vértices, 6 cruzamentos) e as 6 linhas de 4 números devem adicionar 26. Das aproximadamente 479 milhões de possibilidades (12P12 ) aparentemente existem 144 soluções. Tentei codificar isso no R da seguinte maneira, mas a memória é um problema que parece. Eu agradeceria muito qualquer conselho para avançar a resposta se os membros tiverem tempo. Agradecendo antecipadamente aos membros.

library(gtools)

x=c()
elements <- 12
for (i in 1:elements)
{ 
    x[i]<-i
}

soln=c()            

y<-permutations(n=elements,r=elements,v=x)  
j<-nrow(y)
for (i in 1:j) 
{
L1 <- y[i,1] + y[i,3] + y[i,6] + y[i,8]
L2 <- y[i,1] + y[i,4] + y[i,7] + y[i,11]
L3 <- y[i,8] + y[i,9] + y[i,10] + y[i,11]
L4 <- y[i,2] + y[i,3] + y[i,4] + y[i,5]
L5 <- y[i,2] + y[i,6] + y[i,9] + y[i,12]
L6 <- y[i,5] + y[i,7] + y[i,10] + y[i,12]
soln[i] <- (L1 == 26)&(L2 == 26)&(L3 == 26)&(L4 == 26)&(L5 == 26)&(L6 == 26) 
}

z<-which(soln)
z

Aqui está outra abordagem. É baseado em um post do blog do MathWorks de Cleve Moler , autor do primeiro MATLAB.

Na postagem do blog, para economizar memória, o autor permite apenas 10 elementos, mantendo o primeiro elemento como o elemento principal e o sétimo como o elemento base. Portanto, apenas 10! == 3628800permutações precisam ser testadas.
No código abaixo,

1. Gere as permutações de elementos 1para 10. Há um total 10! == 3628800deles.
2. Escolha 11como o elemento principal e mantenha-o fixo. Realmente não importa onde as atribuições começam, os outros elementos estarão nas posições relativas corretas .
3. Em seguida, atribua o 12º elemento à 2ª posição, 3ª posição, etc., em um forloop.

Isso deve produzir a maioria das soluções, dar ou receber rotações e reflexões. Mas isso não garante que as soluções sejam únicas. Também é razoavelmente rápido.

elements <- 12
x <- seq_len(elements)
p <- gtools::permutations(n = elements - 2, r = elements - 2, v = x[1:10])  

i1 <- c(1, 3, 6, 8)
i2 <- c(1, 4, 7, 11)
i3 <- c(8, 9, 10, 11)
i4 <- c(2, 3, 4, 5)
i5 <- c(2, 6, 9, 12)
i6 <- c(5, 7, 10, 12)

result <- vector("list", elements - 1)
for(i in 0:10){
  if(i < 1){
    p2 <- cbind(11, 12, p)
  }else if(i == 10){
    p2 <- cbind(11, p, 12)
  }else{
    p2 <- cbind(11, p[, 1:i], 12, p[, (i + 1):10])
  }
  L1 <- rowSums(p2[, i1]) == 26
  L2 <- rowSums(p2[, i2]) == 26
  L3 <- rowSums(p2[, i3]) == 26
  L4 <- rowSums(p2[, i4]) == 26
  L5 <- rowSums(p2[, i5]) == 26
  L6 <- rowSums(p2[, i6]) == 26

  i_sol <- which(L1 & L2 & L3 & L4 & L5 & L6)
  result[[i + 1]] <- if(length(i_sol) > 0) p2[i_sol, ] else NA
}
result <- do.call(rbind, result)
dim(result)
#[1] 82 12

head(result)
#     [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10] [,11] [,12]
#[1,]   11   12    1    3   10    5    8    9    7     6     4     2
#[2,]   11   12    1    3   10    8    5    6    4     9     7     2
#[3,]   11   12    1    7    6    4    3   10    2     9     5     8
#[4,]   11   12    3    2    9    8    6    4    5    10     7     1
#[5,]   11   12    3    5    6    2    9   10    8     7     1     4
#[6,]   11   12    3    6    5    4    2    8    1    10     7     9

Na verdade, existem 960 soluções. A seguir, fazer uso de Rcpp, RcppAlgos^* , eo parallelpacote para obter a solução em apenas 6 secondsusando 4 núcleos. Mesmo se você optar por usar uma abordagem de encadeamento único com os R's básicos lapply, a solução será retornada em cerca de 25 segundos.

Primeiro, escrevemos um algoritmo simples C++que verifica uma permutação específica. Você notará que usamos uma matriz para armazenar todas as seis linhas. Isso é para desempenho, pois utilizamos a memória cache de maneira mais eficaz do que usar 6 matrizes individuais. Você também deve ter em mente que C++usa a indexação baseada em zero.

#include <Rcpp.h>
using namespace Rcpp;
// [[Rcpp::plugins(cpp11)]]

constexpr int index26[24] = {0, 2, 5, 7,
                             0, 3, 6, 10,
                             7, 8, 9, 10,
                             1, 2, 3, 4,
                             1, 5, 8, 11,
                             4, 6, 9, 11};

// [[Rcpp::export]]
IntegerVector DavidIndex(IntegerMatrix mat) {
    const int nRows = mat.nrow();
    std::vector<int> res;

    for (int i = 0; i < nRows; ++i) {
        int lucky = 0;

        for (int j = 0, s = 0, e = 4;
             j < 6 && j == lucky; ++j, s += 4, e += 4) {

            int sum = 0;

            for (int k = s; k < e; ++k)
                sum += mat(i, index26[k]);

            lucky += (sum == 26);
        }

        if (lucky == 6) res.push_back(i);
    }

    return wrap(res);
}

Agora, usando os argumentos lowere , podemos gerar pedaços de permutações e testá-los individualmente para manter a memória sob controle. Abaixo, escolhi testar cerca de 4,7 milhões de permutações por vez. A saída fornece os índices lexicográficos das permutações de 12! tal que a condição Lucky 26 seja satisfeita.upperpermuteGeneral

library(RcppAlgos)
## N.B. 4790016L evenly divides 12!, so there is no need to check
## the upper bound on the last iteration below

system.time(solution <- do.call(c, parallel::mclapply(seq(1L, factorial(12), 4790016L), function(x) {
    perms <- permuteGeneral(12, 12, lower = x, upper = x + 4790015)
    ind <- DavidIndex(perms)
    ind + x
}, mc.cores = 4)))

  user  system elapsed 
13.005   6.258   6.644

## Foregoing the parallel package and simply using lapply,
## we obtain the solution in about 25 seconds:
##   user  system elapsed 
## 18.495   6.221  24.729

Agora, verificamos o uso permuteSamplee o argumento sampleVecque permite gerar permutações específicas (por exemplo, se você passar 1, ele fornecerá a primeira permutação (por exemplo 1:12)).

system.time(Lucky26 <- permuteSample(12, 12, sampleVec=solution))
 user  system elapsed 
0.001   0.000   0.001

head(Lucky26)
     [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10] [,11] [,12]
[1,]    1    2    4   12    8   10    6   11    5     3     7     9
[2,]    1    2    6   10    8   12    4    7    3     5    11     9
[3,]    1    2    7   11    6    8    5   10    4     3     9    12
[4,]    1    2    7   12    5   10    4    8    3     6     9    11
[5,]    1    2    8    9    7   11    4    6    3     5    12    10
[6,]    1    2    8   10    6   12    4    5    3     7    11     9

tail(Lucky26)
       [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10] [,11] [,12]
[955,]   12   11    5    3    7    1    9    8   10     6     2     4
[956,]   12   11    5    4    6    2    9    7   10     8     1     3
[957,]   12   11    6    1    8    3    9    5   10     7     4     2
[958,]   12   11    6    2    7    5    8    3    9    10     4     1
[959,]   12   11    7    3    5    1    9    6   10     8     2     4
[960,]   12   11    9    1    5    3    7    2    8    10     6     4

Por fim, verificamos nossa solução com a base R rowSums:

all(rowSums(Lucky26[, c(1, 3, 6, 8]) == 26)
[1] TRUE

all(rowSums(Lucky26[, c(1, 4, 7, 11)]) == 26)
[1] TRUE

all(rowSums(Lucky26[, c(8, 9, 10, 11)]) == 26)
[1] TRUE

all(rowSums(Lucky26[, c(2, 3, 4, 5)]) == 26)
[1] TRUE

all(rowSums(Lucky26[, c(2, 6, 9, 12)]) == 26)
[1] TRUE

all(rowSums(Lucky26[, c(5, 7, 10, 12)]) == 26)
[1] TRUE

^* Eu sou o autor deRcppAlgos

Para permutações, o rcppalgos é ótimo. Infelizmente, existem 479 milhões de possibilidades com 12 campos, o que significa que consome muita memória para a maioria das pessoas:

library(RcppAlgos)
elements <- 12
permuteGeneral(elements, elements)
#> Error: cannot allocate vector of size 21.4 Gb

Existem algumas alternativas.

1. Colha uma amostra das permutações. Ou seja, faça apenas 1 milhão em vez de 479 milhões. Para fazer isso, você pode usar permuteSample(12, 12, n = 1e6). Veja a resposta de @ JosephWood para uma abordagem um pouco semelhante, exceto que ele obtém 479 milhões de permutações;)

2. Crie um loop no rcpp para avaliar a permutação na criação. Isso economiza memória porque você acabaria criando a função para retornar apenas os resultados corretos.

3. Aborde o problema com um algoritmo diferente. Vou me concentrar nessa opção.

Novo algoritmo com restrições

Os segmentos devem ter 26

Sabemos que cada segmento de linha na estrela acima precisa somar 26. Podemos adicionar essa restrição à geração de nossas permutações - nos fornecer apenas combinações que somam 26:

# only certain combinations will add to 26
lucky_combo <- comboGeneral(12, 4, comparisonFun = '==', constraintFun = 'sum', limitConstraints = 26L)

Grupos ABCD e EFGH

Na estrela acima, eu pintei três grupos de maneira diferente: ABCD , EFGH e IJLK . Os dois primeiros grupos também não têm pontos em comum e também estão em segmentos de interesse on-line. Portanto, podemos adicionar outra restrição: para combinações que somam 26, precisamos garantir que ABCD e EFGH não tenham sobreposição de números. Os 4 números restantes serão atribuídos ao IJLK .

library(RcppAlgos)
lucky_combo <- comboGeneral(12, 4, comparisonFun = '==', constraintFun = 'sum', limitConstraints = 26L)
two_combo <- comboGeneral(nrow(lucky_combo), 2)

unique_combos <- !apply(cbind(lucky_combo[two_combo[, 1], ], lucky_combo[two_combo[, 2], ]), 1, anyDuplicated)

grp1 <- lucky_combo[two_combo[unique_combos, 1],]
grp2 <- lucky_combo[two_combo[unique_combos, 2],]
grp3 <- t(apply(cbind(grp1, grp2), 1, function(x) setdiff(1:12, x)))

Permissão através dos grupos

Precisamos encontrar todas as permutações de cada grupo. Ou seja, só temos combinações que somam 26. Por exemplo, precisamos pegar 1, 2, 11, 12e criar 1, 2, 12, 11; 1, 12, 2, 11; ....

#create group perms (i.e., we need all permutations of grp1, grp2, and grp3)
n <- 4
grp_perms <- permuteGeneral(n, n)
n_perm <- nrow(grp_perms)

# We create all of the permutations of grp1. Then we have to repeat grp1 permutations
# for all grp2 permutations and then we need to repeat one more time for grp3 permutations.
stars <- cbind(do.call(rbind, lapply(asplit(grp1, 1), function(x) matrix(x[grp_perms], ncol = n)))[rep(seq_len(sum(unique_combos) * n_perm), each = n_perm^2), ],
           do.call(rbind, lapply(asplit(grp2, 1), function(x) matrix(x[grp_perms], ncol = n)[rep(1:n_perm, n_perm), ]))[rep(seq_len(sum(unique_combos) * n_perm^2), each = n_perm), ],
           do.call(rbind, lapply(asplit(grp3, 1), function(x) matrix(x[grp_perms], ncol = n)[rep(1:n_perm, n_perm^2), ])))

colnames(stars) <- LETTERS[1:12]

Cálculos finais

O último passo é fazer as contas. Eu uso lapply()e Reduce()aqui para fazer uma programação mais funcional - caso contrário, muito código seria digitado seis vezes. Veja a solução original para uma explicação mais completa do código matemático.

# creating a list will simplify our math as we can use Reduce()
col_ind <- list(c('A', 'B', 'C', 'D'), #these two will always be 26
                c('E', 'F', 'G', 'H'),  #these two will always be 26
                c('I', 'C', 'J', 'H'), 
                c('D', 'J', 'G', 'K'),
                c('K', 'F', 'L', 'A'),
                c('E', 'L', 'B', 'I'))

# Determine which permutations result in a lucky star
L <- lapply(col_ind, function(cols) rowSums(stars[, cols]) == 26)
soln <- Reduce(`&`, L)

# A couple of ways to analyze the result
rbind(stars[which(soln),], stars[which(soln), c(1,8, 9, 10, 11, 6, 7, 2, 3, 4, 5, 12)])
table(Reduce('+', L)) * 2

      2       3       4       6 
2090304  493824   69120     960 

Troca de ABCD e EFGH

No final do código acima, aproveitei a possibilidade de trocar ABCDe EFGHobter as permutações restantes. Aqui está o código para confirmar que sim, podemos trocar os dois grupos e estar corretos:

# swap grp1 and grp2
stars2 <- stars[, c('E', 'F', 'G', 'H', 'A', 'B', 'C', 'D', 'I', 'J', 'K', 'L')]

# do the calculations again
L2 <- lapply(col_ind, function(cols) rowSums(stars2[, cols]) == 26)
soln2 <- Reduce(`&`, L2)

identical(soln, soln2)
#[1] TRUE

#show that col_ind[1:2] always equal 26:
sapply(L, all)

[1]  TRUE  TRUE FALSE FALSE FALSE FALSE

atuação

No final, avaliamos apenas 1,3 milhão das 479 permutações e apenas embaralhamos apenas 550 MB de RAM. Demora cerca de 0,7s para executar

# A tibble: 1 x 13
  expression   min median `itr/sec` mem_alloc `gc/sec` n_itr  n_gc
  <bch:expr> <bch> <bch:>     <dbl> <bch:byt>    <dbl> <int> <dbl>
1 new_algo   688ms  688ms      1.45     550MB     7.27     1     5

Aqui está a solução para o amiguinho:

numbersToDrawnFrom = 1:12
bling=0

while(T==T){

  bling=bling+1
  x=sample(numbersToDrawnFrom,12,replace = F)

  A<-x[1]+x[2]+x[3]+x[4] == 26
  B<-x[4]+x[5]+x[6]+x[7] == 26
  C<-x[7] + x[8] + x[9] + x[1] == 26
  D<-x[10] + x[2] + x[9] + x[11] == 26
  E<-x[10] + x[3] + x[5] + x[12] == 26
  F1<-x[12] + x[6] + x[8] + x[11] == 26

  vectorTrue <- c(A,B,C,D,E,F1)

  if(min(vectorTrue)==1){break}
  if(bling == 1000000){break}

}

x
vectorTrue