KDP_book

Mathematica: Functional and procedural programming

p = Sort[Map[StringTake[#, {1, Flatten[StringPosition[#, "_"]] [[–1]] – 1}] &, h], Sf]; n = 1; v[t_] := If[ToExpression[StringTake[t, {Flatten[StringPosition[t,

"_"]][[–1]] + 1, –1}]] == m, p[[n++]], StringTake[t, {1, Flatten[StringPosition[t, "_"]][[–1]] – 1}]];

SetAttributes[v, Listable]; c = ToExpression[Map[v, c]]; ReplaceAll[c, Null –> Nothing]]]

In[11]:= SortOnLevel[{p, b, a, u, c, {{{n, {h, f, c}, m}}}, 3, 2, 1}, 1]

Out[11]= {1, 2, 3, a, b, {{{n, {h, f, c}, m}}}, c, p, u}

Along with the above and other similar means [8-16,22], a procedure whose call ElemsOnLevel[x] returns the format of a list x with its internal structure preserved is of great interest but instead of its elements there are 3–element lists, where as their 1st element – element of the x list, the 2nd element – its position in the Flatten[x] list and the third element – its nesting level in the x list (see fragment below).

In[7]:= ElemsOnLevel[x_ /; ListQ[x]] := Module[{d, f, f1, f2, n = 1, p, z = "\[InvisibleComma]"}, f[t_] := ToString1[t] <> z <> ToString[n++];

f1[t_] := ToString[t] <> z <> ToString[p[[n++]]]; f2[t_] := ToExpression[StringSplit[t, z]]; Map[SetAttributes[#, Listable] &, {f, f1, f2}];

p = LevelsOfList[x]; d = Map[f,x]; n=1; d = Map[f1,d]; Map[f2,d]] In[8]:= ElemsOnLevel[{{{{a, b}}}, {c, d, m, {{n, d}}}, s, g, {a, k}}]

Out[8]= {{{{{a, 1, 4}, {b, 2, 4}}}}, {{c, 3, 2}, {d, 4, 2}, {m, 5, 2},

{{{n, 6, 4}, {d, 7, 4}}}}, {s, 8, 1}, {g, 9, 1}, {{a, 10, 2}, {k, 11, 2}}}

The procedure is quite useful in solving of the number the problems of processing nested lists and in combination with the above–mentioned tools it extends the functional component of Mathematica in this direction. In particular, the procedure is useful in solving the task of testing the continuous distribution of elements at a set nesting level of a list. The problem is solved by means of SolidLevelQ procedure, represented below.

In[432]:= SolidLevelQ[x_ /; ListQ[x], n_ /; IntegerQ[n], y___] := Module[{a = ElemsOnLevel[x], b, c, p, t = 0},

If[MemberQ[Range[1, c = MaxLevel[x]], n], b = Partition[Flatten[a], 3]; b = Select[b, #[[3]] == n &];

201

V.Z. Aladjev, M.L. Shishakov, V.A. Vaganov

If[b == {}, Goto[j], b = Map[#[[2]] &, b]; a = Range[b[[1]], b[[-1]]]; Do[If[b[[p]] + 1 == b[[p + 1]], Nothing, t++], {p, Length[b] – 1}];

If[a == b, p = True, p = False]; If[p === False && {y} != {} && ! HowAct[y], y = t + 1, 77]; p],

Label[j]; Print["The second argument should be in range " <> ToString[{1, c}]]; $Failed]]

In[433]:= SolidLevelQ[{3, 2, 1, {{g, s + t, a}, k, 0, 2, 3, 1}, 1, 2, {a, b}, m, n, {c, {d}, t}, g, {d}, f}, 1]

Out[433]= False

In[434]:= SolidLevelQ[{3, 2, 1, {{g, s + t, a}, k, 0, 2, 3, 1}, 1, 2, {a, b}, m, n, {c, {d}, t}, g, {d}, f}, 1, g]

Out[434]= False In[435]:= g Out[435]= 5

In[436]:= SolidLevelQ[{5, 6, 7, 8, {9, 11}, 10, 1}, 3]

"The second argument should be in diapason {1, 2}" Out[436]= $Failed

In[437]:= SolidLevelQ[{5, 6, 7, 8, {9, {c}, 11}, 10, 1}, 2, svg]

Out[437]= False

In[438]:= svg

Out[438]= 2

In[439]:= SolidLevelQ[{5, 6, 7, 8, 9, 11, 10, 1}, 2]

"The second argument should be in diapason {1, 1}" Out[439]= $Failed

In[440]:= SolidLevelQ[{5, 6, 7, 8, 9, 11, 10, 1}, 1]

Out[440]= True

Calling the SolidLevelQ[x, n] procedure returns True if the elements of a level n of a list x are arranged sequentially, i.e. not separated by other nesting levels, and False otherwise. Whereas through optional 3rd argument y – an indefinite variable – the call SolidLevelQ[x,n,y] returns the number of solid segments of the elements of the n–th nesting level if the main result is False. The procedure processes the erroneous situation in a case of invalid nesting level n with returning value $Failed and printing of the appropriate message. The previous fragment represents source code of procedure and the typical examples of its application.

The following procedure should be preceded by a procedure that allows to do that a list of an arbitrary structure and nesting

202

Mathematica: Functional and procedural programming

whose all elements are of the form {h}, is result in the list of the same structure, but with elements of the form h. The procedure call IntSimplList[x] returns the result of the above restructuring of a list x of an arbitrary structure and nesting.

In[7]:= IntSimplList[x_ /; ListQ[x]] := Module[{a = ToString1[x], b = {}, c = {}, d, k, j, p = ""}, d = StringLength[a]; Do[If[StringTake[a, {j}] == "{" && StringTake[a, {j + 1}] != "{", AppendTo[b, j], 77], {j, d – 1}];

For[k = 1, k <= Length[b], k++, For[j = b[[k]], j <= Infinity, j++, p = p <> StringTake[a, {j}]; If[SyntaxQ[p], AppendTo[c, j];

Break[], Continue[]]; p = ""]]; ToExpression[StringReplacePart[a, "", Map[{#, #} &, Join[b, c]]]]]

In[8]:= sv := {{{p}, {F[b]}, {a + b}}, {u^3}, {c}, {{{{n/m}, {{"h"}, {c^2}, {g[f]}}, {n^2 + t}}}}, {{y}, {"x"}}}

In[9]:= IntSimplList[sv]

Out[9]= {{p, F[b], a + b}, u^3, c, {{{n/m, {"h", c^2, g[f]}, n^2 + t}}}, {y, "x"}}

By substantially using now the previous procedure, we can more easily program a procedure that applies a certain symbol to the desired element of the nested list at a set nesting level.

In[7]:= SymbolToElemOnLevel[F_ /; SymbolQ[F], x_ /; ListQ[x], n_Integer, m_Integer] := Module[{a = ToString1[ElemsOnLevel[x]], b, c, d, g, t, u, s, z},

s[t_] := If[IntegerQ[t], ToString[t], t]; SetAttributes[s, Listable]; z[t_] := If[StringQ[t] && IntegerQ[ToExpression[t]], ToExpression[t], If[Quiet[Check[Part[t, 0] === F, False]] && StringQ[Part[t, 1]] && IntegerQ[Set[u, ToExpression[Part[t, 1]]]], F[u], t]]; d = Map[s, x]; SetAttributes[z, Listable]; a = ToString1[ElemsOnLevel[d]];

If[n <= MaxLevel[x] – 1 && n > 0, If[Length[Level[x, {n}]] >= m, b = ReduceAdjacentStr[ReduceAdjacentStr[a, "{", 1], "}", 1]; b = ToExpression["{" <> b <> "}"]; g[t_] := If[IntegerQ[t], Nothing, t]; SetAttributes[g, Listable];

b = Quiet[Check[Select[b, #[[3]] == n &][[m]][[1]], Return[{Print["No element with number " <> ToString[m] <> " at level " <> ToString[n]]; $Failed}[[1]]]]]; c = ToString1[b]; b = F @@ {b}; b = ToString1[b];

203

V.Z. Aladjev, M.L. Shishakov, V.A. Vaganov

t = ToExpression[StringReplace[a, c –> b]]; t = IntSimplList[Map[g, t]]; Map[z, t], Print["No element with number " <> ToString[m] <> " at level " <> ToString[n]]; $Failed],

Print["No level with number " <> ToString[n]]; $Failed]] In[8]:= t := {{p, b, x^2 + y^2, c + b, 7.7, 78, m/n}, u, c^2,

{{{n, {"h", f, {m, n, p}, c}, n + p^2}}}, {y, "x"}} In[9]:= SymbolToElemOnLevel[F, t, 2, 3]

Out[9]= {{p, b, F[x^2 + y^2], b + c, 7.7, 78, m/n}, u, c^2,

{{{n, {"h", f, {m, n, p}, c}, n + p^2}}}, {y, "x"}} In[10]:= SymbolToElemOnLevel[F, t, 4, 2]

Out[10]= {{p, b, x^2 + y^2, b + c, 7.7, 78, m/n}, u, c^2,

{{{n, {"h", f, {m, n, p}, c}, F[n + p^2]}}}, {y, "x"}}}

In[11]:= SymbolToElemOnLevel[F, t, 2, 12] "No element with number 12 at level 2"

Out[11]= $Failed

In[12]:= SymbolToElemOnLevel[F, t, 7, 6] "No level with number 7"

Out[12]= $Failed

The procedure call SymbolToElemOnLevel[F,x,n,m] returns the result of applying of a symbol F to an element with number m of nesting level n of the nested list x. The procedure handles the erroneous situations due to using of incorrect nesting levels and elements numbers at nesting levels with return $Failed and printing of appropriate message. Meantime, at a nesting level n of form ...{a, b,..., {c},..., d}... only {a, b,..., d} elements other than lists are considered as elements, and elements of more higher nesting level p > n, such as {c}, are ignored. The above fragment represents the source code of the procedure along with typical examples of its application.

The following procedure is a rather useful generalization of the previous procedure. The call SymbolToElemOnLevel1[F,x,n] returns the result of applying of a symbol F to elements of the nested list x that are defined by a nested list n, coded in the form of integer nested list {{l1, {p1 ,..., pn}}, …, {lt, {q1, ..., qm}}}. In this list for elements in form {l1, {p1 ,..., pn}} as the first element l1 is a nesting level whereas the 2nd element-list are numbers elements on the set nesting level. In addition, elements of the Integer type

204

Mathematica: Functional and procedural programming

in the list x are coded in the string format. At the same time, the procedure handles the erroneous situations which are caused by the using of incorrect nesting levels and elements numbers at nesting levels with return $Failed and printing of appropriate messages. The fragment below represents the source code of the SymbolToElemOnLevel1 procedure with examples of its use.

In[5]:= SymbolToElemOnLevel1[F_ /; SymbolQ[F],

x_ /; ListQ[x], n_ /; ListQ[n]] := Module[{a = x, b, d, m = If[IntegerQ[n[[1]]], {n}, n], t = {}, h = {}, s = {}, v = {}, u, k, j}, d = Gather[LevelsOfList[x]]; d = Map[{#[[1]], Length[#]} &, d];

Map[{s = Flatten[Append[s, d[[#]][[1]]]], v = Flatten[Append[v, d[[#]][[2]]]]} &, Range[1, Length[d]]]; Map[{AppendTo[t, m[[#]][[1]]], AppendTo[h, Max[m[[#]][[2]]]]} &,

Range[1, Length[m]]]; If[Set[u, Complement[t, s]] != {}, Return[{Print["Levels " <> ToString[u] <> " are absent"]; $Failed}[[1]]],

For[k = 1, k <= Length[d], k++, For[j = 1, j <= Length[m], j++, If[d[[k]][[1]] == m[[j]][[1]] && d[[k]][[2]] < Max[m[[j]][[2]]], Return[{Print["The element numbers greater than the number of elements on level " <> ToString[d[[k]][[1]]]]; $Failed}[[1]]], 7]]];

Do[Do[a = SymbolToElemOnLevel[F, a, k[[1]], j], {j, k[[2]]}], {k, m}]; a]]

In[6]:= h := {{a, b, c}, c, d, {{{g, v, {m, n, p}, f}}}, {x, y, z}}

In[7]:= SymbolToElemOnLevel1[F, h, {{2, {1, 2, 3, 6}}, {4, {1, 2}}, {5, {1, 2, 3}, {4, {1, 2}}}}]

Out[7]= {{F[a],F[b],F[c]}, F[c], d, {{{F[g],F[v], {F[m],F[n], F[p]}, f}}}, {x, y, F[z]}}

In[8]:= SymbolToElemOnLevel1[F, h, {{2, {1, 4, 6}}, {5, {1, 2, 3}}}]

Out[8]= {{F[a], b, c}, c, d, {{{g, v, {F[m], F[n], F[p]}, f}}}, {F[x], y, F[z]}}

In[9]:= SymbolToElemOnLevel1[F, h, {{2, {1, 4,6, 7}}, {6, {1, 2,3}}, {7, {1, 2, 3}}}]

"Levels {6, 7} are absent" Out[9]= $Failed

In[10]:= SymbolToElemOnLevel1[F, h, {{2, {1, 6, 7}}, {5, {1, 2}}}] "The element numbers greater than the number of elements on level 2"

Out[10]= $Failed

205

V.Z. Aladjev, M.L. Shishakov, V.A. Vaganov

Finally, the simple SymbolToListAll procedure returns the result of applying of the given S symbol to each element at all nesting levels of a list x. The following fragment represents the source code of the procedure with an example of its application.

In[147]:= SymbolToListAll[x_ /; ListQ[x], S_ /; SymbolQ[S]] := Module[{a}, SetAttributes[a, Listable]; a[t_] := S @@ {x}; Map[a, x]]

In[148]:= t := {{a, b}, c, m + n, 77, {{{m, {{c + d, n/p}}}}}, {h, "g"}} In[149]:= SymbolToListAll[t, F]

Out[149]= {{F[a], F[b]}, F[c], F[m + n], F[77], {{{F[m], {{F[c + d], F[n/p]}}}}}, {F[h], F["g"]}}

The following procedure is a useful version of the previous procedure. The call SymbolToNestList[x, y] returns the result of applying of symbols to elements of a list x that are defined by a sequence y in the form {f1, l1 , p1}, …, {ft, lt, pt} where {f1,…, ft} is symbols that should be applied, the elements {l1, …, lt} define nesting levels whereas the elements {p1, …, pt} define elements numbers on the corresponding nesting levels. In addition, the procedure handles the erroneous situations which are caused by the using of incorrect nesting levels or elements numbers at nesting levels with printing of appropriate messages.

In[378]:= SymbolToNestList[x_ /; ListQ[x], y__] :=

Module[{a = ElemsOnLevels2[x], b, c, d, g, t, f, v, j = FromCharacterCode[7]}, b[t_] := ToString1[t]; f[t_] := If[IntegerQ[t], Nothing, t]; v[t_] := j <> t <> j; Map[SetAttributes[#, Listable] &, {b, f, v}];

c = StructNestList[Map[b, x]]; d = ElemsOnLevels2[x]; t = Complement[Map[#[[2 ;; 3]] &, {y}], Map[#[[2 ;; 3]] &, d]]; If[t != {}, Print["Elements " <> "with conditions <level/position> " <> ToString[t] <> " are invalid"]; t = Select[{y}, ! MemberQ[t, #[[2 ;; 3]]] &], t = {y}];

d = Select[d, MemberQ[Map[#[[2 ;; 3]] &, t], #[[2 ;; 3]]] &]; g = MatchLists[d, t, 2 ;; 3]; g = Map[Flatten[{g[[#]][[1]] @@ {d[[#]][[1]]}, d[[#]][[2 ;; 3]]}] &,

Range[1, Length[g]]]; d = Map[Flatten[{ToString1[#[[1]]], #[[2 ;; 3]]}] &, d]; g = Map[Flatten[{ToString1[#[[1]]], #[[2 ;; 3]]}] &, g];

c = ReplaceAll[c, Map[d[[#]] –> g[[#]] &, Range[1, Length[d]]]];

206

Mathematica: Functional and procedural programming

c = ToString[Map[v, Map[f, c]]]; ToExpression[StringReplace[c, {"{" <> j –> "", j <> "}" –> ""}]]]]]

In[379]:= p = {{a, b, {d, z, {m, {1, 2, 3, {{{v, g, s, d, s, h}}}, 4, 5}, n, t}, {{u}}, c, {x, y, h, w}}}};

In[380]:= SymbolToNestList[p, {V, 3, 2}, {G, 5, 1}, {S, 8, 1},

{Art, 8, 6}, {Kr, 2, 2}, {T, 4, 1}, {T, 6, 5}, {T, 4, 7}, {J, 1, 2}]

Elements with conditions {level, position} {{1, 2}, {6, 5}} are invalid Out[380]= {{a, Kr[b], {d, V[z], {T[m], {G[1], 2, 3, {{{S[v], g, s, d, s,

Art[h]}}}, 4, 5}, n, t}, {{u}}, c, {x, y, h, T[w]}}}}

The SymbolToNestList1 procedure is analogue of the above procedure with ignoring of invalid values of y argument.

In[390]:= SymbolToNestList1[x_ /; ListQ[x], y__] :=

Module[{a = ElemsOnLevels2[x], b = StructNestList[x], c = {}, d, g = {}, j, s, t = DeleteDuplicates[{y}, #1[[2 ;; 3]] == #2[[2 ;; 3]] &]}, d = Map[#[[2 ;; 3]] &, t]; s = Length[t]; For[j = 1, j <= Length[a], j++, If[MemberQ[d, a[[j]][[2 ;; 3]]], AppendTo[c, a[[j]]], AppendTo[g, a[[j]]]]]; d = MatchLists[c, t, 2 ;; 3];

Quiet[d = Map[c[[#]] –> d[[#]][[1]] @@ {c[[#]][[1]]} &, Range[1, s]]; g = Join[d, Map[# –> #[[1]] &, g]]; ReplaceAll[b, g]]]

The above procedures SolidLevelQ, SymbolToElemOnLevel,

LevelsOfList, IntSimplList, SymbolToListAll, SymbolToNestList, SymbolToElemOnLevel1 and SymbolToNestList1 are of a certain interest in programming problems related to the nested lists and as examples with use of the sapiential methods at programming of the problems of a similar type [6-15].

We will present couple more of tools using useful methods of programming of problems linked with processing of nested lists. Particularly, calling the function ToInitNestList[x] returns an initial nested y list from that a list x was obtained as a result x=StructNestList[y] whereas the call ToInitNestList[x, j] where j is an arbitrary expression returns an initial nested y list from which a list x was obtained as a result ElemsOnLevels1[y]. Its source code is represented below.

In[420]:= ToInitNestList[x_ /; ListQ[x], y___] := ReplaceAll[x, Map[# –> #[[1]] &, Partition[Flatten[x], If[{y} != {}, 2, 3]]]]

207

V.Z. Aladjev, M.L. Shishakov, V.A. Vaganov

Together with the above two procedures, the function is of very specific interest in handling nested lists [8-16].

Calling the procedure DeleteDuplicatesNest[x, n, g] returns the result of deleting of all duplicates from the set nesting level n of a list x. As a value n can be an integer, an integer list or the word All, that provides deletion at a concrete nesting level, at their set or all levels accordingly. In addition, the call can use the 3rd optional g argument that is a test to pairs of elements to determine whether they should be considered duplicates.

In[78]:= DeleteDuplicatesNest[x_ /; ListQ[x], n_ /; PosIntQ[n]|| IntegerListQ[n] || n === All, g___] := Module[{f, h}, f[t_, p_] := Module[{a = ElemsOnLevels2[t], b = StructNestList[t], c, d}, c = Map[If[#[[2]] == p, #, Nothing] &, a]; d = DeleteDuplicates[c, If[{g} != {}, g[#1[[1]]] == g[#2[[1]]] &,

#1[[1]] == #2[[1]] &]]; d = Complement[c, d]; ToInitNestList[ReplaceAll[b, Map[# –> Nothing &, d]]]]; If[PosIntQ[n], f[x, n],

If[IntegerListQ[n], h = x; Do[h = f[h, j], {j, n}]; h, h = x; Do[h = f[h, j], {j, ListLevels[x]}]; h]]]

In[79]:= p = {{b, m, 42, b, {d, c, c, {m, m, {t, t, {{{v, s, 9, s, d, {m, c}, s, h, s, d, 9, 9, v}}}, 4, 5, 4}, t, n, t}, {x, y, y, x}}}};

In[80]:= DeleteDuplicatesNest[p, All]

Out[80]= {{b, m, 42, {d, c, {m, {t, {{{v, s, 9, d, {m, c}, h}}}, 4, 5}, t, n}, {x, y}}}}

Calling the procedure ReplaceCondList[x, y] returns the result of replacement of elements of a list x, that are at nesting levels with set positions on them and that satisfy set conditions that are defined by sequence y of the lists {s1, f1, l1, p1}, ..., {st, ft, lt, pt}, where list {sj, fj, lj, pj} (j = 1..t) defines replacement of an element ej that is located at nesting level lj with position pj on it with condition fj[ej]=True onto a sj element. If substitution is not possible because of absence of nesting level lj or/and position pj then it is ignored without any message.

In[90]:= ReplaceCondList[x_ /; ListQ[x], y__] :=

Module[{a = ElemsOnLevels2[x], b = StructNestList[x], d, k, j, c = DeleteDuplicates[{y}, #1[[3 ;; 4]] == #2[[3 ;; 4]] &], h = {}}, c = Map[If[MemberQ[Map[#[[2 ;; 3]] &, a], #[[3 ;; 4]]], #,

208

Mathematica: Functional and procedural programming

Nothing] &, c]; d = Map[If[MemberQ[Map[#[[3 ;; 4]] &, c], #[[2 ;; 3]]], #, Nothing] &, a]; a = Length[d]; For[k = 1, k <= a, k++, For[j = 1, j <= a, j++,

If[c[[k]][[3 ;; 4]] == d[[j]][[2 ;; 3]], AppendTo[h, c[[j]]], 78]]]; h = Map[If[h[[#]][[2]] @@ {d[[#]][[1]]}, d[[#]] –> Flatten[{h[[#]][[1]], h[[#]][[3 ;; 4]]}], Nothing] &,

Range[1, a]]; ToInitNestList[ReplaceAll[b, h]]]

Calling the procedure ExchangeLevels2[x, k, j] returns the result of elements exchanging of nesting levels k and j of nested list x. The source code of the procedure is represented below.

In[1942]:= ExchangeLevels2[x_/; NestListQ1[x], n_/; PosIntQ[n], m_ /; PosIntQ[m]] := Module[{a, b, c, d, p, g, s, t}, t = ReplaceAll[x, {} –> {s}]; a = ElemsOnLevels2[t]; b = StructNestList[t]; If[! MemberQ3[Map[#[[2]] &, a], {n, m}],

"Second or/and third arguments are invalid", d = Select[a, #[[2]] == n &]; p = Select[a, #[[2]] == m &]; c = {d[[1]], StringTake[ToString1[p], {2, –2}]}; g = {p[[1]], StringTake[ToString1[d], {2, –2}]};

c = ReplaceAll[b, Flatten[{Map[# –> Nothing &, d[[2 ;; –1]]],

Map[# –> Nothing &, p[[2 ;; –1]]], c[[1]] –> c[[2]], g[[1]] –> g[[2]]}]]; c = ToInitNestList[ToExpression[ToString[c]]];

c = ReplaceRepeated[c, {} –> Nothing];

ReplaceAll[c, s –> Nothing]]]

In[1943]:= p = {{a, b, c, {c, d, t, {m, z, g, u, n}, m, h}, x, y, z, v}}; In[1944]:= ExchangeLevels2[p, 2, 4]

Out[1944]= {{m, z, g, u, n, {c, d, t, {a, b, c, x, y, z, v}, m, h}}}

Furthermore, in addition to the previous procedure, calling the procedure ExchangeElemsOnLevels[x, y] returns the result of the interchange of elements located at the specified nesting levels of a list x, taking into account their position on them. In addition, the second argument y – the list of ListList type – has the form {{{l1, p1}, {l2, p2}},…, {{lt, pt}, {ln, pn}}}, where lists pairs of the form {{lt, pt}, {ln, pn}} define nesting levels {lt, ln} and the positions {pt, pn} of elements on them that are subject to mutual exchange. The ExchangeElemsOnLevels procedure handles the

209

V.Z. Aladjev, M.L. Shishakov, V.A. Vaganov

main erroneous situations conditioned by the errors in the 2nd y argument with return or printing of the appropriate messages. The fragment below represents the source code (that contains a number of useful programming methods) of the procedure with a number of examples of its typical application.

In[42]:= ExchangeElemsOnLevels[x_ /; ListQ[x],

y_ /; ListListQ[y]] := Module[{a = ElemsOnLevels2[x], b = StructNestList[x], c, d = {}, j, h = If[Length[Flatten[y]] == 4, {y}, y], g}, c = Map[If[MemberQ3[Map[#[[2 ;; 3]] &, a], #], #, Nothing] &, h];

If[c == {}, Return["The second argument is invalid"],

If[h != c, Print["Elements " <> ToString[Complement[h, c]] <> " in the second argument are invalid"], 78]; g[t_] := {t[[1]] –> Flatten[{t[[2]][[1]], t[[1]][[2 ;; 3]]}], t[[2]] –> Flatten[{t[[1]][[1]], t[[2]][[2 ;; 3]]}]};

Do[AppendTo[d, {Select[a, #[[2 ;; 3]] == c[[j]][[1]] &][[1]], Select[a, #[[2 ;; 3]] == c[[j]][[2]] &][[1]]}], {j, 1, Length[c]}]; d = Flatten[Map[g, d], 1]; ToInitNestList[ReplaceAll[b, d]]]]

In[43]:= p = {{a, b, {c, d, {m, g, {m, {{"t"}}, n}, u, n}, m, h}, x, y, z}}; In[44]:= ExchangeElemsOnLevels[p, {{{3, 4}, {4, 4}}, {{2, 2}, {3, 2}}}]

Out[44]= {{a, d, {c, b, {m, g, {m, {{"t"}}, n}, u, h}, m, n}, x, y, z}} In[45]:= ExchangeElemsOnLevels[p, {{7, 1}, {2, 5}}]

Out[45]= {{a, b, {c, d, {m, g, {m, {{z}}, n}, u, n}, m, h}, x, y, "t"}}

Calling the procedure SortOnLevels2[x, p, f] returns the default sort result of a nesting level p of a list x, if optional f argument is missing, or according to the set ordering function f.

In[9]:= SortOnLevels2[x_ /; ListQ[x], n_ /; PosIntQ[n], Sf___] := Module[{a = ElemsOnLevels2[x], b = StructNestList[x], c, d}, c = Select[a, #[[2]] == n &]; d = If[{Sf} != {}, Sort[c, Sf],

Sort[c, Order[#1[[1]], #2[[1]]] &]]; ToInitNestList[ReplaceAll[b, Map[c[[#]] –> d[[#]] &, Range[1, Length[c]]]]]]

In[10]:= SortOnLevels2[{a, b, {c, d, {j, h, d, e, r, t}}}, 3]

Out[10]= {a, b, {c, d, {d, e, h, j, r, t}}}

210