Menggunakan R untuk menyelesaikan permainan Lucky 26

Saya mencoba menunjukkan kepada anak saya bagaimana pengkodean dapat digunakan untuk memecahkan masalah yang ditimbulkan oleh sebuah permainan serta melihat bagaimana R menangani data besar. Game yang dimaksud disebut "Lucky 26". Dalam game ini angka (1-12 tanpa duplikat) diposisikan pada 12 poin pada bintang david (6 vertex, 6 persimpangan) dan 6 baris 4 angka semuanya harus menambah 26. Dari sekitar 479 juta kemungkinan (12P12 ) rupanya ada 144 solusi. Saya mencoba kode ini dalam R sebagai berikut tetapi tampaknya masalah memori. Saya akan sangat menghargai saran untuk memajukan jawaban jika anggota punya waktu. Berterima kasih kepada anggota sebelumnya.

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

Ini pendekatan lain. Ini didasarkan pada posting blog MathWorks oleh Cleve Moler , penulis MATLAB pertama.

Dalam posting blog, untuk menghemat memori penulis hanya mengijinkan 10 elemen, menjaga elemen pertama sebagai elemen puncak dan yang ke 7 sebagai elemen dasar. Oleh karena itu, hanya 10! == 3628800permutasi yang perlu diuji.
Dalam kode di bawah ini,

1. Hasilkan permutasi elemen 1ke 10. Ada total 10! == 3628800dari mereka.
2. Pilih 11sebagai elemen puncak dan pertahankan. Tidak masalah dari mana tugas dimulai, elemen lainnya akan berada di posisi relatif yang tepat .
3. Kemudian tetapkan elemen ke-12 ke posisi 2, posisi 3, dll, dalam satu forlingkaran.

Ini harus menghasilkan sebagian besar solusi, memberi atau mengambil rotasi dan refleksi. Tetapi itu tidak menjamin bahwa solusinya unik. Ini juga cukup cepat.

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

Sebenarnya ada 960 solusi. Di bawah ini kami menggunakan Rcpp, RcppAlgos^* , dan parallelpaket untuk mendapatkan solusinya hanya dalam waktu singkat6 seconds menggunakan 4 core. Bahkan jika Anda memilih untuk menggunakan pendekatan berulir tunggal dengan basis R lapply, solusinya dikembalikan dalam waktu sekitar 25 detik.

Pertama, kami menulis algoritma sederhana C++yang memeriksa permutasi tertentu. Anda akan perhatikan bahwa kami menggunakan satu array untuk menyimpan semua enam baris. Ini untuk kinerja karena kami menggunakan memori cache lebih efektif daripada menggunakan 6 array individual. Anda juga harus ingat bahwa C++menggunakan pengindeksan berbasis nol.

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

Sekarang, dengan menggunakan lowerdan upperargumen di permuteGeneral, kita dapat menghasilkan potongan permutasi dan mengujinya secara terpisah untuk menjaga memori tetap terkendali. Di bawah ini, saya telah memilih untuk menguji sekitar 4,7 juta permutasi sekaligus. Outputnya memberikan indeks leksikografis dari permutasi 12! sehingga kondisi Lucky 26 puas.

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

Sekarang, kami memverifikasi menggunakan permuteSampledan argumen sampleVecyang memungkinkan Anda untuk menghasilkan permutasi spesifik (misalnya jika Anda melewati 1, itu akan memberi Anda permutasi pertama (yaitu 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

Akhirnya, kami memverifikasi solusi kami dengan 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

^* Saya adalah penulisRcppAlgos

Untuk permutasi, rcppalgos bagus. Sayangnya, ada 479 juta kemungkinan dengan 12 bidang yang berarti terlalu banyak memori untuk kebanyakan orang:

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

Ada beberapa alternatif.

1. Ambil sampel permutasi. Artinya, lakukan hanya 1 juta bukan 479 juta. Untuk melakukan ini, Anda dapat menggunakan permuteSample(12, 12, n = 1e6). Lihat @ JosephWood's jawaban untuk pendekatan yang agak mirip kecuali dia sampel 479 juta permutasi;)

2. Buat loop di rcpp untuk mengevaluasi permutasi pada kreasi. Ini menghemat memori karena pada akhirnya Anda akan membangun fungsi hanya untuk mengembalikan hasil yang benar.

3. Dekati masalah dengan algoritma yang berbeda. Saya akan fokus pada opsi ini.

Algoritma baru dengan kendala

Segmen harus 26

Kita tahu bahwa setiap segmen baris dalam bintang di atas perlu menambahkan hingga 26. Kita dapat menambahkan kendala itu untuk menghasilkan permutasi kami - beri kami hanya kombinasi yang menambahkan hingga 26:

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

Kelompok ABCD dan EFGH

Pada bintang di atas, saya telah mewarnai tiga grup secara berbeda: ABCD , EFGH , dan IJLK . Dua kelompok pertama juga tidak memiliki kesamaan poin dan juga memiliki segmen bunga yang sama. Oleh karena itu, kita dapat menambahkan batasan lain: untuk kombinasi yang menambahkan hingga 26, kita perlu memastikan ABCD dan EFGH tidak memiliki angka yang tumpang tindih. IJLK akan diberi 4 angka sisanya.

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

Permutasi melalui grup

Kita perlu menemukan semua permutasi dari setiap grup. Artinya, kami hanya memiliki kombinasi yang menambahkan hingga 26. Misalnya, kami perlu mengambil 1, 2, 11, 12dan membuat 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]

Perhitungan Akhir

Langkah terakhir adalah melakukan perhitungan. Saya menggunakan lapply()dan di Reduce()sini untuk melakukan pemrograman yang lebih fungsional - jika tidak, banyak kode akan diketik enam kali. Lihat solusi asli untuk penjelasan yang lebih menyeluruh tentang kode matematika.

# 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 dan EFGH

Pada akhir kode di atas, saya mengambil keuntungan bahwa kita dapat bertukar ABCDdan EFGHmendapatkan permutasi yang tersisa. Berikut adalah kode untuk mengonfirmasi bahwa ya, kami dapat menukar kedua grup dan menjadi benar:

# 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

Performa

Pada akhirnya, kami mengevaluasi hanya 1,3 juta dari 479 permutasi dan hanya mengocok hingga 550 MB RAM. Dibutuhkan sekitar 0,7 untuk menjalankan

# 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

Inilah solusi untuk kawan kecil:

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