Utiliser R pour résoudre le jeu Lucky 26

J'essaie de montrer à mon fils comment le codage peut être utilisé pour résoudre un problème posé par un jeu et voir comment R gère les mégadonnées. Le jeu en question s'appelle "Lucky 26". Dans ce jeu, les numéros (1-12 sans doublons) sont positionnés sur 12 points sur une étoile de david (6 vertex, 6 intersections) et les 6 lignes de 4 numéros doivent toutes s'ajouter à 26. Sur environ 479 millions de possibilités (12P12 ), il existe apparemment 144 solutions. J'ai essayé de coder cela en R comme suit, mais la mémoire est un problème, semble-t-il. J'apprécierais grandement tout conseil pour faire avancer la réponse si les membres ont le temps. Remerciant les membres à l'avance.

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

Voici une autre approche. Il est basé sur un article de blog MathWorks de Cleve Moler , l'auteur du premier MATLAB.

Dans l'article de blog, pour économiser de la mémoire, l'auteur ne permute que 10 éléments, en conservant le premier élément comme élément apex et le 7ème comme élément de base. Par conséquent, seules les 10! == 3628800permutations doivent être testées.
Dans le code ci-dessous,

1. Générez les permutations des éléments 1à 10. Il y en a un total 10! == 3628800.
2. Choisissez 11l'élément apex et maintenez-le fixe. Peu importe où commencent les affectations, les autres éléments seront dans les bonnes positions relatives .
3. Attribuez ensuite le 12e élément à la 2e position, à la 3e position, etc., en forboucle.

Cela devrait produire la plupart des solutions, donner ou prendre des rotations et des réflexions. Mais cela ne garantit pas que les solutions sont uniques. Il est également assez rapide.

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

Il existe en fait 960 solutions. Ci-dessous, nous utilisons Rcpp, RcppAlgos^* et le parallelpackage pour obtenir la solution en un peu plus de 6 seconds4 cœurs. Même si vous choisissez d'utiliser une approche à thread unique avec des R de base lapply, la solution est renvoyée en environ 25 secondes.

Tout d'abord, nous écrivons un algorithme simple C++qui vérifie une permutation particulière. Vous remarquerez que nous utilisons un tableau pour stocker les six lignes. Ceci est pour les performances car nous utilisons la mémoire cache plus efficacement que l'utilisation de 6 baies individuelles. Vous devrez également garder à l'esprit que l' C++indexation basée sur zéro est utilisée.

#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);
}

Maintenant, en utilisant les arguments loweret upperdans permuteGeneral, nous pouvons générer des blocs de permutations et les tester individuellement pour contrôler la mémoire. Ci-dessous, j'ai choisi de tester environ 4,7 millions de permutations à la fois. La sortie donne les indices lexicographiques des permutations de 12! de telle sorte que la condition Lucky 26 soit satisfaite.

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

Maintenant, nous vérifions l'utilisation permuteSampleet l'argument sampleVecqui vous permet de générer des permutations spécifiques (par exemple, si vous passez 1, cela vous donnera la première permutation (ie 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

Enfin, nous vérifions notre solution avec la 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

^* Je suis l'auteur deRcppAlgos

Pour les permutations, rcppalgos est génial. Malheureusement, il y a 479 millions de possibilités avec 12 champs, ce qui signifie que cela prend trop de mémoire pour la plupart des gens:

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

Il existe quelques alternatives.

1. Prenez un échantillon des permutations. Ce qui signifie, ne faites que 1 million au lieu de 479 millions. Pour ce faire, vous pouvez utiliser permuteSample(12, 12, n = 1e6). Voir la réponse de @ JosephWood pour une approche quelque peu similaire, sauf qu'il échantillonne jusqu'à 479 millions de permutations;)

2. Construisez une boucle dans rcpp pour évaluer la permutation à la création. Cela économise de la mémoire car vous finiriez par créer la fonction pour ne renvoyer que les résultats corrects.

3. Abordez le problème avec un algorithme différent. Je vais me concentrer sur cette option.

Nouvel algorithme avec contraintes

Les segments doivent être 26

Nous savons que chaque segment de ligne dans l'étoile ci-dessus doit totaliser jusqu'à 26. Nous pouvons ajouter cette contrainte pour générer nos permutations - ne nous donnez que des combinaisons qui totalisent jusqu'à 26:

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

ABCD et EFGHGroupes

Dans l'étoile ci-dessus, j'ai coloré trois groupes différemment: ABCD , EFGH et IJLK . Les deux premiers groupes n'ont pas non plus de points communs et sont également des segments d'intérêt en ligne. Par conséquent, nous pouvons ajouter une autre contrainte: pour les combinaisons totalisant jusqu'à 26, nous devons nous assurer que ABCD et EFGH ne se chevauchent pas. IJLK se verra attribuer les 4 numéros restants.

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)))

Permutez à travers les groupes

Nous devons trouver toutes les permutations de chaque groupe. Autrement dit, nous n'avons que des combinaisons qui totalisent jusqu'à 26. Par exemple, nous devons prendre 1, 2, 11, 12et faire 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]

Calculs finaux

La dernière étape consiste à faire le calcul. J'utilise lapply()et Reduce()ici pour faire une programmation plus fonctionnelle - sinon, beaucoup de code serait tapé six fois. Voir la solution d'origine pour une explication plus approfondie du code mathématique.

# 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 

Échange ABCD et EFGH

À la fin du code ci-dessus, j'ai profité du fait que nous pouvons échanger ABCDet EFGHobtenir les permutations restantes. Voici le code pour confirmer que oui, nous pouvons échanger les deux groupes et être correct:

# 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

Performance

Au final, nous n'avons évalué que 1,3 million des 479 permutations et seulement mélangé sur 550 Mo de RAM. Il faut environ 0,7 secondes pour fonctionner

# 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

Voici la solution pour le petit gars:

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