Easy way to populate this matrix? - matrix

Question

I would like to populate an n * n (n being odd) matrix in the following way:
_ _ _ 23 22 21 20
_ _ 24 10 9 8 37
_ 25 11 3 2 19 36
26 12 4 1 7 18 35
27 13 5 6 17 34 _
28 14 15 16 33 _ _
29 30 31 32 _ _ _
What is an easy way to do this using Mathematica?

Answer 1

With this helper function:
Clear[makeSteps];
makeSteps[0] = {};
makeSteps[m_Integer?Positive] :=
Most#Flatten[
Table[#, {m}] & /# {{-1, 0}, {-1, 1}, {0, 1}, {1, 0}, {1, -1}, {0, -1}}, 1];
We can construct the matrix as
constructMatrix[n_Integer?OddQ] :=
Module[{cycles, positions},
cycles = (n+1)/2;
positions =
Flatten[FoldList[Plus, cycles + {#, -#}, makeSteps[#]] & /#
Range[0, cycles - 1], 1];
SparseArray[Reverse[positions, {2}] -> Range[Length[positions]]]];
To get the matrix you described, use
constructMatrix[7] // MatrixForm
The idea behind this is to examine the pattern that the positions of consecutive numbers 1.. follow. You can see that these form the cycles. The zeroth cycle is trivial - contains a number 1 at position {0,0} (if we count positions from the center). The next cycle is formed by taking the first number (2) at position {1,-1} and adding to it one by one the following steps: {0, -1}, {-1, 0}, {-1, 1}, {0, 1}, {1, 0} (as we move around the center). The second cycle is similar, but we have to start with {2,-2}, repeat each of the previous steps twice, and add the sixth step (going up), repeated only once: {0, -1}. The third cycle is analogous: start with {3,-3}, repeat all the steps 3 times, except {0,-1} which is repeated only twice. The auxiliary function makeSteps automates the process. In the main function then, we have to collect all positions together, and then add to them {cycles, cycles} since they were counted from the center, which has a position {cycles,cycles}. Finally, we construct the SparseArray out of these positions.

Answer 2

I don't know the Mathematica syntax but I guess you could use an algorithm like this:
start in the middle of the matrix
enter a 1 into the middle
go up-right (y-1 / x+1)
set integer iter=1
set integer num=2
while cursor is in matrix repeat:
enter num in current field
increase num by 1
repeat iter times:
go left (x-1 / y)
enter num in current field
increase num by 1
repeat iter times:
go down-left (x-1 / y+1)
enter num in current field
increase num by 1
repeat iter times:
go down (x / y+1)
enter num in current field
increase num by 1
repeat iter times:
go right (x+1 / y)
enter num in current field
increase num by 1
repeat iter times:
go up-right (x+1 / y-1)
enter num in current field
increase num by 1
repeat iter-1 times:
go up (x / y-1)
enter num in current field
increase num by 1
go up-up-right (y-2 / x+1)
increase iter by 1
you can also pretty easily convert this algorithm into a functional version or into a tail-recursion.
Well, you will have to check in the while loop if you aren't out of bounds as well. If n is odd then you can just count num up while:
m = floor(n/2)
num <= n*n - (m+m*m)
I'm pretty sure that there's a simpler algorithm but that's the most intuitive one to me.

Answer 3

The magic numbers on the diagonal starting at 1 and going up right can be arrived at from
f[n_] := 2 Sum[2 m - 1, {m, 1, n}] + UnitStep[n - 3] Sum[2 m, {m, 1, n - 2}]
In := f#Range#5
Out := {2, 8, 20, 38, 62}
With this it should be easy to set up a SparseArray. I'll play around with it a bit and see how hard that is.

Answer 4

First version:
i = 10;
a = b = c = Array[0 &, {2 (2 i + 1), 2 (2 i + 1)}];
f[n_] := 3*n*(n + 1) + 1;
k = f[i - 2];
p[i_Integer] :=
ToRules#Reduce[
-x + y < i - 1 && -x + y > -i + 1 &&
(2 i + 1 - x)^2 + (2 i + 1 - y)^2 <= 2 i i - 2 &&
3 i - 1 > x > i + 1 &&
3 i - 1 > y > i + 1, {x, y}, Integers];
((a[[Sequence ## #]] = 1) & /# ({x, y} /. {p[i]}));
((a[[Sequence ## (# + {2, 2})]] = 0) & /# ({x, y} /. {p[i - 1]}));
(b[[Sequence ## #]] = k--)&/#((# + 2 i {1, 1}) &/# (SortBy[(# - 2 i {1, 1}) &/#
Position[a, 1],
N#(Mod[-10^-9 - Pi/4 + ArcTan[Sequence ## #], 2 Pi]) &]));
c = Table[b[[2 (2 i + 1) - j, k]], {j, 2 (2 i + 1) - 1},
{k, 2 (2 i + 1) - 1}];
MatrixPlot[c]
Edit
A better one:
genMat[m_] := Module[{f, k, k1, i, n, a = {{1}}},
f[n_] := 3*n*(n + 1) + 1;
For[n = 1, n <= m, n++,
a = ArrayPad[a, 1];
k1 = (f[n - 1] + (k = f[n]) + 2)/2 - 1;
For[i = 2, i <= n + 1, i++, a[[i, 2n + 1]] = k--; a[[2-i+2 n, 1]] = k1--];
For[i = n + 2, i <= 2 n + 1, i++, a[[i, 3n+2-i]] = k--; a[[-i,i-n]] = k1--];
For[i = n, i >= 1, i--, a[[2n+1, i]] = k--;a[[1, -i + 2 n + 2]] = k1--];
];
Return#MatrixForm[a];
]
genMat[5]

Answer 5

A partial solution, using image procssing:
Image /# (Differences#(ImageData /#
NestList[
Fold[ImageAdd,
p = #, (HitMissTransform[p, #, Padding -> 0] & /#
{{{1}, {-1}},
{{-1}, {-1}, {1}},
{{1, -1, -1}},
{{-1, -1, 1}},
{{-1, -1, -1, -1}, {-1, -1, -1, -1}, {1, 1, -1, -1}},
{{-1, -1, -1, 1}, {-1, -1, -1, -1}, {-1, -1, -1, -1}}})] &, img, 4]))