Task: Latin Squares in reduced form


C++: #include <algorithm>
#include <functional>
#include <iostream>
#include <numeric>
#include <vector>

typedef std::vector<std::vector<int>> matrix;

matrix dList(int n, int start) {
    start--; 

    std::vector<int> a(n);
    std::iota(a.begin(), a.end(), 0);
    a[start] = a[0];
    a[0] = start;
    std::sort(a.begin() + 1, a.end());
    auto first = a[1];
    
    matrix r;
    std::function<void(int)> recurse;
    recurse = [&](int last) {
        if (last == first) {
            
            
            for (size_t j = 1; j < a.size(); j++) {
                auto v = a[j];
                if (j == v) {
                    return; 
                }
            }
            
            std::vector<int> b;
            std::transform(a.cbegin(), a.cend(), std::back_inserter(b), [](int v) { return v + 1; });
            r.push_back(b);
            return;
        }
        for (int i = last; i >= 1; i--) {
            std::swap(a[i], a[last]);
            recurse(last - 1);
            std::swap(a[i], a[last]);
        }
    };
    recurse(n - 1);
    return r;
}

void printSquare(const matrix &latin, int n) {
    for (auto &row : latin) {
        auto it = row.cbegin();
        auto end = row.cend();
        std::cout << '[';
        if (it != end) {
            std::cout << *it;
            it = std::next(it);
        }
        while (it != end) {
            std::cout << ", " << *it;
            it = std::next(it);
        }
        std::cout << "]\n";
    }
    std::cout << '\n';
}

unsigned long reducedLatinSquares(int n, bool echo) {
    if (n <= 0) {
        if (echo) {
            std::cout << "[]\n";
        }
        return 0;
    } else if (n == 1) {
        if (echo) {
            std::cout << "[1]\n";
        }
        return 1;
    }

    matrix rlatin;
    for (int i = 0; i < n; i++) {
        rlatin.push_back({});
        for (int j = 0; j < n; j++) {
            rlatin[i].push_back(j);
        }
    }
    
    for (int j = 0; j < n; j++) {
        rlatin[0][j] = j + 1;
    }

    unsigned long count = 0;
    std::function<void(int)> recurse;
    recurse = [&](int i) {
        auto rows = dList(n, i);

        for (size_t r = 0; r < rows.size(); r++) {
            rlatin[i - 1] = rows[r];
            for (int k = 0; k < i - 1; k++) {
                for (int j = 1; j < n; j++) {
                    if (rlatin[k][j] == rlatin[i - 1][j]) {
                        if (r < rows.size() - 1) {
                            goto outer;
                        }
                        if (i > 2) {
                            return;
                        }
                    }
                }
            }
            if (i < n) {
                recurse(i + 1);
            } else {
                count++;
                if (echo) {
                    printSquare(rlatin, n);
                }
            }
        outer: {}
        }
    };

    
    recurse(2);
    return count;
}

unsigned long factorial(unsigned long n) {
    if (n <= 0) return 1;
    unsigned long prod = 1;
    for (unsigned long i = 2; i <= n; i++) {
        prod *= i;
    }
    return prod;
}

int main() {
    std::cout << "The four reduced lating squares of order 4 are:\n";
    reducedLatinSquares(4, true);

    std::cout << "The size of the set of reduced latin squares for the following orders\n";
    std::cout << "and hence the total number of latin squares of these orders are:\n\n";
    for (int n = 1; n < 7; n++) {
        auto size = reducedLatinSquares(n, false);
        auto f = factorial(n - 1);
        f *= f * n * size;
        std::cout << "Order " << n << ": Size " << size << " x " << n << "! x " << (n - 1) << "! => Total " << f << '\n';
    }

    return 0;
}







VB: Option Strict On

Imports Matrix = System.Collections.Generic.List(Of System.Collections.Generic.List(Of Integer))

Module Module1

    Sub Swap(Of T)(ByRef a As T, ByRef b As T)
        Dim u = a
        a = b
        b = u
    End Sub

    Sub PrintSquare(latin As Matrix)
        For Each row In latin
            Dim it = row.GetEnumerator
            Console.Write("[")
            If it.MoveNext Then
                Console.Write(it.Current)
            End If
            While it.MoveNext
                Console.Write(", ")
                Console.Write(it.Current)
            End While
            Console.WriteLine("]")
        Next
        Console.WriteLine()
    End Sub

    Function DList(n As Integer, start As Integer) As Matrix
        start -= 1 REM use 0 based indexes
        Dim a = Enumerable.Range(0, n).ToArray
        a(start) = a(0)
        a(0) = start
        Array.Sort(a, 1, a.Length - 1)
        Dim first = a(1)
        REM recursive closure permutes a[1:]
        Dim r As New Matrix

        Dim Recurse As Action(Of Integer) = Sub(last As Integer)
                                                If last = first Then
                                                    REM bottom of recursion. you get here once for each permutation
                                                    REM test if permutation is deranged.
                                                    For j = 1 To a.Length - 1
                                                        Dim v = a(j)
                                                        If j = v Then
                                                            Return REM no, ignore it
                                                        End If
                                                    Next
                                                    REM yes, save a copy with 1 based indexing
                                                    Dim b = a.Select(Function(v) v + 1).ToArray
                                                    r.Add(b.ToList)
                                                    Return
                                                End If
                                                For i = last To 1 Step -1
                                                    Swap(a(i), a(last))
                                                    Recurse(last - 1)
                                                    Swap(a(i), a(last))
                                                Next
                                            End Sub
        Recurse(n - 1)
        Return r
    End Function

    Function ReducedLatinSquares(n As Integer, echo As Boolean) As ULong
        If n <= 0 Then
            If echo Then
                Console.WriteLine("[]")
                Console.WriteLine()
            End If
            Return 0
        End If
        If n = 1 Then
            If echo Then
                Console.WriteLine("[1]")
                Console.WriteLine()
            End If
            Return 1
        End If

        Dim rlatin As New Matrix
        For i = 0 To n - 1
            rlatin.Add(New List(Of Integer))
            For j = 0 To n - 1
                rlatin(i).Add(0)
            Next
        Next
        REM first row
        For j = 0 To n - 1
            rlatin(0)(j) = j + 1
        Next

        Dim count As ULong = 0
        Dim Recurse As Action(Of Integer) = Sub(i As Integer)
                                                Dim rows = DList(n, i)

                                                For r = 0 To rows.Count - 1
                                                    rlatin(i - 1) = rows(r)
                                                    For k = 0 To i - 2
                                                        For j = 1 To n - 1
                                                            If rlatin(k)(j) = rlatin(i - 1)(j) Then
                                                                If r < rows.Count - 1 Then
                                                                    GoTo outer
                                                                End If
                                                                If i > 2 Then
                                                                    Return
                                                                End If
                                                            End If
                                                        Next
                                                    Next
                                                    If i < n Then
                                                        Recurse(i + 1)
                                                    Else
                                                        count += 1UL
                                                        If echo Then
                                                            PrintSquare(rlatin)
                                                        End If
                                                    End If
outer:
                                                    While False
                                                        REM empty
                                                    End While
                                                Next
                                            End Sub

        REM remiain rows
        Recurse(2)
        Return count
    End Function

    Function Factorial(n As ULong) As ULong
        If n <= 0 Then
            Return 1
        End If
        Dim prod = 1UL
        For i = 2UL To n
            prod *= i
        Next
        Return prod
    End Function

    Sub Main()
        Console.WriteLine("The four reduced latin squares of order 4 are:")
        Console.WriteLine()
        ReducedLatinSquares(4, True)

        Console.WriteLine("The size of the set of reduced latin squares for the following orders")
        Console.WriteLine("and hence the total number of latin squares of these orders are:")
        Console.WriteLine()
        For n = 1 To 6
            Dim nu As ULong = CULng(n)

            Dim size = ReducedLatinSquares(n, False)
            Dim f = Factorial(nu - 1UL)
            f *= f * nu * size
            Console.WriteLine("Order {0}: Size {1} x {2}! x {3}! => Total {4}", n, size, n, n - 1, f)
        Next
    End Sub

End Module