Użycie R do rozwiązania gry Lucky 26

Próbuję pokazać mojemu synowi, w jaki sposób kodowania można użyć do rozwiązania problemu związanego z grą, a także zobaczyć, jak R obsługuje duże zbiory danych. Ta gra nazywa się „Lucky 26”. W tej grze numery (1-12 bez duplikatów) są umieszczane na 12 punktach na gwiazdce Davida (6 wierzchołków, 6 skrzyżowań), a 6 linii po 4 liczby muszą się sumować do 26. Z około 479 milionów możliwości (12P12 ) najwyraźniej istnieją 144 rozwiązania. Próbowałem to zakodować w R w następujący sposób, ale wydaje się, że problem z pamięcią. Byłbym bardzo wdzięczny za każdą poradę, aby udzielić odpowiedzi, jeśli członkowie mają czas. Z góry dziękując członkom.

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

Oto inne podejście. Opiera się na postu na blogu MathWorks autorstwa Cleve Moler , autora pierwszego MATLAB-a.

W poście na blogu, aby zaoszczędzić pamięć, autor dopuszcza tylko 10 elementów, zachowując pierwszy element jako element wierzchołkowy, a 7 jako element podstawowy. Dlatego 10! == 3628800należy przetestować tylko permutacje.
W poniższym kodzie

1. Wygeneruj permutacje elementów 1do 10. Jest ich w sumie 10! == 3628800.
2. Wybierz 11jako element wierzchołka i utrzymuj go w stałym położeniu. Naprawdę nie ma znaczenia, gdzie zaczynają się zadania, pozostałe elementy będą w odpowiednich pozycjach względnych .
3. Następnie przypisz 12. element do 2. pozycji, 3. pozycji itp. W forpętli.

Powinno to wytworzyć większość rozwiązań, dać lub obrócić i odbić. Ale to nie gwarantuje, że rozwiązania są wyjątkowe. Jest także dość szybki.

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

W rzeczywistości istnieje 960 rozwiązań. Poniżej używamy Rcpp, RcppAlgos^* i parallelpakietu, aby uzyskać rozwiązanie nieco ponad 6 seconds4 rdzeni. Nawet jeśli zdecydujesz się zastosować podejście jednowątkowe z podstawami R lapply, rozwiązanie jest zwracane w około 25 sekund.

Najpierw piszemy prosty algorytm, C++który sprawdza konkretną permutację. Zauważysz, że używamy jednej tablicy do przechowywania wszystkich sześciu linii. Ma to na celu zwiększenie wydajności, ponieważ efektywniej wykorzystujemy pamięć podręczną niż 6 pojedynczych tablic. Musisz także pamiętać, że C++używa indeksowania zerowego.

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

Teraz, korzystając z argumentów loweri , możemy wygenerować fragmenty permutacji i przetestować je indywidualnie, aby utrzymać pamięć pod kontrolą. Poniżej postanowiłem przetestować około 4,7 miliona permutacji na raz. Dane wyjściowe dają indeksy leksykograficzne permutacji 12! tak, że warunek Lucky 26 jest spełniony.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

Teraz weryfikujemy użycie permuteSamplei argument, sampleVecktóry pozwala wygenerować określone permutacje (np. Jeśli przejdziesz 1, da ci to pierwszą permutację (tj. 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

Na koniec weryfikujemy nasze rozwiązanie z bazą 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

^* Jestem autoremRcppAlgos

Do permutacji rcppalgos jest świetny. Niestety istnieje 479 milionów możliwości z 12 polami, co oznacza, że ​​zabiera zbyt dużo pamięci dla większości ludzi:

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

Istnieje kilka alternatyw.

1. Pobierz próbkę permutacji. To znaczy, zrób tylko 1 milion zamiast 479 milionów. Aby to zrobić, możesz użyć permuteSample(12, 12, n = 1e6). Zobacz odpowiedź @ JosephWood na nieco podobne podejście, z wyjątkiem tego, że pobiera próbki do 479 milionów permutacji;)

2. Zbuduj pętlę w rcpp, aby ocenić permutację podczas tworzenia. Oszczędza to pamięć, ponieważ w rezultacie budowałbyś funkcję zwracającą tylko prawidłowe wyniki.

3. Podejdź do problemu za pomocą innego algorytmu. Skoncentruję się na tej opcji.

Nowy algorytm z ograniczeniami

Segmenty powinny mieć 26

Wiemy, że każdy segment linii w gwiazdce powyżej musi dodać do 26. Możemy dodać to ograniczenie do generowania naszych permutacji - daj nam tylko kombinacje, które sumują się do 26:

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

Grupy ABCD i EFGH

W gwiazdce powyżej kolorowałem trzy grupy inaczej: ABCD , EFGH i IJLK . Dwie pierwsze grupy również nie mają wspólnych punktów i znajdują się również w interesujących segmentach linii. Dlatego możemy dodać kolejne ograniczenie: w przypadku kombinacji, które sumują się do 26, musimy upewnić się, że ABCD i EFGH nie nakładają się na siebie liczb. IJLK zostaną przypisane pozostałe 4 numery.

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 poprzez grupy

Musimy znaleźć wszystkie permutacje każdej grupy. Oznacza to, że mamy tylko kombinacje, które sumują się do 26. Na przykład musimy wziąć 1, 2, 11, 12i wykonać 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]

Ostateczne obliczenia

Ostatnim krokiem jest zrobienie matematyki. Używam lapply()i Reduce()tutaj, aby robić bardziej funkcjonalne programowanie - w przeciwnym razie wiele kodu zostanie wpisanych sześć razy. Zobacz oryginalne rozwiązanie, aby uzyskać dokładniejsze objaśnienie kodu matematycznego.

# 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 

Zamiana ABCD i EFGH

Na końcu powyższego kodu skorzystałem z możliwości wymiany ABCDi EFGHuzyskania pozostałych permutacji. Oto kod potwierdzający, że tak, możemy zamienić dwie grupy i być poprawnym:

# 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

Wydajność

Ostatecznie oceniliśmy tylko 1,3 miliona spośród 479 permutacji i tylko przetasowaliśmy tylko przez 550 MB pamięci RAM. Uruchomienie zajmuje około 0,7 sekundy

# 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

Oto rozwiązanie dla małego gościa:

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