Поиск с конца списка в Mathematica

Многие алгоритмы (например, алгоритм поиска следующей перестановки списка в лексикографическом порядке) включают поиск индекса последнего элемента в списке. Тем не менее, я не смог найти способ сделать это в Mathematica, что не является неудобным. Самый простой подход использует LengthWhile, но это означает изменение всего списка, что, вероятно, будет неэффективным в тех случаях, когда вы знаете элемент, который вы want находится ближе к концу списка и реверсирует смысл предиката:

findLastLengthWhile[list_, predicate_] :=
 ([email protected] - LengthWhile[[email protected], ! [email protected]# &]) /. (0 -> $Failed)

Мы могли бы сделать явный, императивный цикл с Do, но это тоже немного неудобно. Это помогло бы, если Return фактически вернется из функции вместо блока Do, но это не так, поэтому вы можете как хорошо использовать Break:

findLastDo[list_, pred_] :=
 Module[{k, result = $Failed},
  Do[
   If[[email protected][[k]], result = k; Break[]],
   {k, [email protected], 1, -1}];
  result]

В конечном счете, я решил повторить использование хвостовой рекурсии, что означает, что раннее завершение немного легче. Используя странную, но полезную нотацию #0, которая позволяет анонимным функциям вызывать себя, это становится:

findLastRecursive[list_, pred_] :=
 With[{
   step =
    Which[
      #1 == 0, $Failed,
      [email protected][[#1]], #1,
      True, #0[#1 - 1]] &},
  step[[email protected]]]

Все это кажется слишком сложным. Кто-нибудь видит лучший способ?

EDIT, чтобы добавить: Конечно, у моего предпочтительного решения есть ошибка, которая означает, что она разбита на длинные списки из-за $IterationLimit.

In[107]:= findLastRecursive[Range[10000], # > 10000 &]
$IterationLimit::itlim: Iteration limit of 4096 exceeded. 
Out[107]= (* gack omitted *)

Вы можете исправить это с помощью Block:

findLastRecursive[list_, pred_] :=
 Block[{$IterationLimit = Infinity},
  With[{
    step =
     Which[
       #1 == 0, $Failed,
       [email protected][[#1]], #1,
       True, #0[#1 - 1]] &},
   step[[email protected]]]]

$IterationLimit не является моей любимой функцией Mathematica.

Ответ 1

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

Clear[findLastLengthWhile];
findLastLengthWhile[{}, _] = 0;
findLastLengthWhile[list_, predicate_] /; predicate[Last[list]] := Length[list];
findLastLengthWhile[list_, predicate_] :=
   Module[{l = Length[list]}, 
     Scan[If[predicate[#], Return[], l--] &, Reverse[list]]; l];

Я не знаю, проще ли это. Он, конечно, менее эффективен, чем тот, который основан на LengthWhile, особенно для упакованных массивов. Кроме того, я использую соглашение о возврате 0, когда не найден элемент, удовлетворяющий условию, а не $Failed, но это только личное предпочтение.

ИЗМЕНИТЬ

Вот рекурсивная версия, основанная на связанных списках, которая несколько эффективнее:

ClearAll[linkedList, toLinkedList];
SetAttributes[linkedList, HoldAllComplete];
toLinkedList[data_List] := Fold[linkedList, linkedList[], data];

Clear[findLastRec];
findLastRec[list_, pred_] :=
  Block[{$IterationLimit = Infinity},
     Module[{ll = toLinkedList[list], findLR},
       findLR[linkedList[]] := 0;
       findLR[linkedList[_, el_?pred], n_] := n;
       findLR[linkedList[ll_, _], n_] := findLR[ll, n - 1];
       findLR[ll, Length[list]]]]

Некоторые ориентиры:

In[48]:= findLastRecursive[Range[300000],#<9000&]//Timing
Out[48]= {0.734,8999}

In[49]:= findLastRec[Range[300000],#<9000&]//Timing
Out[49]= {0.547,8999}

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

Если ваш список можно сделать упакованным массивом (любых измерений), вы можете использовать компиляцию для C для решений на основе циклов. Чтобы избежать накладных расходов на компиляцию, вы можете memoize скомпилированную функцию, например:

Clear[findLastLW];
findLastLW[predicate_, signature_] := findLastLW[predicate, Verbatim[signature]] = 
   Block[{list},
       With[{sig = [email protected][signature, list]},
      Compile @@ Hold[
        sig,
        Module[{k, result = 0},
          Do[
            If[[email protected][[k]], result = k; Break[]], 
            {k, [email protected], 1, -1}
          ];
          result], 
        CompilationTarget -> "C"]]]

Часть Verbatim необходима, так как в типичных сигнатурах, таких как {_Integer,1}, _Integer иначе интерпретируется как шаблон, а memoized определение не будет соответствовать. Вот пример:

In[60]:= 
fn = findLastLW[#<9000&,{_Integer,1}];
fn[Range[300000]]//Timing

Out[61]= {0.016,8999}

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

Вот более компактная и быстрая версия рекурсивного решения на основе связанных списков:

Clear[findLastRecAlt];
findLastRecAlt[{}, _] = 0;
findLastRecAlt[list_, pred_] :=
  Module[{lls, tag},
    Block[{$IterationLimit = Infinity, linkedList},
       SetAttributes[linkedList, HoldAllComplete];
       lls = Fold[linkedList, linkedList[], list];
       ll : linkedList[_, el_?pred] := Throw[Depth[Unevaluated[ll]] - 2, tag];
       linkedList[ll_, _] := ll;
       Catch[lls, tag]/. linkedList[] :> 0]]

Это так же быстро, как версии, основанные на циклах Do - и в два раза быстрее, чем исходный findLastRecursive (соответствующий тест, который будет добавлен в ближайшее время - я не могу сделать последовательные (с предыдущими) эталонами на другой машине в данный момент). Я думаю, что это хорошая иллюстрация того, что хвосто-рекурсивные решения в mma могут быть такими же эффективными, как и процедурные (несвязанные).

Ответ 2

Не совсем ответ, просто пара вариантов на findLastDo.

(1) Фактически Return может принять недокументированный второй аргумент, говорящий о том, что нужно вернуть.

In[74]:= findLastDo2[list_, pred_] := 
 Module[{k, result = $Failed}, 
  Do[If[[email protected][[k]], Return[k, Module]], {k, [email protected], 1, -1}];
  result]

In[75]:= findLastDo2[Range[25], # <= 22 &]
Out[75]= 22

(2) Лучше использовать Catch [... Throw...]

In[76]:= findLastDo3[list_, pred_] := 
 Catch[Module[{k, result = $Failed}, 
   Do[If[[email protected][[k]], Throw[k]], {k, [email protected], 1, -1}];
   result]]

In[77]:= findLastDo3[Range[25], # <= 22 &]
Out[77]= 22

Даниэль Лихтблау

Ответ 3

Для приключений...

Следующие определения определяют выражение-оболочку reversed[...], которое маскируется как объект списка, содержимое которого представляет собой обратную версию завернутого списка:

reversed[list_][[i_]] ^:= list[[-i]]
Take[reversed[list_], i_] ^:= Take[list, -i]
Length[reversed[list_]] ^:= Length[list]
Head[reversed[list_]] ^:= List

Использование примера:

$list = Range[1000000];
Timing[LengthWhile[reversed[$list], # > 499500 &]]
(* {1.248, 500500} *)

Обратите внимание, что этот метод медленнее, чем фактическое изменение списка...

Timing[LengthWhile[Reverse[$list], # > 499500 &]]
(* 0.468, 500500 *)

... но, конечно, он использует гораздо меньше памяти.

Я бы не рекомендовал эту технику для общего использования, поскольку недостатки в маскараде могут проявляться в виде тонких ошибок. Рассмотрим: какие другие функции необходимо реализовать для идеального моделирования? Выявленные определения оболочки, по-видимому, достаточно хороши, чтобы обмануть LengthWhile и TakeWhile для простых случаев, но другие функции (в частности, встроенные ядра) не могут быть настолько легко обмануты. Переопределение Head кажется особенно чреватым опасностью.

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

Ответ 4

Вот несколько альтернатив, два из которых не меняют список:

findLastLengthWhile2[list_, predicate_] := 
 Length[list]-(Position[list//Reverse, _?(!predicate[#] &),1,1]/.{}->{{0}})[[1, 1]]+1

findLastLengthWhile3[list_, predicate_] := 
    Module[{lw = 0}, 
      Scan[If[predicate[#], lw++, lw = 0] &, list]; 
      Length[list] - lw
    ]

findLastLengthWhile4[list_, predicate_] := 
   Module[{a}, a = Split[list, predicate]; 
         Length[list] - If[predicate[a[[-1, 1]]], Length[a[[-1]]], 0]
   ]

Некоторые тайминги (номер 1 - первый Pillsy) для поиска последнего прогона 1 в массиве 100 000 1, в котором один нуль помещается на разные позиции. Сроки представляют собой среднее значение 10 повторных пересылок:

enter image description here

Код, используемый для тайминга:

Monitor[
 timings = Table[
   ri = ConstantArray[1, {100000}];
   ri[[daZero]] = 0;
   t1 = (a1 = findLastLengthWhile[ri, # == 1 &];) // Timing // First;
   t2 = (a2 = findLastLengthWhile2[ri, # == 1 &];) // Timing // First;
   t3 = (a3 = findLastLengthWhile3[ri, # == 1 &];) // Timing // First;
   t4 = (a4 = findLastLengthWhile4[ri, # == 1 &];) // Timing // First;
   {t1, t2, t3, t4},
   {daZero, {1000, 10000, 20000, 50000, 80000, 90000, 99000}}, {10}
   ], {daZero}
 ]

ListLinePlot[
   Transpose[{{1000, 10000, 20000, 50000, 80000, 90000,99000}, #}] & /@ 
     (Mean /@ timings // Transpose), 
   Mesh -> All, Frame -> True, FrameLabel -> {"Zero position", "Time (s)", "", ""}, 
   BaseStyle -> {FontFamily -> "Arial", FontWeight -> Bold, 
   FontSize -> 14}, ImageSize -> 500
]

Ответ 5

Сроки Reverse для строк и реалов

a = DictionaryLookup[__];
b = RandomReal[1, 10^6];
Timing[[email protected]@#] & /@ {a, b}

(*
 ->
{{0.016,         {Zyuganov,Zyrtec,zymurgy,zygotic,zygotes,...}},
 {3.40006*10^-15,{0.693684,0.327367,<<999997>>,0.414146}}}
*)

Ответ 6

Элегантным решением будет:

findLastPatternMatching[{Longest[start___], f_, ___}, f_] := Length[{start}]+1

(* match this pattern if item not in list *)
findLastPatternMatching[_, _] := -1

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