# Nest a list with given level specifications

The value of each element in list l indicates its depth in the nested list. Suppose the value can change by at most 1 between adjacent elements, how do I write the code in a more Mathematica-friendly manner?

Example:

l = {1,1,1,2,2,3,3,2,2,3,2,1,1,2,2,3,2,1}
(* output *)
(* {1,1,1,{2,2,{3,3},2,2,{3},2},1,1,{2,2,{3},2}} *)


I wanted to use ReplaceAll recursively, but it only sees the first match

l /. {a___,1,y:Except..,1,b___}:>{a,1,{y},1,b}
(* {1, 1, 1, {2, 2, 3, 3, 2, 2, 3, 2}, 1, 1, 2, 2, 3, 2, 1} *)


You can use ReplaceRepeated with a refined set of rules, e.g.:

l //. {
{a___, b_, c__, b_, e___} :> {a, b, {c}, b, e} /; c == b + 1,
{a___, b_, c_, d___, c_, b_, e___} :> {a, b, {c, d, c}, b, e} /; c == b + 1
}

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


Actually, I am not sure if the rules treat all cases correctly. Personally, I would prefer the following parsing approach: A difference of 1 means open brace; a difference of -1 means closing brace. Spreading in an appropriate amount of commata converting to strings in order to fuse it, this could look like this:

f[l_] := ToExpression[
StringJoin[
"{",
Riffle[
IntegerString /@ l,
Differences[l] /. {0 -> ",", 1 -> ",{", -1 -> "},"}
],
"}"
]
];


This is also much more efficient, since the list has to be parsed only once and we save quite a bunch of copy operations. Let's compare the two approaches: Here, a function for applying the rules above and a random list generator:

g[l_] := l //. rules;
rand[n_] := Module[{l},
l = Accumulate[RandomChoice[{0, -1, 1}, n]];
l = l - Min[l] + 1;
Join[Range[1, l[]], l, Range[l[[-1]], 1, -1]]
]


And here the speed test:

l = rand;
a = f[l]; // AbsoluteTiming // First
b = g[l]; // AbsoluteTiming // First
a == b


0.001347

191.374

True

Edit

Kuba inspired me to add some further functionality: getting rid of the requirement that jumps must be of size $\pm 1$. The approach is very similar to the one for f, but I employ memoization to avoid too many ConstantArrays. It turns out that this algorithm's performance is also rather independent of the total depth of the final list:

ClearAll[s];
SetAttributes[s, Listable];
s[i_] := s[i] = Switch[Sign[i],
1, StringJoin[",", ConstantArray["{", i]],
-1, StringJoin[ConstantArray["}", -i], ","],
0, ","
];
h[l_] := ToExpression@StringJoin["{",
Riffle[IntegerString[l], s[Differences[l]]],
"}"];

list = Join[{1}, RandomInteger[{1, 200}, 10000], {1}];
a = h[list]; // AbsoluteTiming
b = foo[list]; // AbsoluteTiming
a == b


{0.077537, Null}

{5.94479, Null}

True

• Could you explain a bit why do I need the first rule? – arax Mar 9 '18 at 3:10
• Otherwise, things like {1,2,{3},2,1} would not be processed any further. Note that I changed the ordering of the rules because {1, 2, 1, 2, 1} was turned into {1, {2, 1, 2}, 1} instead of {1, {2}, 1, {2}, 1} by the old set of rules. – Henrik Schumacher Mar 9 '18 at 6:59
foo[list_, l_: 1] := Module[{n = l}
, Replace[
SplitBy[list, n != # &]
, { {a:n..} :> a
, a_List :> foo[a, n + 1]
}
, {1}
]
]


It is ~8x slower than Henrik's f:

l = rand;

a = f[l]; // AbsoluteTiming // First
b = g[l]; // AbsoluteTiming // First
c = foo[l]; // AbsoluteTiming // First


0.000432499 (f)

0.865704

0.00340069 (foo)

but will work for arbitrary differences:

list = {1, 1, 1, 4, 4, 3, 3, 2, 2, 3, 3, 2, 2, 3, 2, 1, 1, 2, 2, 7, 2, 1}

foo[list]

 { 1, 1, 1, {{{4, 4}, 3, 3}, 2, 2, {3, 3}, 2, 2, {3}, 2}, 1, 1, {2, 2, {{{{{7}}}}}, 2}, 1}