Nest a list with given level specifications

Question

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]..,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} *)

Answer 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[[1]]], l, Range[l[[-1]], 1, -1]]
  ]

And here the speed test:

l = rand[1000];
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

Answer 2

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[200];

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}