Verwenden Sie R, um das Lucky 26-Spiel zu lösen

Ich versuche meinem Sohn zu zeigen, wie Codierung verwendet werden kann, um ein von einem Spiel aufgeworfenes Problem zu lösen, und wie R mit Big Data umgeht. Das fragliche Spiel heißt "Lucky 26". In diesem Spiel werden Zahlen (1-12 ohne Duplikate) auf 12 Punkten auf einem Davidstern (6 Scheitelpunkte, 6 Schnittpunkte) positioniert und die 6 Linien mit 4 Zahlen müssen alle zu 26 addieren. Von den ungefähr 479 Millionen Möglichkeiten (12P12) ) Es gibt anscheinend 144 Lösungen. Ich habe versucht, dies in R wie folgt zu codieren, aber der Speicher scheint ein Problem zu sein. Ich würde mich über jeden Rat sehr freuen, die Antwort voranzutreiben, wenn die Mitglieder Zeit haben. Vielen Dank an die Mitglieder im Voraus.

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

Hier ist ein anderer Ansatz. Es basiert auf einem MathWorks-Blogbeitrag von Cleve Moler , dem Autor des ersten MATLAB.

Um Speicherplatz zu sparen, permutiert der Autor im Blog-Beitrag nur 10 Elemente, wobei das erste Element als Apex-Element und das 7. als Basiselement beibehalten werden. Daher müssen nur 10! == 3628800Permutationen getestet werden.
Im folgenden Code

1. Generieren Sie die Permutationen von Elementen 1zu 10. Es gibt insgesamt 10! == 3628800von ihnen.
2. Wählen Sie 11als Apex-Element und halten Sie es fest. Es ist wirklich egal, wo die Aufgaben beginnen, die anderen Elemente befinden sich an den richtigen relativen Positionen.
3. Ordnen Sie dann das 12. Element in einer forSchleife der 2. Position, 3. Position usw. zu .

Dies sollte die meisten Lösungen erzeugen, Rotationen und Reflexionen geben oder nehmen. Es garantiert jedoch nicht, dass die Lösungen einzigartig sind. Es ist auch ziemlich schnell.

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

Es gibt tatsächlich 960 Lösungen. Im Folgenden verwenden wir Rcpp, RcppAlgos^* und das parallelPaket, um die Lösung in etwas mehr als 6 seconds4 Kernen zu erhalten. Selbst wenn Sie sich für einen Single-Threaded-Ansatz mit Basis-Rs entscheiden lapply, wird die Lösung in etwa 25 Sekunden zurückgegeben.

Zunächst schreiben wir einen einfachen Algorithmus C++, der eine bestimmte Permutation überprüft. Sie werden feststellen, dass wir ein Array verwenden, um alle sechs Zeilen zu speichern. Dies dient der Leistung, da wir den Cache-Speicher effektiver nutzen als 6 einzelne Arrays. Sie müssen auch berücksichtigen, dass eine C++auf Null basierende Indizierung verwendet wird.

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

Nun wird die Verwendung lowerund upperin Argumente permuteGeneralkönnen wir Stücke von Permutationen erzeugen und diese einzeln testen Speicher in Schach zu halten. Im Folgenden habe ich beschlossen, ungefähr 4,7 Millionen Permutationen gleichzeitig zu testen. Die Ausgabe gibt die lexikografischen Indizes der Permutationen von 12 an! so dass die Lucky 26-Bedingung erfüllt ist.

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

Jetzt überprüfen wir die Verwendung permuteSampleund das Argument sampleVec, mit dem Sie bestimmte Permutationen generieren können (z. B. wenn Sie 1 übergeben, erhalten Sie die erste Permutation (dh 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

Schließlich verifizieren wir unsere Lösung mit Basis 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

^* Ich bin der Autor vonRcppAlgos

Für Permutationen ist rcppalgos großartig. Leider gibt es 479 Millionen Möglichkeiten mit 12 Feldern, was bedeutet, dass die meisten Menschen zu viel Speicherplatz beanspruchen:

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

Es gibt einige Alternativen.

1. Nehmen Sie eine Probe der Permutationen. Das heißt, nur 1 Million statt 479 Millionen. Dazu können Sie verwenden permuteSample(12, 12, n = 1e6). Siehe @ JosephWoods Antwort für einen etwas ähnlichen Ansatz, außer dass er 479 Millionen Permutationen abtastet;)

2. Erstellen Sie eine Schleife in rcpp , um die Permutation bei der Erstellung auszuwerten. Dies spart Speicher, da Sie am Ende die Funktion erstellen würden, um nur die richtigen Ergebnisse zurückzugeben.

3. Gehen Sie das Problem mit einem anderen Algorithmus an. Ich werde mich auf diese Option konzentrieren.

Neuer Algorithmus mit Einschränkungen

Segmente sollten 26 sein

Wir wissen, dass jedes Liniensegment im obigen Stern bis zu 26 addieren muss. Wir können diese Einschränkung zur Erzeugung unserer Permutationen hinzufügen - geben Sie nur Kombinationen an, die bis zu 26 addieren:

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

ABCD und EFGH Gruppen

Im obigen Stern habe ich drei Gruppen unterschiedlich gefärbt: ABCD , EFGH und IJLK . Die ersten beiden Gruppen haben ebenfalls keine gemeinsamen Punkte und sind auch auf interessierenden Liniensegmenten. Daher können wir eine weitere Einschränkung hinzufügen: Für Kombinationen, die sich zu 26 addieren, müssen wir sicherstellen, dass ABCD und EFGH keine Zahlenüberlappung aufweisen. IJLK werden die restlichen 4 Nummern zugewiesen.

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

Permute durch die Gruppen

Wir müssen alle Permutationen jeder Gruppe finden. Das heißt, wir haben nur Kombinationen, die sich zu 26 addieren. Zum Beispiel müssen wir nehmen 1, 2, 11, 12und machen 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]

Endgültige Berechnungen

Der letzte Schritt ist die Mathematik. Ich benutze lapply()und Reduce()hier, um mehr funktionale Programmierung zu machen - sonst würde viel Code sechsmal eingegeben. In der ursprünglichen Lösung finden Sie eine ausführlichere Erläuterung des mathematischen Codes.

# 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 

Swapping ABCD und EFGH

Am Ende des obigen Codes habe ich den Vorteil genutzt, dass wir tauschen ABCDund EFGHdie verbleibenden Permutationen erhalten können. Hier ist der Code, um zu bestätigen, dass wir die beiden Gruppen austauschen und korrekt sein können:

# 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

Am Ende haben wir nur 1,3 Millionen der 479 Permutationen ausgewertet und nur 550 MB RAM gemischt. Die Ausführung dauert ca. 0,7 Sekunden

# 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

Hier ist die Lösung für den kleinen Kerl:

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