Latin Squares in reduced form

From Rosetta Code
Latin Squares in reduced form is a draft programming task. It is not yet considered ready to be promoted as a complete task, for reasons that should be found in its talk page.

A Latin Square is in its reduced form if the first row and first column contain items in their natural order. The order n is the number of items. For any given n there is a set of reduced Latin Squares whose size increases rapidly with n. g is a number which identifies a unique element within the set of reduced Latin Squares of order n. The objective of this task is to construct the set of all Latin Squares of a given order and to provide a means which given suitable values for g any element within the set may be obtained.

For a reduced Latin Square the first row is always 1 to n. The second row is all Permutations/Derangements of 1 to n starting with 2. The third row is all Permutations/Derangements of 1 to n starting with 3 which do not clash (do not have the same item in any column) with row 2. The fourth row is all Permutations/Derangements of 1 to n starting with 4 which do not clash with rows 2 or 3. Likewise continuing to the nth row.

Demonstrate by:

  • displaying the four reduced Latin Squares of order 4.
  • for n = 1 to 6 (or more) produce the set of reduced Latin Squares; produce a table which shows the size of the set of reduced Latin Squares and compares this value times n! times (n-1)! with the values in OEIS A002860.

F#

The Function

This task uses Permutations/Derangements#F.23 <lang fsharp> // Generate Latin Squares in reduced form. Nigel Galloway: July 10th., 2019 let normLS α=

 let N=derange α|>List.ofSeq|>List.groupBy(fun n->n.[0])|>List.sortBy(fun(n,_)->n)|>List.map(fun(_,n)->n)|>Array.ofList
 let rec fG n g=match n with h::t->fG t (g|>List.filter(fun g->Array.forall2((<>)) h g )) |_->g
 let rec normLS n g=seq{for i in fG n N.[g] do if g=α-2 then yield [|1..α|]::(List.rev (i::n)) else yield! normLS (i::n) (g+1)}
 match α with 1->seq[[[|1|]]] |2-> seq[[[|1;2|];[|2;1|]]] |_->Seq.collect(fun n->normLS [n] 1) N.[0]

</lang>

The Task

<lang fsharp> normLS 4 |> Seq.iter(fun n->List.iter(printfn "%A") n;printfn "");; </lang>

Output:
[|1; 2; 3; 4|]
[|2; 3; 4; 1|]
[|3; 4; 1; 2|]
[|4; 1; 2; 3|]

[|1; 2; 3; 4|]
[|2; 1; 4; 3|]
[|3; 4; 2; 1|]
[|4; 3; 1; 2|]

[|1; 2; 3; 4|]
[|2; 1; 4; 3|]
[|3; 4; 1; 2|]
[|4; 3; 2; 1|]

[|1; 2; 3; 4|]
[|2; 4; 1; 3|]
[|3; 1; 4; 2|]
[|4; 3; 2; 1|]

<lang fsharp> let rec fact n g=if n<2 then g else fact (n-1) n*g [1..6] |> List.iter(fun n->let nLS=normLS n|>Seq.length in printfn "order=%d number of Reduced Latin Squares nLS=%d nLS*n!*(n-1)!=%d" n nLS (nLS*(fact n 1)*(fact (n-1) 1))) </lang>

Output:
order=1 number of Reduced Latin Squares nLS=1 nLS*n!*(n-1)!=1
order=2 number of Reduced Latin Squares nLS=1 nLS*n!*(n-1)!=2
order=3 number of Reduced Latin Squares nLS=1 nLS*n!*(n-1)!=12
order=4 number of Reduced Latin Squares nLS=4 nLS*n!*(n-1)!=576
order=5 number of Reduced Latin Squares nLS=56 nLS*n!*(n-1)!=161280
order=6 number of Reduced Latin Squares nLS=9408 nLS*n!*(n-1)!=812851200

Go

This reuses the dList function from the Permutations/Derangements#Go task, suitably adjusted for the present one. <lang go>package main

import (

   "fmt"
   "sort"

)

type matrix [][]int

// generate derangements of first n numbers, with 'start' in first place. func dList(n, start int) (r matrix) {

   start-- // use 0 basing
   a := make([]int, n)
   for i := range a {
       a[i] = i
   }
   a[0], a[start] = start, a[0]
   sort.Ints(a[1:])
   first := a[1]
   // recursive closure permutes a[1:]
   var recurse func(last int)
   recurse = func(last int) {
       if last == first {
           // bottom of recursion.  you get here once for each permutation.
           // test if permutation is deranged.
           for j, v := range a[1:] { // j starts from 0, not 1
               if j+1 == v {
                   return // no, ignore it
               }
           }
           // yes, save a copy
           b := make([]int, n)
           copy(b, a)
           for i := range b {
               b[i]++ // change back to 1 basing
           }
           r = append(r, b)
           return
       }
       for i := last; i >= 1; i-- {
           a[i], a[last] = a[last], a[i]
           recurse(last - 1)
           a[i], a[last] = a[last], a[i]
       }
   }
   recurse(n - 1)
   return

}

func reducedLatinSquare(n int, echo bool) uint64 {

   if n <= 0 {
       if echo {
           fmt.Println("[]\n")
       }
       return 0
   } else if n == 1 {
       if echo {
           fmt.Println("[1]\n")
       }
       return 1
   }
   rlatin := make(matrix, n)
   for i := 0; i < n; i++ {
       rlatin[i] = make([]int, n)
   }
   // first row
   for j := 0; j < n; j++ {
       rlatin[0][j] = j + 1
   }
   count := uint64(0)
   // recursive closure to compute reduced latin squares and count or print them
   var recurse func(i int)
   recurse = func(i int) {
       rows := dList(n, i) // get derangements of first n numbers, with 'i' first.
   outer:
       for r := 0; r < len(rows); r++ {
           copy(rlatin[i-1], rows[r])
           for k := 0; k < i-1; k++ {
               for j := 1; j < n; j++ {
                   if rlatin[k][j] == rlatin[i-1][j] {
                       if r < len(rows)-1 {
                           continue outer
                       } else if i > 2 {
                           return
                       }
                   }
               }
           }
           if i < n {
               recurse(i + 1)
           } else {
               count++
               if echo {
                   printSquare(rlatin, n)
               }
           }
       }
       return
   }
   // remaining rows
   recurse(2)
   return count

}

func printSquare(latin matrix, n int) {

   for i := 0; i < n; i++ {
       fmt.Println(latin[i])
   }
   fmt.Println()

}

func factorial(n uint64) uint64 {

   if n == 0 {
       return 1
   }
   prod := uint64(1)
   for i := uint64(2); i <= n; i++ {
       prod *= i
   }
   return prod

}

func main() {

   fmt.Println("The four reduced latin squares of order 4 are:\n")
   reducedLatinSquare(4, true)
   fmt.Println("The size of the set of reduced latin squares for the following orders")
   fmt.Println("and hence the total number of latin squares of these orders are:\n")
   for n := uint64(1); n <= 6; n++ {
       size := reducedLatinSquare(int(n), false)
       f := factorial(n - 1)
       f *= f * n * size
       fmt.Printf("Order %d: Size %-4d x %d! x %d! => Total %d\n", n, size, n, n-1, f)
   }

}</lang>

Output:
The four reduced latin squares of order 4 are:

[1 2 3 4]
[2 1 4 3]
[3 4 1 2]
[4 3 2 1]

[1 2 3 4]
[2 1 4 3]
[3 4 2 1]
[4 3 1 2]

[1 2 3 4]
[2 4 1 3]
[3 1 4 2]
[4 3 2 1]

[1 2 3 4]
[2 3 4 1]
[3 4 1 2]
[4 1 2 3]

The size of the set of reduced latin squares for the following orders
and hence the total number of latin squares of these orders are:

Order 1: Size 1    x 1! x 0! => Total 1
Order 2: Size 1    x 2! x 1! => Total 2
Order 3: Size 1    x 3! x 2! => Total 12
Order 4: Size 4    x 4! x 3! => Total 576
Order 5: Size 56   x 5! x 4! => Total 161280
Order 6: Size 9408 x 6! x 5! => Total 812851200

Phix

A Simple backtracking search.
aside: in phix here is no difference between res[r][c] and res[r,c]. I mixed them here, using whichever felt the more natural to me. <lang Phix>string aleph = "123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"

function rfls(integer n, bool count_only=true)

   if n>length(aleph) then ?9/0 end if -- too big...
   if n=1 then return iff(count_only?1:Template:1) end if
   atom t1 = time()+1
   sequence tn = tagset(n),     -- {1..n}
            vcs = repeat(tn,n), -- valid for cols
            vrs = repeat(tn,n), -- valid for rows
            res = repeat(tn,n)  -- (main workspace/one element of result)
   object result = iff(count_only?0:{})
   vcs[1] = {}     -- (not strictly necessary)
   vrs[1] = {}     --          """
   for i=2 to n do
       res[i] = i & repeat(0,n-1)
       vrs[i][i] = 0
       vcs[i][i] = 0
   end for
   integer r = 2, c = 2
   while true do
       -- place with backtrack:
       -- if we successfully place [n,n] add to results and backtrack
       -- terminate when we fail to place or backtrack from [2,2]
       integer rrc = res[r,c]
       if rrc!=0 then  -- backtrack (/undo)
           if vrs[r][rrc]!=0 then ?9/0 end if  -- sanity check
           if vcs[c][rrc]!=0 then ?9/0 end if  --      ""
           res[r,c] = 0
           vrs[r][rrc] = rrc
           vcs[c][rrc] = rrc
       end if
       bool found = false
       for i=rrc+1 to n do
           if vrs[r][i] and vcs[c][i] then
               res[r,c] = i
               vrs[r][i] = 0
               vcs[c][i] = 0
               found = true
               exit
           end if
       end for
       if found then
           if r=n and c=n then
               if count_only then
                   result += 1 
               else
                   result = append(result,res)
               end if
               -- (here, backtracking == not advancing)
           elsif c=n then
               c = 2
               r += 1
           else
               c += 1  
           end if
       else
           -- backtrack
           if r=2 and c=2 then exit end if
           c -= 1
           if c=1 then
               r -= 1
               c = n
           end if
       end if
   end while
   return result

end function

procedure reduced_form_latin_squares(integer n)

   sequence res = rfls(n,false)
   for k=1 to length(res) do
       for i=1 to n do
           string line = ""
           for j=1 to n do
               line &= aleph[res[k][i][j]]
           end for
           res[k][i] = line
       end for
       res[k] = join(res[k],"\n")
   end for
   string r = join(res,"\n\n")
   printf(1,"There are %d reduced form latin squares of order %d:\n%s\n",{length(res),n,r})

end procedure

reduced_form_latin_squares(4) puts(1,"\n") for n=1 to 6 do

   integer size = rfls(n),
           f = factorial(n)*factorial(n-1)*size
   printf(1,"Order %d: Size %-4d x %d! x %d! => Total %d\n", {n, size, n, n-1, f})

end for</lang>

Output:
There are 4 reduced form latin squares of order 4:
1234
2143
3412
4321

1234
2143
3421
4312

1234
2341
3412
4123

1234
2413
3142
4321

Order 1: Size 1    x 1! x 0! => Total 1
Order 2: Size 1    x 2! x 1! => Total 2
Order 3: Size 1    x 3! x 2! => Total 12
Order 4: Size 4    x 4! x 3! => Total 576
Order 5: Size 56   x 5! x 4! => Total 161280
Order 6: Size 9408 x 6! x 5! => Total 812851200