Mathematica: реконструировать произвольный вложенный список после Flatten

Question

Какой самый простой способ отобразить произвольно напуганный вложенный список expr в функцию unflatten, чтобы expr==unflatten@@Flatten@expr?

Мотивация: Compile могла обрабатывать толькополные массивы (что я только что узнал, но не из сообщения об ошибке), поэтому идея состоит в том, чтобы использовать unflatten вместе со скомпилированной версией сглаженного выражения:

fPrivate=Compile[{x,y},Evaluate@Flatten@expr];
f[x_?NumericQ,y_?NumericQ]:=unflatten@@fPrivate[x,y] 

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

expr=Table[D[x^2 y+y^3,{{x,y},k}],{k,0,2}];
unflatten=Module[{f,x,y,a,b,sslot,tt},
  tt=Table[D[f[x,y],{{x,y},k}],{k,0,2}] /. 
    {Derivative[a_,b_][_][__]-> x[a,b], f[__]-> x[0,0]};
  (Evaluate[tt/.MapIndexed[#1->sslot[#2[[1]]]&, 
            Flatten[tt]]/. sslot-> Slot]&) ] 

Out[1]= {x^2 y + y^3, {2 x y, x^2 + 3 y^2}, {{2 y, 2 x}, {2 x, 6 y}}}
Out[2]= {#1, {#2, #3}, {{#4, #5}, {#5, #7}}} &

Это работает, но это не элегантно и не обобщенно.

Редактировать: Вот версия решения "безопасность работы", предоставляемая aaz:

makeUnflatten[expr_List]:=Module[{i=1},
    Function@Evaluate@ReplaceAll[
        If[ListQ[#1],Map[#0,#1],i++]&@expr,
        i_Integer-> Slot[i]]]

Работает чудо:

In[2]= makeUnflatten[expr]
Out[2]= {#1,{#2,#3},{{#4,#5},{#6,#7}}}&

Answer 1

Вам, очевидно, нужно сохранить некоторую информацию о структуре списка, потому что Flatten[{a,{b,c}}]==Flatten[{{a,b},c}].

Если ArrayQ[expr], то структура списка задается Dimensions[expr], и вы можете восстановить ее с помощью Partition. Э.Г.

expr = {{a, b, c}, {d, e, f}};
dimensions = Dimensions[expr]

  {2,3}

unflatten = Fold[Partition, #1, Reverse[Drop[dimensions, 1]]]&;
expr == unflatten @ Flatten[expr]

(Справочная страница Partition на самом деле имеет похожий пример с именем unflatten.)

---

Если expr не является массивом, вы можете попробовать это:

expr = {a, {b, c}};
indexes = Module[{i=0}, If[ListQ[#1], Map[#0, #1], ++i]& @expr]

  {1, {2, 3}}

slots = indexes /. {i_Integer -> Slot[i]}

  {#1, {#2, #3}}

unflatten = Function[Release[slots]]

  {#1, {#2, #3}} &

expr == unflatten @@ Flatten[expr]

Answer 2

Я просто хотел обновить отличные решения от aaz и Janus. Кажется, что, по крайней мере, в Mathematica 9.0.1.0 на Mac OSX, назначение (см. Решение aaz)

{i_Integer -> Slot[i]}

выходит из строя. Если, однако, мы используем

{i_Integer :> Slot[i]}

вместо этого мы добиваемся успеха. Разумеется, то же самое относится и к вызову ReplaceAll в версии Януса «Безопасность работы».

Для удобства я включил свою собственную функцию.

unflatten[ex_List, exOriginal_List] := 
  Module[
   {indexes, slots, unflat},
   indexes = 
     Module[
       {i = 0}, 
       If[ListQ[#1], Map[#0, #1], ++i] &@exOriginal
       ];
   slots = indexes /. {i_Integer :> Slot[i]};
   unflat = Function[Release[slots]];
   unflat @@ ex
   ];

(* example *)
expr = {a, {b, c}};
expr // Flatten // unflatten[#, expr] &

Может показаться, что использование исходного выражения в функции немного похоже на чит, но, как указывает aaz, нам нужна некоторая информация из исходного выражения. Хотя вам не нужно all , для того, чтобы иметь single функцию, которая может unflatten, необходимо все.

Мое приложение похоже на приложение Януса: я распараллеливаю вызовы на Simplify для тензора. Используя ParallelTable, я могу значительно улучшить производительность, но я разрушаю тензорную структуру в процессе. Это дает мне быстрый способ восстановить мой оригинальный тензор, упрощенный.

Answer 3

Я не уверен, что вы пытаетесь сделать с компиляцией. Он используется, когда вы хотите очень быстро оценить процедурные или функциональные выражения по числовым значениям, поэтому я не думаю, что это поможет здесь. Если повторяющиеся вычисления D [f, ...] мешают вашей производительности, вы можете предварительно вычислить и сохранить их как Table[d[k]=D[f,{{x,y},k}],{k,0,kk}];

Тогда просто вызовите d [k], чтобы получить k-ю производную.