5
$\begingroup$

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...

$\endgroup$

3 Answers 3

4
$\begingroup$

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 = PadRight[PadLeft[Reverse[Flatten[mm, {{2}, {1}}], 2], {Automatic, n}], {n, n}];
  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}}
$\endgroup$
4
$\begingroup$

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]] &;

rotatePad = Fold[PadLeft, RotateRight[#, #2], Length[#] + {-#2, 1}] &;

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

Examples:

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

enter image description here

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

enter image description here

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

enter image description here

$\endgroup$
3
$\begingroup$

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.

$\endgroup$
3
  • 1
    $\begingroup$ 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. $\endgroup$
    – QuantumDot
    Commented Sep 23, 2020 at 22:24
  • $\begingroup$ 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. $\endgroup$
    – QuantumDot
    Commented Sep 23, 2020 at 23:03
  • 1
    $\begingroup$ @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. $\endgroup$
    – flinty
    Commented Sep 24, 2020 at 11:24

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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