Usare R per risolvere il gioco Lucky 26

Sto cercando di mostrare a mio figlio come la codifica può essere utilizzata per risolvere un problema posto da un gioco e di vedere come R gestisce i big data. Il gioco in questione si chiama "Lucky 26". In questo gioco i numeri (1-12 senza duplicati) sono posizionati su 12 punti su una stella di david (6 vertici, 6 intersezioni) e le 6 linee di 4 numeri devono aggiungere tutte a 26. Delle circa 479 milioni di possibilità (12P12 ) apparentemente ci sono 144 soluzioni. Ho provato a scrivere questo codice in R come segue, ma sembra che la memoria sia un problema. Gradirei molto qualsiasi consiglio per avanzare la risposta se i membri hanno tempo. Ringraziare i membri in anticipo.

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

Ecco un altro approccio. È basato su un post sul blog di MathWorks di Cleve Moler , l'autore del primo MATLAB.

Nel post del blog, per risparmiare memoria l'autore consente solo 10 elementi, mantenendo il primo elemento come elemento apice e il settimo come elemento base. Pertanto, è 10! == 3628800necessario testare solo le permutazioni.
Nel codice seguente,

1. Genera le permutazioni degli elementi 1a 10. Ce ne sono in totale 10! == 3628800.
2. Scegli 11come elemento apice e mantienilo fisso. In realtà non importa dove iniziano i compiti, gli altri elementi saranno nelle giuste posizioni relative .
3. Quindi assegnare il 12 ° elemento alla 2a posizione, 3a posizione, ecc., In un forciclo.

Questo dovrebbe produrre la maggior parte delle soluzioni, dare o prendere rotazioni e riflessioni. Ma non garantisce che le soluzioni siano uniche. È anche ragionevolmente veloce.

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

In realtà ci sono 960 soluzioni. Di seguito utilizziamo Rcpp, RcppAlgos^* , e il parallelpacchetto per ottenere la soluzione in poco più di 6 seconds4 core. Anche se si sceglie di utilizzare un approccio a thread singolo con R di base lapply, la soluzione viene restituita in circa 25 secondi.

Innanzitutto, scriviamo un semplice algoritmo C++che controlla una particolare permutazione. Noterai che usiamo un array per memorizzare tutte e sei le linee. Questo è per le prestazioni poiché utilizziamo la memoria cache in modo più efficace rispetto all'utilizzo di 6 array individuali. Dovrai anche tenere presente che C++utilizza l'indicizzazione in base 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);
}

Ora, usando il lowerupper argomenti e permuteGeneral, possiamo generare blocchi di permutazioni e testarli singolarmente per tenere sotto controllo la memoria. Di seguito, ho scelto di testare circa 4,7 milioni di permutazioni alla volta. L'output fornisce gli indici lessicografici delle permutazioni di 12! tale che la condizione Lucky 26 è soddisfatta.

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

Ora verifichiamo l'utilizzo permuteSample e l'argomento sampleVecche ti consente di generare permutazioni specifiche (ad esempio, se passi 1, ti darà la prima permutazione (cioè 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

Infine, verifichiamo la nostra soluzione con 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

^* Sono l'autore diRcppAlgos

Per le permutazioni, rcppalgos è fantastico. Sfortunatamente, ci sono 479 milioni di possibilità con 12 campi, il che significa che occupa troppa memoria per la maggior parte delle persone:

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

Ci sono alcune alternative.

1. Prendi un campione delle permutazioni. Ciò significa che solo 1 milione invece di 479 milioni. Per fare questo, puoi usare permuteSample(12, 12, n = 1e6). Vedi la risposta di @ JosephWood per un approccio un po 'simile, tranne per il fatto che campiona 479 milioni di permutazioni;)

2. Crea un ciclo in rcpp per valutare la permutazione alla creazione. Ciò consente di risparmiare memoria perché si finirà per costruire la funzione per restituire solo i risultati corretti.

3. Affronta il problema con un algoritmo diverso. Mi concentrerò su questa opzione.

Nuovo algoritmo con vincoli

I segmenti dovrebbero essere 26

Sappiamo che ogni segmento di linea nella stella sopra deve aggiungere fino a 26. Possiamo aggiungere quel vincolo alla generazione delle nostre permutazioni - dandoci solo combinazioni che aggiungono fino a 26:

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

Gruppi ABCD ed EFGH

Nella stella sopra, ho colorato tre gruppi in modo diverso: ABCD , EFGH e IJLK . I primi due gruppi inoltre non hanno punti in comune e sono anche segmenti di interesse online. Pertanto, possiamo aggiungere un altro vincolo: per le combinazioni che aggiungono fino a 26, dobbiamo garantire che ABCD ed EFGH non abbiano sovrapposizioni di numeri. Ad IJLK verranno assegnati i 4 numeri rimanenti.

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

Permuta attraverso i gruppi

Dobbiamo trovare tutte le permutazioni di ciascun gruppo. Cioè, abbiamo solo combinazioni che aggiungono fino a 26. Ad esempio, dobbiamo prendere 1, 2, 11, 12e creare 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]

Calcoli finali

L'ultimo passo è fare la matematica. Io uso lapply()e Reduce()qui per fare una programmazione più funzionale, altrimenti un sacco di codice verrebbe digitato sei volte. Vedi la soluzione originale per una spiegazione più approfondita del codice matematico.

# 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 

Scambio di ABCD ed EFGH

Alla fine del codice sopra, ho approfittato del fatto che possiamo scambiare ABCDe EFGHottenere le permutazioni rimanenti. Ecco il codice per confermare che sì, possiamo scambiare i due gruppi ed essere corretti:

# 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

Prestazione

Alla fine, abbiamo valutato solo 1,3 milioni delle 479 permutazioni e solo mischiato attraverso 550 MB di RAM. Sono necessari circa 0,7 secondi per l'esecuzione

# 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

Ecco la soluzione per il piccolo amico:

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