Latin Square from submatrix

Question

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

Answer 1

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] 

Answer 2

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.