# Numbering nested list according with Depth (or Level)

(This question is slightly similar with Sequentially numbering a nested list, but not exactly the same.)

# What I want

Say I have a nested list

lst = {{"X", {{"X", "X"}, {{"X", "X"}, "X"}, "X"}, "X"}, "X", "X"};


What I would like to do is to label each "X" with a number according with its Depth/Level, that is something like this

{{{2,"X"},{{{4,"X"},{4,"X"}},{{{5,"X"},{5,"X"}},{4,"X"}},{3,"X"}},{2,"X"}},{1,"X"},{1,"X"}}


# What I tried

I used a dumb way to achieve my goal.

First I label each "X" with a unique label:

labelLst = lst /. "X" :> RandomReal[]


Then get their positions:

posSet = Position[labelLst, #][[1]] & /@ Flatten[labelLst]


Then label "X"s with its Depth:

ReplacePart[lst, Function[pos, pos -> {
Length[pos], lst[[##]] & @@ pos
}] /@ posSet]


# My question

I think taking the aid of extra real-number labels is a bit cheating and inelegant, so I want to ask for a more elegant method for this. By saying elegant, I'm thinking of something pure list-manipulations. Any idea would be helpful.

Why I need this:

I'm trying to format the result of Trace for external plain-text viewer. Label numbers according with Levels eventually lead to human friendly indents.

Clear[levelIndentFunc]
levelIndentFunc[lst_] :=
Module[{labelLst, posSet},
labelLst = lst /. e_HoldForm :> RandomReal[];
posSet = Position[labelLst, #][[1]] & /@ Flatten[labelLst];
ReplacePart[lst, Function[pos, pos -> StringJoin[Flatten@{
ConstantArray["\t", Length[pos] - 1],
StringTake[
ToString[lst[[##]] & @@ pos, InputForm], {10, -2}]
}]] /@ posSet] // Flatten // Riffle[#, "\n"] & // StringJoin
]


Example:

traceRes = Trace[Reduce[x^2 == -1, x], TraceInternal -> True, TraceDepth -> 3];
Export["tracePrintTest.txt", levelIndentFunc@traceRes, "String"]


Open tracePrintTest.txt in external text viewer (here Sublime Text with Mathematica syntax highlight plugin):

Edit:

With the help of Mr.Wizard's MapIndexed function, the formatting function levelIndentFunc can be simplified to

Clear[levelIndentFunc]
levelIndentFunc[lst_] :=
MapIndexed[
{ConstantArray["\t", Length[#2] - 1], #1, "\n"} &,
lst /. e_HoldForm :> StringTake[ToString[e, InputForm], {10, -2}],
{-1}] // Flatten // StringJoin

-
Have you looked at MapIndexed? –  Mr.Wizard May 29 '13 at 6:33
@Mr.Wizard Thanks! Almost forgot it can scan different levels! –  Silvia May 29 '13 at 6:40
Glad I could jog your memory. :-) I added a simplification of your own method that I believe is equivalent. I hope it helps. –  Mr.Wizard May 29 '13 at 6:45

I think you may merely want MapIndexed. For your first example:

lst = {{"X", {{"X", "X"}, {{"X", "X"}, "X"}, "X"}, "X"}, "X", "X"};

f[s_String, pos_] := {Length@pos, s}
f[other_, _] := other

MapIndexed[f, lst, -1]

{{{2,"X"},{{{4,"X"},{4,"X"}},{{{5,"X"},{5,"X"}},{4,"X"}},{3,"X"}},{2,"X"}},{1,"X"},{1,"X"}}


Alternatively, your own formulation may be simplified:

ReplacePart[lst,
# -> {Length@#, lst ~Extract~ #} & /@ Position[lst, s_String]
]

{{{2,"X"},{{{4,"X"},{4,"X"}},{{{5,"X"},{5,"X"}},{4,"X"}},{3,"X"}},{2,"X"}},{1,"X"},{1,"X"}}


In either method the pattern s_String defines which objects are to be indexed. A simpler/faster method for all atomic objects (level {-1}) is:

MapIndexed[{Length@#2, #} &, lst, {-1}]

{{{2,"X"},{{{4,"X"},{4,"X"}},{{{5,"X"},{5,"X"}},{4,"X"}},{3,"X"}},{2,"X"}},{1,"X"},{1,"X"}}

-
Really appreciate! :D –  Silvia May 29 '13 at 6:54
@Silvia You're welcome. I made a third update to the question with a simpler form that may or may not be adaptable to your problem. (Other levelspec values could be used.) –  Mr.Wizard May 29 '13 at 6:57
Thanks. I will ToString all atomic objects before feeding to the indent function, so I think all your version will work perfectly. –  Silvia May 29 '13 at 7:05
lst = {{"X", {{"X", "X"}, {{"X", "X"}, "X"}, "X"}, "X"}, "X", "X"};

SetAttributes[f, Listable]

Map[f, lst, {1, Infinity}];

ClearAttributes[f, Listable]

%% //. {
f[x_String] :> {1, x},
f[{i_Integer, x_String}] :> {i + 1, x}}

{{{2, "X"}, {{{4, "X"}, {4, "X"}}, {{{5, "X"}, {5, "X"}}, {4,
"X"}}, {3, "X"}}, {2, "X"}}, {1, "X"}, {1, "X"}}

-
+1 Nice, I like it! –  Aky May 29 '13 at 7:30
Interesting method! –  Silvia May 29 '13 at 7:33
You can MapAll or //@ but then set first rule to {0, x}. –  BoLe May 29 '13 at 7:35
Everybody has their unique angle of view on Mathematica. Somebody like "arrows" while somebody prefer "@"s :) –  Silvia May 29 '13 at 8:31
@BoLe Off-topic, but have the GIFs in your blog been generated using Mathematica? They're quite cool! –  Aky May 29 '13 at 9:01

This obviously can't hold a candle to Mr. Wizard's solutions, and is a bit hackish as well, but anyway:

Fold[Replace[#1, "X" -> {#2, "A"}, {#2}] &, lst,
Range[Depth[lst] - 1]] /. "A" -> "X"


If there's anyway to use this approach without using the dummy symbol, I'd like to know about it. -> Edit: See Mr. Wizard's solution in the comments.

-
I always like alternatives. +1 As for eliminating the substitution, how about: Fold[Replace[#1, "X" -> {#2, "X"}, {#2}] &, lst, Reverse @ Range[Depth[lst] - 1]] ? Also, you could use a rule such as p : "X" :> {#2, p} which would be useful when not all indexed expressions are identical. –  Mr.Wizard May 29 '13 at 7:09
@Mr.Wizard Great "backward" thinking! :D –  Aky May 29 '13 at 7:13
:-) By the way, Reverse @ Range[Depth[lst] - 1] could be written Range[Depth[lst] - 1, 1, -1] as you prefer. –  Mr.Wizard May 29 '13 at 7:14
@Mr.Wizard Fortunately that's one thing I do know, lol (referring to the negative step in Range). However I still have to work out where the named pattern would come in useful in this type of problem. Could you give an example? –  Aky May 29 '13 at 7:21
Sorry, I didn't express myself well. I mean if e.g. lst = {{"A", {{"Q", "C"}, {{"J", "M"}, "B"}, "R"}, "I"}, "X", "T"}; and you want to index every string, then: Fold[Replace[#1, p_String :> {#2, p}, {#2}] &, lst, Range[Depth[lst] - 1, 1, -1]] –  Mr.Wizard May 29 '13 at 21:18