Lucky 26 oyunu çözmek için R kullanma

Oğluma kodlamanın bir oyunun neden olduğu bir sorunu çözmek için nasıl kullanılabileceğini ve R'nin büyük verileri nasıl ele aldığını görmeye çalışıyorum. Söz konusu oyuna "Şanslı 26" denir. Bu oyunda numaralar (yinelenmeyen 1-12) bir Davut yıldızı (12 tepe, 6 kavşak) üzerinde 12 noktaya yerleştirilir ve 4 sayının 6 çizgisinin tümü 26'ya eklenmelidir. Yaklaşık 479 milyon olasılıktan (12P12) ) Görünüşe göre 144 çözüm var. Aşağıdaki gibi bu R kodlamak çalıştı ama bellek göründüğü bir sorundur. Üyelerin zamanları varsa cevabı ilerletmek için herhangi bir tavsiyeyi çok takdir ediyorum. Üyelere şimdiden teşekkür ederiz.

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

İşte başka bir yaklaşım. Bir dayanıyor MathWorks blog yayınında tarafından Cleve Moler , ilk MATLAB yazarı.

Blog gönderisinde, belleği kaydetmek için yazar, ilk öğeyi apeks öğesi olarak ve 7. öğeyi temel öğe olarak koruyarak yalnızca 10 öğeye izin verir. Bu nedenle, sadece 10! == 3628800permütasyonların test edilmesi gerekir.
Aşağıdaki kodda,

1. Elementlerin permütasyon üret 1için 10. 10! == 3628800Bunların toplamı var .
2. 11Apeks öğesi olarak seçin ve sabit tutun. Görevlerin nereden başladığı önemli değil, diğer unsurlar doğru göreceli pozisyonlarda olacak.
3. Ardından, 12. elemanı bir fordöngü içinde 2. konuma, 3. konuma vb .

Bu, çözümlerin çoğunu üretmeli, rotasyonlar ve yansımalar vermeli veya almalıdır. Ancak çözümlerin benzersiz olduğunu garanti etmez. Aynı zamanda oldukça hızlı.

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

Aslında 960 çözüm var. Aşağıda Rcpp, 4 çekirdeği kullanarak çözümü elde etmek için , RcppAlgos^* ve parallelpaketini 6 secondskullanıyoruz. Baz R'lerle tek bir dişli yaklaşım kullanmayı tercih etseniz bile lapply, çözüm yaklaşık 25 saniye içinde geri döner.

İlk olarak, C++belirli bir permütasyonu kontrol eden basit bir algoritma yazıyoruz . Altı satırı da saklamak için bir dizi kullandığımızı göreceksiniz. Bu, 6 ayrı diziden daha önbellek kullandığımız için performans içindir. Ayrıca C++sıfır tabanlı indeksleme kullanan akılda tutmanız gerekir .

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

Şimdi, lowerve upperargümanlarını kullanarak, permuteGeneralpermütasyon parçaları oluşturabilir ve hafızayı kontrol altında tutmak için bunları ayrı ayrı test edebiliriz. Aşağıda, bir seferde yaklaşık 4.7 milyon permütasyonu test etmeyi seçtim. Çıktı 12 permütasyonlarının sözlüksel indekslerini verir! Şanslı 26 koşulu yerine getirilir.

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

Şimdi, belirli permütasyonlar oluşturmanıza izin veren permuteSampleargümanı ve argümanı doğrularız sampleVec(örneğin, 1'i geçerseniz, size ilk permütasyonu verecektir (yani 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

Son olarak, çözümümüzü temel R ile doğrularız 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

^* Ben yazarımRcppAlgos

Permütasyonlar için rcppalgos harika. Ne yazık ki, 12 alanla 479 milyon olasılık var, bu da çoğu insan için çok fazla bellek kaplıyor:

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

Bazı alternatifler var.

1. Permütasyonlardan bir örnek alın. Yani, 479 milyon yerine sadece 1 milyon. Bunu yapmak için kullanabilirsiniz permuteSample(12, 12, n = 1e6). 479 milyon permütasyonu örneklemenin dışında @ JosephWood'un biraz benzer bir yaklaşımın cevabına bakın;)

2. Oluşturmadaki permütasyonu değerlendirmek için rcpp'de bir döngü oluşturun. Bu, bellek tasarrufu sağlar, çünkü işlevi yalnızca doğru sonuçları döndürmek için oluşturursunuz.

3. Soruna farklı bir algoritma ile yaklaşın. Bu seçeneğe odaklanacağım.

Kısıtlı yeni algoritma

Segmentler 26 olmalıdır

Yukarıdaki yıldızdaki her bir çizgi segmentinin 26'ya kadar eklemesi gerektiğini biliyoruz. Permütasyonlarımızı oluşturmak için bu kısıtlamayı ekleyebiliriz - bize yalnızca 26'ya kadar olan kombinasyonlar verebiliriz:

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

ABCD ve EFGH grupları

Yukarıdaki yıldızda üç grubu farklı renklendirdim: ABCD , EFGH ve IJLK . İlk iki grubun da ortak noktaları yoktur ve aynı zamanda ilgili çizgi segmentlerinde yer alırlar. Bu nedenle, başka bir kısıtlama ekleyebiliriz: 26'ya kadar olan kombinasyonlar için, ABCD ve EFGH'nin sayı çakışması olmamasını sağlamalıyız . Kalan 4 numaraya IJLK atanacaktır.

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

Gruplar arasında permütasyon

Her grubun tüm permütasyonlarını bulmalıyız. Yani, sadece 26'ya kadar olan kombinasyonlarımız var. Örneğin, almamız 1, 2, 11, 12ve yapmamız gerekiyor 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]

Son Hesaplamalar

Son adım matematik yapmaktır. Kullandığım lapply()ve Reduce()burada daha işlevsel programlama yapmak - Aksi kod çok altı kez yazılabilir olacaktır. Matematik kodunun daha ayrıntılı bir açıklaması için orijinal çözüme bakın.

# 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 

Değiştirme ABCD ve EFGH

Yukarıdaki kodun sonunda, takas edebilmemiz ABCDve EFGHkalan permütasyonları elde etmemizden faydalandım . Evet, iki grubu değiştirebilir ve doğru olabiliriz:

# 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

Verim

Sonunda, 479 permütasyonun sadece 1.3 milyonunu değerlendirdik ve sadece 550 MB RAM ile karıştırdık. Çalıştırmak yaklaşık 0.7s sürer

# 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

İşte küçük adam için çözüm:

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