Латинский квадрат — это квадратная матрица, в которой каждая строка и каждый столбец содержат все числа от 1 до N. Считать, что N<=20. Если полученный массив латинским квадратом не является, повторить процесс его формирования заново и так до тех пор, пока не будет получен искомый результат.
type
MyArr=array [1..20,1..20] of integer;
var
a:MyArr;
i,j,k,n:integer;
fl:boolean;
{функция факториала}
function Fact(n:integer):real;
var
i,res:integer;
begin
res:=1;
for i:=1 to n do
res:=res*i;
Fact:=res
end;
{функция проверки на латинский квадрат}
function Lat(a:MyArr;n:integer):boolean;
var
i,j,str,col:integer;
temp:real;
fl:boolean;
begin
fl:=true;
temp:=Fact(n);
i:=1;
while fl and (i<=n) do
begin
str:=1;
col:=1;
for j:=1 to n do
begin
str:=str*a[i,j];
col:=col*a[j,i];
end;
if (str<>temp)or(col<>temp) then
fl:=false;
inc(i)
end;
Lat:=fl
end;
{основная программа}
begin
n:=5;{тут можешь заменить если нужно случайное на n:=random(20)+1;}
writeln('Размер матрицы ',n,'x',n);
repeat
{задаем матрицу}
for i:=1 to n do
for j:=1 to n do
repeat
a[i,j]:=random(n)+1;
fl:=true;
for k:=1 to j do
if (a[i,k]=a[i,j]) and (k<>j) then
fl:=false;
until
fl;
until
Lat(a,n);
{выводим матрицу}
for i:=1 to n do
begin
for j:=1 to n do
write(a[i,j]:2,' ');
writeln
end
end.
Вариант 2
uses crt;
const max=20;
type mas=array[1..max] of byte;//строка матрицы
matr=array[1..max] of mas;//матрица-массив строк
procedure Stroka(var v:mas;n:byte);//заполняем строку числами
var m:set of byte;
i,c:byte;
begin
m:=[];
for i:=1 to n do
begin
repeat
c:=random(n)+1;//читаем число
until not(c in m);//если его нет в множестве
include(m,c);//заносим
v[i]:=c;//и в строку
end;
end;
procedure Matrica(var mt:matr;n:byte);//создание матрицы
var i:byte;
begin
for i:=1 to n do
Stroka(mt[i],n);//создаем все строки
end;
function Prov(mt:matr;n:byte):boolean;//проверка на лат. квадрат
var i,j,k,p:byte;
m:set of byte;
begin
k:=0;
for i:=1 to n do//проверяем строки
begin
p:=0;
m:=[];
for j:=1 to n do
if not(mt[i,j] in m) then
begin
p:=p+1;
include(m,mt[i,j]);
end;
if p=n then k:=k+1;//если все числа разные, считаем строку
end;
for j:=1 to n do//то же по столбцам
begin
p:=0;
m:=[];
for i:=1 to n do
if not(mt[i,j] in m) then
begin
p:=p+1;
include(m,mt[i,j]);
end;
if p=n then k:=k+1;
end;
if k=2*n then Prov:=true//если все строки и столбцы, то да
else Prov:=false;
end;
var a:matr;
n,i,j:byte;
begin
clrscr;
randomize;
{n:=random(max)+1;}
n:=5;
repeat
Matrica(a,n);
until Prov(a,n);
for i:=1 to n do
begin
for j:=1 to n do
write(a[i,j]:4);
writeln;
end;
readln
end.