# Build the following symmetric array

My mind is a bit cloudy and I can't quite pinpoint the pattern here that will allow me to write an elegant piece of code to build the following symmetric matrix of for a given size n:

For example, if n=5:

{{0,    f[1],  f[6], f[9], f[5] },
{f[1], 0,     f[2], f[7], f[10]},
{f[6], f[2],  0,    f[3], f[8] },
{f[9], f[7],  f[3], 0,    f[4] },
{f[5], f[10], f[8], f[4], 0    }}


And if n=9,

{{0,     f[1],  f[10], f[19], f[28], f[33], f[25], f[17], f[9] },
{f[1],  0,     f[2],  f[11], f[20], f[29], f[34], f[26], f[18]},
{f[10], f[2],  0,     f[3],  f[12], f[21], f[30], f[35], f[27]},
{f[19], f[11], f[3],  0,     f[4],  f[13], f[22], f[31], f[36]},
{f[28], f[20], f[12], f[4],  0,     f[5],  f[14], f[23], f[32]},
{f[33], f[29], f[21], f[13], f[5],  0,     f[6],  f[15], f[24]},
{f[25], f[34], f[30], f[22], f[14], f[6],  0,     f[7],  f[16]},
{f[17], f[26], f[35], f[31], f[23], f[15], f[7],  0,     f[8] },
{f[9],  f[18], f[27], f[36], f[32], f[24], f[16], f[8],  0    }}


Do you see the pattern? The main diagonal is zero. Then the sub-leading diagonal gets filled in order, followed by the upper-right corner. Then the sub-sub-leading diagonal gets filled, followed by the sub-leading upper-right diagonal, and so on...

Here is my modest attempt:

qdMat[n_Integer?Positive] := Module[{id, mm},
id = Riffle @@ Reverse[MapAt[Reverse, TakeDrop[Range[n - 1], Quotient[n - 1, 2]], -1]];
mm = TakeList[Array[f, Binomial[n, 2]], id][[InversePermutation[id]]];
mm + Transpose[mm]]


For instance,

qdMat[6]
{{0, f[1], f[7], f[13], f[11], f[6]},
{f[1], 0, f[2], f[8], f[14], f[12]},
{f[7], f[2], 0, f[3], f[9], f[15]},
{f[13], f[8], f[3], 0, f[4], f[10]},
{f[11], f[14], f[9], f[4], 0, f[5]},
{f[6], f[12], f[15], f[10], f[5], 0}}

qdMat[9]
{{0, f[1], f[10], f[19], f[28], f[33], f[25], f[17], f[9]},
{f[1], 0, f[2], f[11], f[20], f[29], f[34], f[26], f[18]},
{f[10], f[2], 0, f[3], f[12], f[21], f[30], f[35], f[27]},
{f[19], f[11], f[3], 0, f[4], f[13], f[22], f[31], f[36]},
{f[28], f[20], f[12], f[4], 0, f[5], f[14], f[23], f[32]},
{f[33], f[29], f[21], f[13], f[5], 0, f[6], f[15], f[24]},
{f[25], f[34], f[30], f[22], f[14], f[6], 0, f[7], f[16]},
{f[17], f[26], f[35], f[31], f[23], f[15], f[7], 0, f[8]},
{f[9], f[18], f[27], f[36], f[32], f[24], f[16], f[8], 0}}


If we determine the elements in the first row, the remaining rows are obtained by simple rotation + padding and adding 1 to the previous rotated/padded row:

ClearAll[firstRow, rotatePad, spiralMat]

firstRow = Module[{rng = Range[0, Floor[(# - 1)/2]]},
1 + Join[# If[OddQ @ #, Most @ rng, rng] , (# - 1) Reverse @ Rest @ rng]] &;

spiralMat = MapIndexed[rotatePad[#, #2[[1]] - 1]&] @ NestList[#+1&, firstRow @ #, #-1]&;


Examples:

Row[MatrixForm[spiralMat[#]] & /@ Range[5, 9], Spacer[5]]


MatrixForm[spiralMat[9] /. x_Integer?Positive :> f[x]]


MatrixForm[# + Transpose @ # & @ spiralMat[9] /.  x_Integer?Positive :> f[x]]


Because the diagonals switch from the corner to close to the diagonal there is no pretty solution (or at least no easy one). The following code will do the trick. You will have to do the lower triangle by yourself though.

n=9;
m = ConstantArray[0, {n, n}];
initialxLeft = 2;
initialxRight = n;
leftOrRightToggle = "Left";
counter = 1;
While[initialxLeft <= initialxRight,
If[leftOrRightToggle == "Left",
{x, y} = {initialxLeft, 1};
initialxLeft++;
leftOrRightToggle = "Right",
{x, y} = {initialxRight, 1};
initialxRight--;
leftOrRightToggle = "Left"];
While[x <= n,
m[[y, x]] = counter;
counter++;
x++;
y++;
];
];
m


$$\left( \begin{array}{ccccccccc} 0 & f[1] & f[10] & f[19] & f[28] & f[33] & f[25] & f[17] & f[9] \\ 0 & 0 & f[2] & f[11] & f[20] & f[29] & f[34] & f[26] & f[18] \\ 0 & 0 & 0 & f[3] & f[12] & f[21] & f[30] & f[35] & f[27] \\ 0 & 0 & 0 & 0 & f[4] & f[13] & f[22] & f[31] & f[36] \\ 0 & 0 & 0 & 0 & 0 & f[5] & f[14] & f[23] & f[32] \\ 0 & 0 & 0 & 0 & 0 & 0 & f[6] & f[15] & f[24] \\ 0 & 0 & 0 & 0 & 0 & 0 & 0 & f[7] & f[16] \\ 0 & 0 & 0 & 0 & 0 & 0 & 0 & 0 & f[8] \\ 0 & 0 & 0 & 0 & 0 & 0 & 0 & 0 & 0 \\ \end{array} \right)$$

What it does: start with some point $$(x,y)$$. Move the point along a diagonal and use a counter to keep track of the current count. When it hits the edge reset back to the top row. leftOrRightToggle keeps track if you should start from the main diagonal or from the corner. initialxleft and initialxRight keep track of the initial x position for starting from the main diagonal or the corner respectivetely. Once initialxleft and initialxRight meet you are done.

• Hi! Thank you for your answer. Most likely, the elegant solution is given in a functional style preferred for Mathematica, instead of the procedural style you have provided. May I suggest you periodically revisit this question so you may study any functional style solutions that people post here? You may find them quite enlightening. Commented Sep 23, 2020 at 22:24
• For example, look at what I came up with (after 3 hours of playing around!): myMatrix[n_]:=#+Transpose[#]&[MapIndexed[RotateRight[#,#2[[1]]]&,Transpose[Partition[Array[f,(n^2-n)/2],n,n,1,0]~Join~ConstantArray[0,{Ceiling[n/2],n}]]]]. Then you can get the matrices my running myMatrix[9], for example. Commented Sep 23, 2020 at 23:03
• @QuantumDot Most likely, the elegant solution is given in a functional style - I think that's your preference but all solutions deserve consideration. Functional style solutions can be more cryptic and hide important details with deep nesting. At a glance you can tell that this answer is going to make one allocation and then do a 2-nested loop, but it takes more effort to know what's allocated, copied and iterated over in your comment. I'd say this answer is more readable to those outside Mathematica too, and it's useful to show this alongside the other answers. Commented Sep 24, 2020 at 11:24