Latin Square from submatrix

A Latin Square is a $$n\times n$$ matrix with entries in $$\{1,\ldots,n\}$$ such that

• each column has the entries $$\{1,\ldots,n\}$$ and
• each row has the entires $$\{1,\ldots,n\}$$.

It's a common math problem to "fill in" missing entries of a partial (claimed) Latin Square. I want to write a function whose input is a partially filled $$n\times n$$ matrix which outputs a valid Latin Square supermatrix if one exists. For instance,

7   1   4   3   2   5   6
4   3   7   6   5   2   1
1   2   6   7   4   3   5


are the first three rows of many valid $$7\times7$$ Latin Squares. The Nulls in the following $$6\times6$$ matrix can be replaced with numbers from 4 to 6 which make it a Latin Square

partmat={{,2,3,,,1},{2,3,,,1,},{3,,2,1,,},{,,1,2,,3},{,1,,,3,2},{1,,,3,2,}}


etc. If no values are given, there is a huge amount of solutions. But given some partially filled in matrix (say, with Nulls), write some code to compute a valid coinciding Latin Square, and then find them all.

For the first example, I defined a function

allvalidnextrows[pancakerect_, n_] :=
Select[Flatten[Outer @@
Prepend[Complement[Range@7, #] & /@ (pancakerect\[Transpose]),
List], n - 1], Sort@# == Range@n &]


and used (with rows appropriately defined)

Nest[DeleteDuplicates[Join @@ ((mat \[Function]
Append[mat, #] & /@ allvalidnextrows[mat, 7]) /@ #)] &, {rows}, 4]


to find the ~11 thousand supmatrices. For the second example, I wrote a weird function which substitutes the 18 missing values

matfunc = Evaluate[Activate@
Fold[{ReplacePart[#[[1]], #2 -> Inactive[Slot][#[[2]]]], #[[2]] +
1} &, {partmat, 1}, Position[partmat, Null]][[1]]] &


and then did some things I'm ashamed of to arrive at

MatrixForm[matfunc @@ Join @@ #] & /@
Flatten[Table[
If[{4, 5, 6} == Sort@{i1[[1]], i4[[1]], i5[[1]]} ==
Sort@{i3[[1]], i4[[2]], i6[[1]]} ==
Sort@{i2[[1]], i5[[2]], i6[[2]]} ==
Sort@{i1[[2]], i2[[2]], i5[[3]]} ==
Sort@{i1[[3]], i3[[2]], i4[[3]]} ==
Sort@{i2[[3]], i3[[3]], i6[[3]]}, {i1, i2, i3, i4, i5, i6},
Nothing], {i1, {{4, 5, 6}, {4, 6, 5}, {5, 4, 6}, {5, 6, 4}, {6, 4,
5}, {6, 5, 4}}}, {i2, {{4, 5, 6}, {4, 6, 5}, {5, 4, 6}, {5, 6,
4}, {6, 4, 5}, {6, 5, 4}}}, {i3, {{4, 5, 6}, {4, 6, 5}, {5, 4,
6}, {5, 6, 4}, {6, 4, 5}, {6, 5, 4}}}, {i4, {{4, 5, 6}, {4, 6,
5}, {5, 4, 6}, {5, 6, 4}, {6, 4, 5}, {6, 5, 4}}}, {i5, {{4, 5,
6}, {4, 6, 5}, {5, 4, 6}, {5, 6, 4}, {6, 4, 5}, {6, 5,
4}}}, {i6, {{4, 5, 6}, {4, 6, 5}, {5, 4, 6}, {5, 6, 4}, {6, 4,
5}, {6, 5, 4}}}], 5]


which yields 72 supmatrices.

This question is to give context to another one, Activating part without resolving [[1]]. I'm curious about generality (I haven't achieved that with my code) and performance (I certainly haven't achieved that with my code).

• Ummm... what's your question, exactly? Commented Feb 27, 2022 at 0:03
• I suppose this is more suited for the Wolfram forum, but to pin down an explicit Q: how to write a function whose input is a partially filled square matrix which outputs a valid Latin Square supermatrix if there is one.
Commented Feb 27, 2022 at 0:29
• That's a valid question here... but please WRITE that question within your posting! Commented Feb 27, 2022 at 1:19

Here is a quick and dirty and not very well tested solution using recursion.

The input must consists of a matrix with elements 0..n. The 0 indicates a missing element. If no solution is possible "Nothing" is returned.

First, we need a test to see if a partial solution fulfills the conditions:

test[sq0_] := Module[{sq = sq0, c},
c = 0; sq = sq /. 0 :> --c;
AllTrue[Join[DuplicateFreeQ /@ sq , DuplicateFreeQ /@ Transpose[sq]]
, # == True &]
]


Then we try to eliminate the zeros one at a time:

step[sq0_] := Module[{sq, pos, n = Length[sq0], row, t},
If[! MemberQ[Flatten[sq0], 0], Return[{sq0}]];
res = Reap[
pos = FirstPosition[sq0, 0];
(sq = sq0; sq[[Sequence @@ pos]] = #;
If[test[sq], Sow[step[sq]]] ) & /@
Complement[Range[n], Union[sq0[[pos[[1]], All]]],
sq0[[All, pos[[2]]]]];
][[2]];
res = Flatten[res, 2];
If[Flatten[res] == {}, Nothing, res]
]


For a test we need a matrix: sq that fulfills the conditions:

While[(sq = Array[RandomInteger[{0, 3}] &, {3, 3}]; ! test[sq])];
MatrixForm[sq]


And then we can get the solutions:

MatrixForm /@ step[sq]


Or with a 4 times 4 matrix:

While[(sq = Array[RandomInteger[{0, 4}] &, {4, 4}]; ! test[sq])];
MatrixForm[sq]
MatrixForm /@ step[sq]


• Why not RandomInteger[{0, 4}, {4, 4}] in place of Array[RandomInteger... for testing speedup? Also, should res not be also declared in the Module instead of as a global symbol? Also, what's with the AllTrue[...,#==True] -- intentionally verbose?
Commented Feb 27, 2022 at 20:38
• Also, +1, awesome answer. A cute math problem is to find a 10x10 one whose upperleft 5x5 submatrix is the addition table mod 5. This code doesn't fare too well -- I suppose it does BFS -- but most tricky math problems are are designed with loopholes to be infeasible with brute force.
Commented Feb 27, 2022 at 20:43
• You are right. There things to improve. I simply tried to made it work. Commented Feb 27, 2022 at 20:51
• Here is a faster trial: n = 5; nzero = 15; pe = Permutations[Range[n]]; While[! test[sq = RandomChoice[Permutations[Range[n]], n]]]; sq = ReplacePart[sq, RandomInteger[{1, n}, {nzero, 2}] -> 0]; sq // MatrixForm step[sq] Commented Feb 27, 2022 at 21:24

There is a paper (Ref. 1) that proved that a diagonal element in a Latin square doesn't occur more than twice in the diagonal. So no Latin square has a form of partmat. You can brute-check via:

partmat = {{_, 2, 3, _, _, 1}, {2, 3, _, _, 1, _}, {3, _, 2, 1, _, _}, {_, _, 1, 2, _, 3}, {_, 1, _, _, 3, 2}, {1, _, _, 3, 2, _}};
n = Length@partmat (*dimension of partmat*);
size = n!*n!;

(*produce every permutation of LS in dimension n*)
ran = Range[1, n];
seed = DeleteDuplicates[Permutations[ran], AnyTrue[Table[#1[[i]] == #2[[i]], {i, n}], TrueQ] &] (*make a seed Latin square*);
lPr = Permutations[seed] (*row permutations*);
lP = {};
Dynamic[N[Length[lP]/size]]
Do[
lsP = lPr[[i]];
lP = Join[lP, Transpose /@ Permutations[Transpose[lsP]]];
Clear[lsP];
, {i, n!}]

(*search every Latin square matching partmat pattern*)
sol = Select[lP, AllTrue[Table[MatchQ[#[[i]], partmat[[i]]], {i, n}], TrueQ] &]
(* {} *)


Reference:

1. Peter J. Cameron and Ian M. Wanless, Covering radius for sets of permutations, 2004.
• If partmat is defined with Null's instead of _'s, then I get True out of partmat=={{4, 2, 3, 5, 6, 1}, {2, 3, 4, 6, 1, 5}, {3, 4, 2, 1, 5, 6}, {5, 6, 1, 2, 4, 3}, {6, 1, 5, 4, 3, 2}, {1, 5, 6, 3, 2, 4}} /. (4 | 5 | 6) -> Null