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, MessagesSysUtilsVariantsClasses

  GraphicsControlsFormsDialogsStdCtrlsGrids;

Const M=50;

type
  TfmLatinUtk = class(TForm)
    lbLatinUtkTLabel;
    btKilepesTButton;
    sgVLNTStringGrid;
    btInitTButton;
    btRendezTButton;
    edMenetTEdit;
    edUTOSzTEdit;
    edMaxTEdit;
    lbKeszTLabel;
    lbMeretTLabel;
    edStartTEdit;
    edStopTEdit;
    edMaxMenetTEdit;
    Label1: TLabel;
    Procedure Init;
    Procedure Tablara;
    Procedure Keveres;
    Function UTSz(O1, O2, S: Word): Word;
    Procedure Utkozesek;
    procedure btKilepesClick(SenderTObject);
    procedure FormCreate(SenderTObject);
    procedure btInitClick(SenderTObject);
    procedure btRendezClick(SenderTObject);
    procedure edMaxChange(SenderTObject);
    procedure sgVLNDrawCell(SenderTObject; Col, Row: Integer;
      RectTRectStateTGridDrawState);
    procedure edMaxMenetChange(SenderTObject);
  private
    Private declarations }
  public
    Public declarations }
  end;

var
  fmLatinUtkTfmLatinUtk;
  VLN, UTT: Array[1..M,1..M] Of Word;
  MaxUTOSz: Word;
  MaxMenet, Menet: LongInt;

implementation

{$R *.dfm}

procedure TfmLatinUtk.btKilepesClick(SenderTObject);
begin
  Close;
end;

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

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

procedure TfmLatinUtk.sgVLNDrawCell(SenderTObject; Col, Row: Integer;
  RectTRectStateTGridDrawState);
begin
  With sgVLN.Canvas.Brush Do
  Begin
    If Not((gdSelected In StateOr (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(SenderTObject);
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(SenderTObject);
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(SenderTObject);
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<MaxMenetDo
  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.RePaintTablara;
      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.