Использование R, чтобы решить игру Lucky 26

Я пытаюсь показать сыну, как можно использовать кодирование для решения проблемы, возникающей в игре, а также посмотреть, как R обрабатывает большие данные. Эта игра называется «Счастливчик 26». В этой игре числа (1-12 без дубликатов) расположены на 12 точках звезды Давида (6 вершин, 6 пересечений), и 6 линий по 4 числа должны все добавить к 26. Из приблизительно 479 миллионов возможностей (12P12 ) есть, по-видимому, 144 решения. Я попытался закодировать это в R следующим образом, но, похоже, проблема с памятью. Я был бы очень признателен за любой совет, если у участников будет время. Поблагодарив членов заранее.

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

Вот другой подход. Он основан на пост MathWorks блоге по Клив Moler , автор первой MATLAB.

В сообщении в блоге для экономии памяти автор переставляет только 10 элементов, оставляя первый элемент в качестве элемента apex и 7-й в качестве базового элемента. Поэтому только10! == 3628800 перестановки должны быть проверены.
В приведенном ниже коде

1. Генерация перестановок элементов 1 для 10. Всего10! == 3628800 их есть.
2. выбирать 11 как верхний элемент и сохраните его фиксированным. Это действительно не имеет значения, где начинаются назначения, другие элементы будут в правильном отношении позициях.
3. Затем присвойте 12-й элемент 2-й позиции, 3-й позиции и т. Д. В forцикле.

Это должно дать большинство решений, дать или взять повороты и отражения. Но это не гарантирует, что решения уникальны. Это также достаточно быстро.

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

На самом деле существует 960 решений. Ниже мы используем Rcpp, RcppAlgos^* и parallelпакет, чтобы получить решение чуть более, 6 secondsиспользуя 4 ядра. Даже если вы решите использовать однопоточный подход с базой Rlapply , решение возвращается примерно через 25 секунд.

Сначала мы напишем простой алгоритм, C++который проверяет конкретную перестановку. Вы заметите, что мы используем один массив для хранения всех шести строк. Это для производительности, так как мы используем кэш-память более эффективно, чем 6 отдельных массивов. Вы также должны иметь в виду, что C++используется индексация с нуля.

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

Теперь, используя аргументы lowerи , мы можем генерировать порции перестановок и тестировать их по отдельности, чтобы контролировать память. Ниже я выбрал для тестирования около 4,7 миллионов перестановок одновременно. Выходные данные дают лексикографические показатели перестановок 12! так что условие Lucky 26 выполнено.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

Теперь мы проверяем использование permuteSampleи аргумент, sampleVecкоторый позволяет вам генерировать конкретные перестановки (например, если вы передадите 1, он даст вам первую перестановку (т.е. 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

Наконец, мы проверяем наше решение с базой 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

^* Я авторRcppAlgos

Для перестановок rcppalgos отлично подходит. К сожалению, существует 479 миллионов возможностей с 12 полями, что означает, что для большинства людей это занимает слишком много памяти:

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

Есть несколько альтернатив.

1. Возьмите образец перестановок. То есть только 1 миллион вместо 479 миллионов. Для этого вы можете использовать permuteSample(12, 12, n = 1e6). См. Ответ @ JosephWood о похожем подходе, за исключением того, что он выбрал 479 миллионов перестановок;)

2. Создайте цикл в rcpp для оценки перестановки при создании. Это экономит память, потому что вы в конечном итоге создадите функцию, которая будет возвращать только правильные результаты.

3. Подход к задаче с другим алгоритмом. Я сосредоточусь на этом варианте.

Новый алгоритм с ограничениями

Сегментов должно быть 26

Мы знаем, что каждый сегмент линии в звезде выше должен добавить до 26. Мы можем добавить это ограничение к генерации наших перестановок - дать нам только комбинации, которые в сумме дают 26:

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

ABCD и EFGH группы

В приведенной выше звезде я по-разному раскрасил три группы: ABCD , EFGH и IJLK . Первые две группы также не имеют общих точек и также представляют интерес на линейных отрезках. Поэтому мы можем добавить еще одно ограничение: для комбинаций, которые в сумме составляют 26, мы должны убедиться, что ABCD и EFGH не перекрываются. IJLK будет присвоен оставшиеся 4 номера.

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

Переставить через группы

Нам нужно найти все перестановки каждой группы. То есть у нас есть только комбинации, которые в сумме составляют 26. Например, нам нужно взять 1, 2, 11, 12и сделать 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]

Окончательные расчеты

Последний шаг - сделать математику. Я использую lapply()и Reduce()здесь, чтобы сделать более функциональное программирование - в противном случае много кода было бы напечатано шесть раз. Смотрите оригинальное решение для более подробного объяснения математического кода.

# 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 

Перекачка ABCD и EFGH

В конце кода выше я воспользовался тем, что мы можем поменяться местами ABCDи EFGHполучить оставшиеся перестановки. Вот код, подтверждающий, что да, мы можем поменять две группы и быть правильными:

# 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

Представление

В итоге мы оценили только 1,3 миллиона из 479 перестановок и только перетасовали только 550 МБ ОЗУ. Для запуска требуется около 0,7 с

# 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

Вот решение для маленького парня:

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