Véletlen Latin négyzet generálása ütközésmentesítéssel (4. verzió)

Ez a program a Latin négyzet készítő programok közül a negyedik. Az eddigiektől alapvetően különböző algoritmus alapján dolgozik. Kezdetben létrehoz egy véletlen elrendezésű négyzetes táblázatot, melynek minden sorában 1-től Max-ig terjedő számok egy véletlen permutációja található. Egy soron belül tehát számismétlődés (ütközés) nem lehet.

A továbbiakban egy kicsit a genetikus algoritmusokhoz hasonlóan dolgozik (de nem genetikus!). Megállapítja, hogy a táblázat hány ütközést tartalmaz. Ezt úgy teszi, hogy minden elemnek külön-külön meghatározza az ütközési számát, majd ezeket összegzi. Ez lesz a táblázat jóságát (még pontosabban rosszaságát) kifejező számérték. Ettől kezdve beindul egy véletlen választáson alapuló keresési folyamat, mely során a sorokból véletlenül kiválasztunk két helyet. Az egyik olyan hely lesz, ahol ütközéses szám található, a másik tetszőleges. Megnézzük, hogy a kiválasztott két szám cseréjével nem romlik-e az ütközési számérték. Ha nem romlik, akkor a két elemet felcseréljük, majd ezt addig ismételjük, amíg az ütközések száma 0 nem lesz. Ha a minőségi vizsgálatnál ahhoz ragaszkodnánk, hogy mindenképp javuljon az ütközési számérték, az algoritmus végéhez közeledve a konvergencia leállna, a 0 értéket szinte biztosan nem érnénk el (a tapasztalatok ugyanis ezt mutatják).

A négyzet oldalhosszát az 1-50 intervallumból választhatjuk, melyhez a megjelenítő StringGrid mérete illeszkedik. Beállíthatjuk a lépések (véletlen választások) maximális számát, mely alapértelmezésben 1 millió. Minden tízezredik választás után frissül a képernyő, ezzel a futási időt jelentősen csökkenthetjük. A megjelenített táblázatban az ütközéses számok zöld háttérszínben látszanak.

A következő táblázat a kezdeti ütközési számokat, az átlagos keresési menetszámokat és a futási időket tartalmazza különböző méretű négyzetek esetén:

Méret	Kezdeti ütközésszám	Menetszám	Futási idő
5	20	60	<1 s
10	100	320	<1 s
15	220	1100	<1 s
20	400	2500	<1 s
25	600	5000	<1 s
30	900	7500	1 s
35	1200	15 ezer	1 s
40	1500	20 ezer	1 s
45	2000	32 ezer	1-2 s
50	2500	40 ezer	1-2 s

Néhány futási kép következik. 30-as méretnél a rendezés (generálás, ütközésmentesítés) előtti állapot:

30-as méretnél a generálás közbeni állapot:

30-as méretnél az elkészült Latin négyzet:

50-es méretnél az elkészült Latin négyzet:

A program listája:

unit ULatinUtk;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, 

Graphics, Controls, Forms, Dialogs, StdCtrls, Grids;

Const M=50;

type
TfmLatinUtk = class(TForm)
lbLatinUtk: TLabel;
btKilepes: TButton;
sgVLN: TStringGrid;
btInit: TButton;
btRendez: TButton;
edMenet: TEdit;
edUTOSz: TEdit;
edMax: TEdit;
lbKesz: TLabel;
lbMeret: TLabel;
edStart: TEdit;
edStop: TEdit;
edMaxMenet: TEdit;
Label1: TLabel;
Procedure Init;
Procedure Tablara;
Procedure Keveres;
Function UTSz(O1, O2, S: Word): Word;
Procedure Utkozesek;
procedure btKilepesClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure btInitClick(Sender: TObject);
procedure btRendezClick(Sender: TObject);
procedure edMaxChange(Sender: TObject);
procedure sgVLNDrawCell(Sender: TObject; Col, Row: Integer;
Rect: TRect; State: TGridDrawState);
procedure edMaxMenetChange(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
fmLatinUtk: TfmLatinUtk;
  VLN, UTT: Array[1..M,1..M] Of Word;
Max, UTOSz: Word;
MaxMenet, Menet: LongInt;

implementation

{$R *.dfm}

procedure TfmLatinUtk.btKilepesClick(Sender: TObject);
begin
Close;
end;

procedure TfmLatinUtk.edMaxChange(Sender: TObject);
Var Kod: Integer;
begin
Val(edMax.Text,Max,Kod);
end;

procedure TfmLatinUtk.edMaxMenetChange(Sender: TObject);
Var Kod: Integer;
begin
Val(edMaxMenet.Text,MaxMenet,Kod);
end;

procedure TfmLatinUtk.sgVLNDrawCell(Sender: TObject; Col, Row: Integer;
Rect: TRect; State: TGridDrawState);
begin
With sgVLN.Canvas.Brush Do
Begin
If Not((gdSelected In State) Or (gdFixed In State)) Then
Begin If UTT[Col,Row]<>0 Then Color:= clLime Else Color:= clWindow End;
End;
sgVLN.Canvas.TextRect(Rect,Rect.Left+1,
Rect.Top+1,sgVLN.Cells[Col,Row]);
If gdFocused In State Then sgVLN.Canvas.DrawFocusRect(Rect);
end;

procedure TfmLatinUtk.FormCreate(Sender: TObject);
begin
Randomize;
Max:= 20;
MaxMenet:= 1000000;
end;

Procedure TfmLatinUtk.Init;
Var I, J: Word;
Begin
For I:= 1 To Max Do For J:= 1 To Max Do VLN[I,J]:= I;
With sgVLN Do
Begin
For I:= 0 To ColCount-1 Do For J:= 0 To RowCount-1 Do Cells[I,J]:= '';
For I:= 1 To Max Do
Begin
Cells[I,0]:= IntToStr(I);
Cells[0,I]:= IntToStr(I);
End;
End;
End;

Procedure TfmLatinUtk.Keveres;
Var I, J, A, B, P: Word;
Begin
For I:= 1 To Max Do
For J:= 1 To 10000 Do
Begin
    A:= Random(Max)+1; B:= Random(Max)+1;
    P:= VLN[A,I]; VLN[A,I]:= VLN[B,I]; VLN[B,I]:= P;
End;
End;

Function TfmLatinUtk.UTSz(O1, O2, S: Word): Word;
Var I, N: Word;
Begin
  N:= 0;
For I:= 1 To Max Do If (I<>S) And (VLN[O1,I]=VLN[O2,S]) Then Inc(N);
UTSz:= N;
End;

Procedure TfmLatinUtk.Utkozesek;
Var I, J: Word;
Begin
UtOSz:= 0;
For I:= 1 To Max Do For J:= 1 To Max Do
Begin UTT[I,J]:= UTSz(I,I,J); Inc(UtOSz,UTT[I,J]) End;
End;

Procedure TfmLatinUtk.Tablara;
Var I, J: Word;
Begin
With sgVLN Do
Begin
For I:= 1 To Max Do For J:= 1 To Max Do Cells[I,J]:= IntToStr(VLN[I,J]);
RePaint;
End;
End;

procedure TfmLatinUtk.btInitClick(Sender: TObject);
begin
lbKesz.Visible:= False;
edStart.Text:= '';
edStop.Text:= '';
With sgVLN Do
Begin
ColCount:= Max+1;
RowCount:= Max+1;
Width:= (Max+1)*17+3;
Height:= (Max+1)*14+3;
End;
Init;
Keveres;
Utkozesek;
Tablara;
  Menet:= 0;
edMenet.Text:= IntToStr(Menet);
edUtOSz.Text:= IntToStr(UTOSz);
end;

procedure TfmLatinUtk.btRendezClick(Sender: TObject);
Var I, J, A, B, S, P: Word;
begin
edStart.Text:= TimeToStr(GetTime); edStart.Repaint;
edStop.Text:= ''; edStop.Repaint;
lbKesz.Caption:= '        '; lbKesz.Repaint;
  Menet:= 0;
While (UTOSz>0) And (Menet<MaxMenet) Do
Begin
    Inc(Menet); A:= 1; S:= 1;
While UTT[A,S]=0 Do
Begin A:= Random(Max)+1; S:= Random(Max)+1 End;
    B:= Random(Max)+1;
If UTT[A,S]+UTT[B,S]>=UTSz(A,B,S)+UTSz(B,A,S) Then
Begin
      P:= VLN[A,S]; VLN[A,S]:= VLN[B,S]; VLN[B,S]:= P;
For I:= 1 To Max Do UTT[A,I]:= UTSz(A,A,I);
For I:= 1 To Max Do UTT[B,I]:= UTSz(B,B,I);
UtOSz:= 0;
For I:= 1 To Max Do For J:= 1 To Max Do Inc(UtOSz,UTT[I,J]);
End;
If Menet Mod 10000=0 Then
Begin
edMenet.Text:= IntToStr(Menet); edMenet.RePaint; Tablara;
edUtOSz.Text:= IntToStr(UTOSz); edUTOsz.RePaint;
End;
End;
Tablara;
edMenet.Text:= IntToStr(Menet);
edUtOSz.Text:= IntToStr(UTOSz);
With lbKesz Do If UTOsz=0 Then
Caption:= 'Kész' Else Caption:= 'Vége';
lbKesz.Visible:= True;
edStop.Text:= TimeToStr(GetTime);
end;

end.