KDP_book

Mathematica: Functional and procedural programming

The standard ReplaceList function attempts to transform an expression by applying a rule or list of rules in all possible ways, and returns the list of the results obtained. The following procedure is an useful enough modification of the ReplaceList function. The call ReplaceList1[x, y, z, p] returns the list that is the result of replacement in a list x of elements whose positions are determined by a list y at a nesting level p onto appropriate expressions that are defined by a list z. In addition, if a certain element should be deleted, in the z list the key word "Nothing" is coded in the appropriate position. The procedure processes the main especial situations. The following fragment represents source code of the procedure and examples of its application.

In[7]:= ReplaceList1[x_ /; ListQ[x], y_ /; IntegerListQ[y],

z_ /; ListQ[z], p_ /; IntegerQ[p]] := Module[{a = MaxLevelList[x], b, c = {}},

If[Length[y] != Length[z], Print["The 2nd and 3rd arguments have different lengths"]; $Failed, If[p > a, Print["The given nesting level is more than maximal"]; $Failed, b = Level[x, {p}];

Do[AppendTo[c, If[y[[j]] <= Length[b], b[[y[[j]]]] –> If[z[[j]] ===

"Nothing", Nothing, z[[j]]], Nothing]], {j, 1, Length[y]}]; If[c == {}, x, Replace[x, c, {p}]]]]]

In[8]:= L := {a,b, {{a,b}, {{m,n, {p, {{{}}}}}}}, c, {}, m,n,p, {{{{a*b}, g}}}} In[9]:= ReplaceList1[L, {1, 2, 5}, {Avz, Agn, Vsv}, 4]

Out[9]= {a,b,{{a,b},{{Avz,Agn,{p,{{{}}}}}}},c,{},m,n,p,{{{{a*b},Vsv}}}} In[10]:= ReplaceList1[L, {1, 2}, {{Avz, Agn}, {77, 72}}, 2]

Out[10]= {a, b, {{Avz, Agn}, {77, 72}}, c, {}, m, n, p, {{{{a*b}, g}}}}

The InsertToList procedure is based on the above procedure ReplaceList1 and Sequences [8,16] and attempts to transform a list by including of expressions in the tuples of its elements that are located on the set nesting level. The InsertToList procedure is a rather useful modification of the built-in Insert function. The procedure call InsertToList[x,y,z,h,p] returns the list that is the result of inserting into x list on a nesting level p of expressions from a list z; the positions for inserting are defined by means of the appropriate y list which defines the positions of elements of the x list on the p–th nesting level [7,10-16].

191

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

The following procedure uses a bit different algorithm that is different from the above-mentioned InsertToList procedure. The InsertToList1 procedure algorithm is based on procedures

ElemsOnLevels2 and StructNestList described in this book and in [8,16], and attempts to transform a list by including of the set of expressions before (after) of its element that is located on a set nesting level with the given position on it. The procedure call InsertToList1[x, {l, p}, {a, b, c,…}, t] returns the list – the result of inserting in a list x at a nesting level l after (t is absent) or before (t is an arbitrary expression) of its position p of expressions from the list z. The procedure handles the erroneous situations that are conditioned by invalid the 2nd argument with output of the appropriate messages, returning the initial x list that is based on standard evaluations. The following fragment represents the source code of the procedure along with typical examples of its application.

In[78]:= InsertToList1[x_ /; ListQ[x], y_ /; ListQ[y],

z_ /; ListQ[z], t___] := Module[{a = ElemsOnLevels2[x], b = StructNestList[x], c, d}, c = Select[a, #[[2 ;; 3]] == y &]; If[c != {}, If[{t} == {}, d = ToString1[c[[1]]] <> "," <>

StringTake[ToString1[Map[{ToString1[#], 1, 1} &, z]], {2, -2}], d = StringTake[ToString1[Map[{ToString1[#], 1, 1} &, z]], {2, –2}] <> "," <> ToString1[c[[1]]]]; b = ToString[ReplaceAll[b, c[[1]] –> d]];

ToExpression[ToInitNestList[ToExpression[b]]], Print["Second argument " <> ToString[y] <> " is invalid"]; x]]

In[79]:= p = {{b, a, b, {c, d, {j, {j, {t, j}, n}, u, n}, j, h}, z, y, x}}; In[80]:= InsertToList1[p, {3, 3}, {c, c, c}]

Out[80]= {{b, a, b, {c, d, {j, {j, {t, j}, n}, u, n}, j, c, c, c, h}, z, y, x}} In[81]:= InsertToList1[p, {3, 3}, {c, c, c}, gsv]

Out[81]= {{b, a, b, {c, d, {j, {j, {t, j}, n}, u, n}, c, c, c, j, h}, z, y, x}} In[82]:= InsertToList1[p, {7, 3}, {a, b, c}, gsv]

Second argument {7, 3} is invalid

Out[82]= {{b, a, b, {c, d, {j, {j, {t, j}, n}, u, n}, j, h}, z, y, x}}

192

Mathematica: Functional and procedural programming

Using the ElemsOnLevels2 procedure [16], it is possible to program the procedure allowing to expand a list by means of inserting into the given positions (nesting levels and sequential numbers on them) of the list. The call ExpandLevelsList[x, y, z] returns the result of inserting of the z list to a nesting level m relative to n–th position at this nesting level; at that, the second y argument in common case is a nested list {{m, n}, p},...,{mt, nt}, pt}}, allowing to execute inserting to positions, whose locations are defined by pairs {mj, nj} {j=1..t} (nesting levels and sequential numbers on them), whereas pt {1, –1, 0} defines insertion at the right, at the left and at situ relative to the set position. Thus, the argument y has the format {{m, n}, p}, or the kind of the above nested list {{m, n}, p},...,{mt, nt}, pt}}. At that, the structure of an initial x list is preserved.

In[2385]:= ExpandLevelsList[x_ /; ListQ[x], y_, z_ /; ListQ[z]] := Module[{a, b, c, d, h, g = If[Length[Flatten[y]] == 3, {y}, y], f, n = 1, u, p = ToString[z]}, SetAttributes[d, Listable]; f = ReplaceAll[x, {} –> Set[u, {FromCharacterCode[2]}]]; h = Flatten[f]; a = ElemsOnLevels2[f]; d[t_] := "g" <> ToString[n++]; c = Map[d[#] &, f];

h = GenRules[Map["g" <> ToString[#] &, Range[1, Length[h]]], h]; SetAttributes[b, Listable]; a = ElemsOnLevels2[c]; Do[b[t_] := If[MemberQ[a, {t, g[[j]][[1]][[1]], g[[j]][[1]][[2]]}],

If[g[[j]][[2]] == –1, p <> "," <> t, If[g[[j]][[2]] == 1, t <> "," <> p, p, 7]], t]; Set[c, Map[b[#] &, c]], {j, 1, Length[g]}]; c = ToExpression[ToString[c]];

ReplaceAll[ReplaceAll[c, Map[ToExpression[#[[1]]] –> #[[2]] &, h]], u[[1]] –> {}]]

In[2386]:= ExpandLevelsList[{a, d, {b, h, {c, d}}}, {{{1, 1}, 1}, {{2, 1}, 0}, {{3, 1}, –1}}, {{x, y, z}}]

Out[2386]= {a, {{x, y, z}}, d, {{{x, y, z}}, h, {{{x, y, z}}, c, d}}} In[2387]:= ExpandLevelsList[{a, d, {b, h, {c, d}}}, {{{1, 1}, 1},

{{2, 1}, 0}, {{3, 1}, –1}}, {{}}]

Out[2387]= {a, {{}}, d, {{{}}, h, {{{}}, c, d}}}

In[2388]:= ExpandLevelsList[{}, {{1, 1}, 0}, MultiEmptyList[7]]

Out[2388]= {{{{{{{{}}}}}}}}

The procedure is widely used by tools processing list structures.

193

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

Unlike the SelectNestElems procedure the following simple procedure, based on the ElemsOnLevels5 procedure, calling the procedure ElemsLocation[x, y] returns a list of the form {{h1, m1, n1},...,{hp, mp, np}}, whose elements {hj, mj, nj} (j=1..p) define the elements hj (which are determined by the argument y), the nesting levels and the sequential numbers on them accordingly which determine the locations of the elements hj in the list x.

In[2222]:= ElemsLocation[x_ /; ListQ[x], y_] := Module[{a = {}, c, b = Flatten[{y}]}, If[Set[c, Intersection[Flatten[x], b]] == b, 78,

Print["Elements " <> ToString1[Complement[b, c]] <> " are absent in the first argument"]]; Do[AppendTo[a, Map[If[SameQ[#[[1]], b[[j]]], #, Nothing] &, ElemsOnLevels5[x]]], {j, Length[b]}]; Flatten[a, 1]]

In[2223]:= ElemsLocation[w, {m, x^y}]

Out[2223]= {{m, 4, 1}, {m, 7, 1}, {x^y, 4, 3}}

In[2224]:= ElemsLocation[{a, b, c, d, f, d, g, g, f}, {d, f, m, n, s, v}]

Elements {m, n, s, v} are absent in the first argument Out[2224]= {{d, 1, 4}, {d, 1, 6}, {f, 1, 5}, {f, 1, 8}}

Unlike previous processing procedures of nested lists, the following procedure generates a nested list of so-called canonical form considered above based on list of elements with nesting levels ascribed to them. The procedure call CanonList[x] where x – a nested list of form {{a1, p1},…,{an, pn}} (aj – elements and pj – nesting levels on which they located) return a nested canonical list with the aj elements on pj nesting levels (j=1..n). Elements order on levels in the returned list are defined of their order at the x.

In[78]:= CanonList[x_ /; ListListQ[x]] :=

Module[{a = Max[Map[#[[2]] &, x]], b = "{", c = "}", b1 = FromCharacterCode[7], c1 = FromCharacterCode[8], d, g, t}, d = StringJoin[Map[StringRepeat[#, a] &, {b1, c1}]]; t = Map[{ToString1[#[[1]]], #[[2]]} &, x];

t = Gather[t, #1[[2]] == #2[[2]] &]; t = Flatten[Map[Reverse, t], 1]; Map[{g = Map[#[[1]] &, StringPosition[d, b1]], d = StringInsert[d, #[[1]] <> ",", g[[#[[2]]]] + 1]} &, t];

ToExpression[StringReplace[d, {b1 -> b, c1 -> c, "," <> c1 -> c}]]]

In[79]:= CanonList[{{a, 2}, {b, 4}, {c^2, 6}, {m/n, 2}, {t, 4}, {j*2, 6}}]

Out[79]= {{a, m/n, {{b, t, {{c^2, 2*j}}}}}}

194

Mathematica: Functional and procedural programming

Like the previous procedure, the following procedure also generates a nested list of so–called canonical form considered above based on list of elements with nesting levels ascribed to them and on a slightly different algorithm. The procedure call ListToCanon[x] returns a nested canonical list. Elements order on levels in the returned list are defined of their order at x. At the same time, the procedure call MaxLevelList2[x] used by the procedure (being one of the options for such tools) returns maximal nesting level of a list x. The fragment below represents source codes the above procedures with examples of their application. The codes use interesting enough methods of programming.

In[90]:= MaxLevelList2[x_ /; ListQ[x]] :=

Module[{a = x, b, n = 1}, Do[If[x == Set[b, Flatten[x]]||{n++; SameQ[a = Flatten[a, 1], b]}[[1]], Return[n], 78], Infinity]]

In[91]:= ListToCanon[x_ /; ListQ[x]] :=

Module[{a = MaxLevelList2[x], b, c, f, g}, If[a == 1, x, b = StringRepeat["{", a]; b = b <> StringRepeat["}", a];

c = Gather[ElemsOnLevels2[x], #1[[2]] == #2[[2]] &]; f[t_] := Module[{p = ""}, Do[p = p <> ToString1[t[[j]][[1]]] <> ",", {j, 1, Length[t]}];

{t[[1]][[2]], If[Length[t] == 1, StringTake[p, {1, –2}], p]}]; c = Reverse[Map[f, c]]; Do[b = StringInsert[b,

If[StringTake[Set[g, c[[j]][[2]]], {1, –2}] == "{}", "", g], {c[[j]][[1]] + 1}], {j, 1, Length[c]}]; ToExpression[b]]]

In[92]:= gs = {{a, b, {}, c, {d, {j, {a, {t}, b}, b}, a/b}, "n + p", {a, g, n}, {{v, s, v}}, d^2}}; MaxLevelList2[gs]

Out[92]= 6

In[93]:= ListToCanon[gs]

Out[93]= {{a, b, c, "n + p", d^2, {{}, d, a/b, a, g, n, {j, b, v, s, v, {a, b, {t}}}}}}

In[94]:= ListToCanon[Flatten[gs]]

Out[94]= {a, b, c, d, j, a, t, b, b, a/b, "n + p", a, g, n, v, s, v, d^2}

195

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

The following rather simple procedure is intended for the grouping of elements of a list according to their multiplicities. The procedure call GroupIdentMult[x] returns the nested list of the following format:

{{{n1}, {x1, x2,…,xa}}, {{n2}, {y1, y2,…,yb}}, …, {{nk}, {z1, z2,…,zc}}}

where {xi, yj, …, zp} are elements of a list x and {n1, n2, …, nk} – multiplicities corresponding to them {i = 1..a, j = 1..b,…,p = 1..c}. The fragment below represents the source code of the procedure along with some typical examples of its application.

In[1287]:= GroupIdentMult[x_ /; ListQ[x]] :=

Module[{a = Gather[x], b}, b = Map[{DeleteDuplicates[#][[1]], Length[#]} &, a]; b = Map[DeleteDuplicates[#] &, Map[Flatten, Gather[b, SameQ[#1[[2]], #2[[2]]] &]]];

b = Map[{{#[[1]]}, Sort[#[[2 ;; –1]]]} &, Map[Reverse,

Map[If[Length[#] > 2, Delete[Append[#, #[[2]]], 2], #] &, b]]]; b = Sort[b, #1[[1]][[1]] > #2[[1]][[1]] &]; If[Length[b] == 1, Flatten[b, 1], b]]

In[1288]:= L = {a, c, b, a, a, c, g, d, a, d, c, a, c, c, h, h, h, h, h, g, g}; In[1289]:= GroupIdentMult[L]

Out[1289]= {{{5}, {a, c, h}}, {{3}, {g}}, {{2}, {d}}, {{1}, {b}}} In[1290]:= GroupIdentMult[{a, a, a, a, a, a, a, a, a, a, a, a, a, a, a}]

Out[1290]= {{15}, {a}}

In[1291]:= GroupIdentMult[RandomInteger[2, 47]]

Out[1291]= {{{19}, {2}}, {{16}, {0}}, {{12}, {1}}}

In[1292]:= GroupIdentMult[RandomInteger[42, 77]]

Out[1292]= {{{4}, {9, 20, 24, 32, 34}}, {{3}, {0, 2, 5, 12, 17, 18}}, {{2}, {3, 4, 8, 15, 16, 19, 21, 22, 25, 31, 35, 40, 41}}, {{1}, {6, 7, 10, 11, 14, 26, 28, 29, 30, 37, 38, 39, 42}}}

In[1293]:= Sum[%[[k]][[1]]*Length[%[[k]][[2]]], {k, 1, Length[%]}][[1]]

Out[1293]= 77

In addition, elements of the returned nested list are sorted in decreasing order of multiplicities of elements groups of the initial x list. In a number of problems dealing with structures of list type the procedure is of a certain interest. That procedure is used in a number of tools of the MathToolBox package [16].

196

Mathematica: Functional and procedural programming

Note, along with above means we have programmed a lot of other means for processing lists, which are intended both for mass application and in special cases. Some are original, while others to varying degrees extend the functionality of the built-in means or extend their applicability. All these tools are included in the attached package MathToolBox [16].

3.6. Additional tools for the Mathematica

Here we will present some of the additional tools created at using of Mathematica for the programming of applications and in preparation of a series of books on computer algebra systems.

The following procedure expands the standard MemberQ function onto the nested lists, its call MemberQL[x, y] returns True if an expression y belongs to any nesting level of list x, and False otherwise. While the call with the 3rd optional z argument

– an indefinite variable – in addition through z returns the list of the ListList type, the first element of each its sublist determines a level of the x list, whereas the second determines quantity of y elements on this level provided that the main output is True, otherwise z remains indefinite. Below is represented the source code and examples of its use (see also function MemberQL2 [16]).

In[2144]:= MemberQL1[x_ /; ListQ[x], y_, z___] :=

Module[{a = MaxLevel[x], b = {}, c = {}, k = 0}, Do[AppendTo[b, Count[Level[x, {j}], y]], {j, a}]; If[Plus[Sequences[b]] >= 1, If[SymbolQ[z], Map[{k++, If[# != 0, AppendTo[c, {k, #}], 72]} &, b], 77]; z = c; True, False]]

In[2145]:= MemberQL1[{a, b, {c, d, {f, d, h, d}, s, {p, w, {n, m, d, d, r, u, d, {x, d, {d, m, n, d}, d, y}}, t}}, x, y, z}, d, agn]

Out[2145]= True In[2146]:= agn

Out[2146]= {{2, 1}, {3, 2}, {4, 3}, {5, 2}, {6, 2}}

In[2147]:= MemberQL1[Flatten[{a, b, {c, d, {f, d, h, d}, s, {p, w, {n, m, d, d, r, u, d}, t}}, x, y, z}], d, avz]

Out[2147]= True In[2148]:= avz Out[2148]= {{1, 6}}

197

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

At programming of certain procedures of access to files has been detected the expediency of creation of a procedure useful also in other appendices. Therefore, the procedure PosSubList has been created, whose call PosSubList[x, y] returns the nested list of initial and final elements for entrance into a simple x list of the tuple of elements set by a list y. The fragment represents the source code of the procedure and an example of its use.

In[7]:= PosSubList[x_ /; ListQ[x], y_ /; ListQ[y]] :=

Module[{d, a = ToString1[x], b = ToString1[y], c = FromCharacterCode[16]}, d = StringTake[b, {2, –2}];

If[! StringFreeQ[a, d], b = StringReplace[a, d –> c <> "," <> StringTake[ToString1[y[[2 ;; –1]]], {2, –2}]]; Map[{#, # + Length[y] – 1} &,

Flatten[Position[ToExpression[b], ToExpression[c]]]], {}]]

In[8]:= PosSubList[{a, a, b, a, a, a, b, a, x, a, b, a, y, z, a, b, a}, {a, b, a}]

Out[8]= {{2, 4}, {6, 8}, {10, 12}, {15, 17}}

The above approach once again illustrates incentive motives and prerequisites for programming of the user tools expanding the Mathematica software. Many of tools of our MathToolBox package appeared exactly in this way. So, the both procedures Gather1 and Gather2 a little extend the built-in function Gather, being an useful in a number of applications [8,12-16].

The following group of means serves for sorting of lists of various type. Among them can be noted such as SortNL, SortLS, SortNL1, SortLpos, SortNestList. For example, the procedure call

SortNestList[x,p,y] returns the sorting result of a nested numeric or symbolic list x by p–th element of its sub-lists according to the sorting functions Less, Greater for numeric lists, and SymbolLess, SymbolGreater for symbolic lists. In both cases a nested list with the nesting level <3 as actual x argument is supposed, otherwise an initial x list is returned. In addition, in a case of symbolic lists the comparison of elements is carried out on the basis of their character codes. The following fragment represents source code of the procedure with a typical example of its application.

In[76]:= SortNestList[x_ /; NestListQ[x], p_ /; PosIntQ[p], y_] := Module[{a = DeleteDuplicates[Map[Length, x]], b},

198

Mathematica: Functional and procedural programming

b = If[AllTrue[Map[ListNumericQ, x], TrueQ] && MemberQ[{Greater, Less}, y], y,

If[AllTrue[Map[ListSymbolQ, x], TrueQ] && MemberQ[{SymbolGreater, SymbolLess}, y], y],

Return[Defer[SortNestList[x, p, y]]]]; If[Min[a] <= p <= Max[a], Sort[x, b[#1[[p]], #2[[p]]] &], Defer[SortNestList[x, p, y]]]]

In[77]:= SortNestList[{{42, 47, 72}, {77, 72, 52}, {30, 23}}, 2, Less]

Out[77]= {{30, 23}, {42, 47, 72}, {77, 72, 52}}

Sorting of a nested list at the nesting levels composing it is of quite certain interest. In this regard the following procedure can be a rather useful tool. The call SortOnLevel[x, m] returns the sorting result of a list x at its nesting level m [16]. Whereas the SortOnLevels procedure is a rather natural generalization of the previous procedure. The call SortOnLevels[x,m,sf] where optional sf argument – a sorting pure function analogously to the previous procedure returns the sorting result of x list at its nesting levels m. Furthermore, as an argument m can be used a single level, the levels list or "All" word which determines all nesting levels of the x list which are subject to sorting. If all m levels are absent then the call returns $Failed with printing of the appropriate message, otherwise the call prints the message concerning only levels absent in the x list. It must be kept in mind, that by default the sorting is made in symbolic mode, i.e. all elements of the sorted x list before sorting by means of the built-in Sort function are presented in the string format. While the call SortOnLevels[x, m, sf] returns the sorting result of a list x at its nesting levels m depending on a sorting pure sf function that is the optional argument. The following fragment represents source code of the procedure and examples of its application.

In[75]:= SortOnLevels[x_ /; ListQ[x], m_ /; IntegerQ[m] ||

IntegerListQ[m] || m === All, sf___] := Module[{a, b, c = ReplaceAll[x, {} –> {Null}], d, h, t, g, s}, a = LevelsOfList[c]; d = Sort[DeleteDuplicates[a]]; If[m === All || SameQ[d, Set[h, Sort[DeleteDuplicates[Flatten[{m}]]]]], t = d, If[Set[g, Intersection[h, d]] == {},

199

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

Print["Levels " <> ToString[h] <> " is empty"]; Return[$Failed], t = g; s = Select[h, ! MemberQ[d, #] &]; If[s == {}, Null, Print["Levels " <> ToString[s] <>

" are absent in the list; " <> "nesting levels must belong to " <> ToString[Range[1, Max[d]]]]]]]; Map[Set[c, SortOnLevel[c, #, sf]] &, t]; ReplaceAll[c, Null –> Nothing]]

In[76]:= SortOnLevels[{b, t, "c", {{3, 2, 1, {g, s*t, a}, k, 0}, 2, 3, 1}, 1, 2, {{m, n, f}}, {{2, 3, 6, {{{g, f, d, s, m}}}}}}, 7, 8]

Levels {7} are absent in the list;

nesting levels must belong to {1, 2, 3, 4, 5, 6} Out[76]= $Failed

In[77]:= SortOnLevels[{b, t, "c", {{3, 2, 1, {g, s*t, a}, k, 0}, 2, 3, 1}, 1, 2, {{m, n, f}}, {{2, 3, 6, {{{g, f, d, s, m}}}}}}, 6]

Out[77]= {b, t, "c", {{3, 2, 1, {g, s*t, a}, k, 0}, 2, 3, 1}, 1, 2, {{m, n, f}}, {{2, 3, 6, {{{d, f, g, m, s}}}}}}

The procedure call SortOnLevel[x, m] returns the sorting result of a list x at its nesting level m. If the m level is absent, the procedure call returns $Failed, printing the appropriate message. It must be kept in mind that by default the sorting is made in the symbolic format, i.e. all elements of the sorted x list will be represented in the string format. Whereas the procedure call SortOnLevel[x, m, Sf] returns the sorting result of the x list at its nesting level m depending on the sorting pure Sf function that is the optional argument. In addition, the cross-cutting sorting at the set nesting level is made. The fragment below represents source code of the procedure and an example of its application.

In[10]:= SortOnLevel[x_ /; ListQ[x], m_ /; IntegerQ[m], Sf___] := Module[{a, b = ReplaceAll[x, {} –> {Null}], c, d, f, g, h = {}, n = 1, p, v}, a = LevelsOfList[b]; d = DeleteDuplicates[a];

If[! MemberQ[d, m], Print["Level " <> ToString[m] <> " is absent in the list; " <> "nesting level must belong to " <> ToString[Range[1, Max[d]]]]; $Failed, f[t_] := "(" <> ToString1[t] <> ")" <> "_" <> ToString1[a[[n++]]]; SetAttributes[f, Listable]; c = Map[f, b];

g[t_] := If[SuffPref[t, "_" <> ToString[m], 2], AppendTo[h, t], Null]; SetAttributes[g, Listable]; Map[g, c];

200