Optimizing the calculation of a global maximum

ClearAll["Global*"]

n = 4;

A = Table[Table[Indexed[x, {i, j}], {j, 1, n}], {i, 1, n}];

solns = Maximize[{Det[A], Join[Flatten[Map[{1 <= #, # <= n} &, Flatten[A]]], {Total[Flatten[A]] ==n*Total[Range[1, n]], Product[Flatten[A][[i]], {i, 1, n^2}] == (n!)^n}]}, Flatten[A],Integers][[2]];

MatrixForm[Table[Table[solns[[i*n + j - n]][[2]], {j, 1, n}], {i, 1, n}]]

Table[Table[solns[[i*n + j - n]][[2]], {j, 1, n}], {i, 1, n}]


I am looking to use this code to maximize the determinant of a $$n\times n$$ matrix which contains only digits $$1$$ through $$n$$ (inclusive), of which each digit must appear exactly $$n$$ times.

Currently, this code is very slow when $$n\ge4$$.

How can this Mathematica code be modified to make it tractable when $$n\ge4$$?

• I believe but I do not think I can prove that the best possible 9x9 matrix for this is any positive-determinant row-column permutation of the following matrix: RotateRight[Range[9], #] & /@ (Range[9] - 1). For the 4x4 case this finds a 4x4 matrix with a determinant of 160, which is an improvement over the existing answer. Feb 19, 2022 at 2:49
• For the n=9 case a determinant of 933,251,220 can be achieved: {{9, 4, 1, 5, 6, 8, 3, 2, 7}, {5, 9, 4, 6, 3, 2, 1, 8, 7}, {8, 5, 9, 2, 1, 4, 7, 3, 6}, {4, 3, 7, 9, 8, 1, 5, 2, 6}, {3, 6, 8, 1, 9, 7, 2, 5, 4}, {1, 7, 5, 8, 2, 9, 6, 3, 4}, {6, 8, 2, 4, 7, 3, 9, 5, 1}, {7, 1, 6, 7, 4, 6, 4, 9, 1}, {2, 2, 3, 3, 5, 5, 8, 8, 9}} Feb 19, 2022 at 3:44
• “Each digit appears exactly $n$ times” seems to imply there are $9n$ entries in your $n\times n$ matrix. Did you mean digits 1 through $n$ (for a given $n$ up to 9), by chance? Feb 20, 2022 at 5:52
• Thank you for pointing that out, I did mean 1 through $n$ however I was initially interested in the $n=9$ case when I made the post and must have mixed it up. Feb 20, 2022 at 15:05

You can use the MaximizeOverPermutations resource function to find Monte-Carlo stochastic estimates of the maximum (with no guarantee of global maximality). With this method you can get "pretty good" solutions for very large $$n$$.

As an example, let's do $$n=5$$:

f[L_] := With[{n = Sqrt[Length[L]]}, Det[Partition[Mod[L, n, 1], n]]]

MOP = ResourceFunction["MaximizeOverPermutations"];
M = MOP[f, 25, Method -> {"MonteCarlo", "Iterations" -> 10^5,
"AnnealingParameter" -> 1}];
M[[2]]
(*    2196.    *)


Show the unique solution(s):

Partition[#, 5] & /@ Union[Mod[M[[1]], 5, 1]]
(*    {
{{3, 1, 5, 4, 2},
{2, 2, 1, 4, 5},
{4, 4, 2, 5, 1},
{1, 5, 4, 2, 3},
{5, 3, 3, 1, 3}}
}    *)


We can also do $$n=9$$:

M = MOP[f, 81, Method -> {"MonteCarlo", "Iterations" -> 10^5,
"AnnealingParameter" -> 1}];
M[[2]]
(*    9.02194*10^8    *)


(not quite reached @YusufBashi's maximum yet, need more iterations)

Partition[#, 9] & /@ Union[Mod[M[[1]], 9, 1]]
(*    {
{{6, 7, 2, 4, 7, 1, 5, 9, 5},
{7, 4, 7, 8, 9, 3, 2, 1, 4},
{5, 9, 4, 6, 3, 5, 9, 1, 3},
{1, 4, 2, 6, 7, 8, 5, 4, 9},
{3, 1, 8, 7, 3, 2, 9, 6, 6},
{8, 2, 2, 8, 2, 8, 4, 7, 3},
{2, 8, 9, 5, 3, 6, 1, 7, 4},
{9, 5, 6, 1, 2, 5, 4, 3, 9},
{5, 3, 6, 1, 8, 8, 7, 6, 1}
}    *)


Maybe use NMaximize.

n = 4;
A = Table[Indexed[x, {i, j}], {j, 1, n}, {i, 1, n}];
vars = Flatten[A];
solns = NMaximize[{Det[A], 1 <= vars <= n, vars ∈ Integers,
Plus @@ vars == n*Plus @@ Range[n], Times @@ vars == (n!)^n},
vars][[2]]
A /. solns
A /. solns // Transpose


{{3, 4, 1, 2}, {3, 1, 3, 3}, {1, 4, 2, 4}, {1, 2, 4, 2}}

{{3, 3, 1, 1}, {4, 1, 4, 2}, {1, 3, 2, 4}, {2, 3, 4, 2}}`