4
$\begingroup$

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} *)
$\endgroup$
5
$\begingroup$

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

$\endgroup$
  • $\begingroup$ Could you explain a bit why do I need the first rule? $\endgroup$ – arax Mar 9 '18 at 3:10
  • 1
    $\begingroup$ 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. $\endgroup$ – Henrik Schumacher Mar 9 '18 at 6:59
3
$\begingroup$
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}
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.