Создайте список в Mathematica с условным тестированием для каждого элемента

Предположим, что мы хотим сгенерировать список простых чисел p, для которых p + 2 также просто.

Быстрое решение состоит в том, чтобы сгенерировать полный список первых n простых чисел и использовать функцию Select для возврата элементов, соответствующих условиям.

Select[Table[Prime[k], {k, n}], PrimeQ[# + 2] &]

Однако это неэффективно, поскольку он загружает большой список в память перед возвратом отфильтрованного списка. Цикл For с Sow/Reap (или l = {}; AppendTo[l, k]) решает проблему с памятью, но она далека от элегантности и громоздка для реализации несколько раз в Mathematica script.

Reap[
  For[k = 1, k <= n, k++,
   p = Prime[k];
   If[PrimeQ[p + 2], Sow[p]]
  ]
 ][[-1, 1]]

Идеальное решение было бы встроенной функцией, которая позволяет вариант, подобный этому.

Table[Prime[k], {k, n}, AddIf -> PrimeQ[# + 2] &]

Ответ 1

Я буду интерпретировать это скорее как вопрос об автоматизации и разработке программного обеспечения, а не о конкретной проблеме и учитывая большое количество уже опубликованных решений. Reap и Sow являются хорошими средствами (возможно, лучшими в символической настройке) для сбора промежуточных результатов. Давайте просто сделаем его общим, чтобы избежать дублирования кода.

Нам нужно написать функцию более высокого порядка. Я не буду делать ничего принципиально нового, но просто упакую ваше решение, чтобы сделать его более общеприменимым:

Clear[tableGen];
tableGen[f_, iter : {i_Symbol, __}, addif : Except[_List] : (True &)] :=
 Module[{sowTag},   
  If[# === {}, #, [email protected]#] &@
       [email protected][Do[If[addif[#], Sow[#,sowTag]] &[f[i]], iter],sowTag]];

Преимущества использования Do over For заключаются в том, что переменная цикла динамически локализована (поэтому глобальные модификации для нее вне области Do), а также синтаксис итератора Do ближе до Table (Do также немного быстрее).

Теперь, это использование

In[56]:= tableGen[Prime, {i, 10}, PrimeQ[# + 2] &]

Out[56]= {3, 5, 11, 17, 29}

In[57]:= tableGen[Prime, {i, 3, 10}, PrimeQ[# + 1] &]

Out[57]= {}

In[58]:= tableGen[Prime, {i, 10}]

Out[58]= {2, 3, 5, 7, 11, 13, 17, 19, 23, 29}

ИЗМЕНИТЬ

Эта версия ближе к упомянутому синтаксису (вместо выражения используется выражение):

ClearAll[tableGenAlt];
SetAttributes[tableGenAlt, HoldAll];
tableGenAlt[expr_, iter_List, addif : Except[_List] : (True &)] :=
 Module[{sowTag}, 
  If[# === {}, #, [email protected]#] &@
    [email protected][Do[If[addif[#], Sow[#,sowTag]] &[expr], iter],sowTag]];

У этого есть дополнительное преимущество, что вы можете даже иметь символы итератора, определенные глобально, поскольку они передаются неоценимыми и динамически локализованными. Примеры использования:

In[65]:= tableGenAlt[Prime[i], {i, 10}, PrimeQ[# + 2] &]

Out[65]= {3, 5, 11, 17, 29}

In[68]:= tableGenAlt[Prime[i], {i, 10}]

Out[68]= {2, 3, 5, 7, 11, 13, 17, 19, 23, 29}

Обратите внимание, что поскольку синтаксис сейчас отличается, нам пришлось использовать атрибут Hold, чтобы предотвратить переданное выражение expr от преждевременной оценки.

РЕДАКТИРОВАТЬ 2

В запросе на @Simon, вот обобщение для многих измерений:

ClearAll[tableGenAltMD];
SetAttributes[tableGenAltMD, HoldAll];
tableGenAltMD[expr_, iter__List, addif : Except[_List] : (True &)] :=
Module[{indices, indexedRes, sowTag},
  SetDelayed @@  Prepend[Thread[Map[Take[#, 1] &, List @@ Hold @@@ Hold[iter]], 
      Hold], indices];
  indexedRes = 
    If[# === {}, #, [email protected]#] &@
      [email protected][Do[If[addif[#], Sow[{#, indices},sowTag]] &[expr], iter],sowTag];
  Map[
    First, 
    SplitBy[indexedRes , 
      Table[With[{i = i}, Function[Slot[1][[2, i]]]], {i,Length[Hold[iter]] - 1}]], 
    {-3}]];

Это значительно менее тривиально, так как я должен был Sow индексов вместе с добавленными значениями, а затем разбивать полученный плоский список в соответствии с индексами. Вот пример использования:

{i, j, k} = {1, 2, 3};
tableGenAltMD[i + j + k, {i, 1, 5}, {j, 1, 3}, {k, 1, 2}, # < 7 &]

{{{3, 4}, {4, 5}, {5, 6}}, {{4, 5}, {5, 6}, {6}}, {{5, 6}, {6}}, {{6}}}

Я присвоил значения переменным -тератору i,j,k, чтобы проиллюстрировать, что эта функция локализует переменные итератора и нечувствительна к возможным глобальным значениям для них. Чтобы проверить результат, мы можем использовать Table, а затем удалить элементы, не удовлетворяющие условию:

In[126]:= 
DeleteCases[Table[i + j + k, {i, 1, 5}, {j, 1, 3}, {k, 1, 2}], 
    x_Integer /; x >= 7, Infinity] //. {} :> Sequence[]

Out[126]= {{{3, 4}, {4, 5}, {5, 6}}, {{4, 5}, {5, 6}, {6}}, {{5, 6}, {6}}, {{6}}}

Обратите внимание, что я не выполнял обширных проверок, поэтому текущая версия может содержать ошибки и требует еще нескольких тестов.

РЕДАКТИРОВАТЬ 3 - ОШИБКА

Обратите внимание на важное исправление ошибок: во всех функциях я теперь использую Sow с уникальным уникальным тегом и Reap. Без этого изменения функции не будут работать должным образом, когда выражение, которое они оценивают, также использует Sow. Это общая ситуация с Reap - Sow и напоминает это для исключений (Throw - Catch).

РЕДАКТИРОВАТЬ 4 - SyntaxInformation

Так как это такая потенциально полезная функция, приятно заставить ее вести себя как встроенная функция. Сначала мы добавляем подсветку синтаксиса и проверку основных аргументов через

SyntaxInformation[tableGenAltMD] = {"ArgumentsPattern" -> {_, {_, _, _., _.}.., _.},
                                    "LocalVariables" -> {"Table", {2, -2}}};

Затем добавление сообщения об использовании позволяет использовать пункт меню "Сделать шаблон" (Shift+Ctrl+k):

tableGenAltMD::usage = "tableGenAltMD[expr,{i,imax},addif] will generate \
a list of values expr when i runs from 1 to imax, \
only including elements if addif[expr] returns true.
The default of addiff is True&."

Более полное и отформатированное сообщение об использовании можно найти в этом значении.

Ответ 2

Я думаю, что подход Reap/Sow, вероятно, будет наиболее эффективным с точки зрения использования памяти. Некоторые альтернативы могут быть:

DeleteCases[(With[{p=Prime[#]},If[PrimeQ[p+2],p,{}] ] ) & /@ Range[K]),_List]

Или (для устранения результатов Null может потребоваться какой-то DeleteCases):

FoldList[[(With[{p=Prime[#2]},If[PrimeQ[p+2],p] ] )& ,1.,Range[2,K] ]

Оба содержат большой список целых чисел от 1 до K в памяти, но Primes находятся внутри структуры With [].

Ответ 3

Да, это еще один ответ. Другой альтернативой, которая включает в себя вкус подхода Reap/Sow и подход FoldList, будет использовать Scan.

result = {1};
Scan[With[{p=Prime[#]},If[PrimeQ[p+2],result={result,p}]]&,Range[2,K] ];
Flatten[result]

Опять же, это включает в себя длинный список целых чисел, но промежуточные результаты Prime не сохраняются, поскольку они находятся в локальной области С. Поскольку p является константой в объеме функции With, вы можете использовать With, а не Module, и немного увеличить скорость.

Ответ 4

Вы можете попробовать что-то вроде этого:

Clear[f, primesList]
f = With[{p = Prime[#]},Piecewise[{{p, PrimeQ[p + 2]}}, {}] ] &;
primesList[k_] := [email protected]@(f /@ Range[k]);

Если вам нужны как простые p, так и простые p+2, то решение есть

Clear[f, primesList]
f = With[{p = Prime[#]},Piecewise[{{p, PrimeQ[p + 2]}}, {}] ] &;
primesList[k_] := 
  Module[{primes = f /@ Range[k]}, 
   [email protected]@{primes, primes + 2}];

Ответ 5

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

В старые добрые времена перед функциональным программированием:) такого рода вещи были решены путем выделения максимального размера массива, а затем с помощью отдельного индекса для его вставки, чтобы не было сделано никаких дыр. Как этот

x=Table[0,{100}];  (*allocate maximum possible*)
j=0;
Table[ If[PrimeQ[k+2], x[[++j]]=k],{k,100}];

x[[1;;j]]  (*the result is here *)

{1,3,5,9,11,15,17,21,27,29,35,39,41,45,51,57,59,65,69,71,77,81,87,95,99}

Ответ 6

Здесь еще несколько альтернатив, использующих NextPrime:

pairs1[pmax_] := Select[Range[pmax], PrimeQ[#] && NextPrime[#] == 2 + # &]

pairs2[pnum_] := Module[{p}, NestList[(p = NextPrime[#];
                      While[p + 2 != (p = NextPrime[p])]; 
                      p - 2) &, 3, pnum]]

и модификация вашего решения Reap/Sow, которое позволяет указать максимальное значение:

pairs3[pmax_] := Module[{k,p},
                   Reap[For[k = 1, (p = Prime[k]) <= pmax, k++,
                        If[PrimeQ[p + 2], Sow[p]]]][[-1, 1]]]

Вышеуказанные в порядке возрастания скорости.

In[4]:= pairs2[10000]//Last//Timing
Out[4]= {3.48,1261079}
In[5]:= pairs1[1261079]//Last//Timing
Out[5]= {6.84,1261079}
In[6]:= pairs3[1261079]//Last//Timing
Out[7]= {0.58,1261079}