Latin négyzet (2. verzió)

A Latin négyzet programnál leírtak figyelembe vételével, javítsunk oly módon a véletlen permutáció előállításán, hogy egy adott pozícióba már csak a sor és oszlop szerint megengedett értékekből választhasson a program. Így akár 50 x 50-es négyzetet is tud elfogadható időn belül (kb. 15 perc) egy gyors PC előállítani. Ez a program méri a generáláshoz szükséges időt és azt ki is jelzi. Az előállított táblázat adatait a Mentés gombbal, a felette lévő beviteli mező tartalma + .csv néven lemezre menthetjük.

A program futási képe:

A program listája:

unit UUjLatin;

interface

uses
  Windows, Messages, SysUtils, Classes, 

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

type
TfmUjLatin = class(TForm)
lbLatin: TLabel;
btKilep: TButton;
sgLatin: TStringGrid;
edN: TEdit;
btStart: TButton;
lbKezd: TLabel;
lbVeg: TLabel;
btMentes: TButton;
edNev: TEdit;
Procedure Kepre(M: Word);
Procedure Init;
Function Veletlen(M: Word): Boolean;
Procedure Tolto;
procedure btKilepClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure btStartClick(Sender: TObject);
procedure btMentesClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
Const Max=100;
var
fmUjLatin: TfmUjLatin;
  N: Word;
  AT, ET, PT: Array[1..Max, 1..Max] Of Integer;
DNev: String;
FText: Text;

implementation

{$R *.DFM}

Procedure TfmUjLatin.Kepre(M: Word);
Var I: Word;
Begin
With sgLatin Do
For I:= 1 To N Do Cells[I,M]:= IntToStr(ET[M,I]);
End;

Procedure TfmUjLatin.Init;
Var K, L: Word;
Begin
For K:= 1 To N Do For L:= 1 To N Do AT[K,L]:= K;
End;

Function TfmUjLatin.Veletlen(M: Word): Boolean;
Var I, J, K: Word;
Wi, We: Integer;
    U: Integer;
Begin
  U:= 0; Veletlen:= True; PT:= AT;
For I:= 1 To N Do
Begin
Repeat
Wi:= Random(N+1-M)+1;
      Inc(U);
If U>3*N Then
Begin
Veletlen:= False; AT:= PT; Exit;
End;
Until AT[Wi,I]>0;
We:= AT[Wi,I]; AT[Wi,I]:= 0;
For K:= 1 To N+1-M Do For J:= I+1 To N Do
If AT[K,J]=We Then AT[K,J]:= -AT[K,J];
Et[M,I]:=We;
Kepre(M);
End;
For J:= 1 To N Do
Begin
    I:= 1;
While AT[I,J]<>0 Do Inc(I);
For K:= I To N+1-M Do AT[K,J]:= AT[K+1,J];
    AT[N+1-M+1,J]:= 0;
End;
End;

Procedure TfmUjLatin.Tolto;
Var I, J, K: Word;
Begin
For I:= 1 To N Do
Repeat
For K:= 1 To N+1-I Do For J:= 1 To N Do
If AT[K,J]<0 Then AT[K,J]:= -AT[K,J];
Until Veletlen(I);
End;

procedure TfmUjLatin.btKilepClick(Sender: TObject);
begin
Close;
end;

procedure TfmUjLatin.FormCreate(Sender: TObject);
begin
Randomize;
end;

procedure TfmUjLatin.btStartClick(Sender: TObject);
Var I, J: Word;
begin
btStart.Enabled:= False;
lbVeg.Caption:= 'Vég:-              ';
lbVeg.Repaint;
lbKezd.Caption:= 'Kezd:'+TimeToStr(Time);
lbKezd.Repaint;
edNev.Text:= edN.Text;
For I:= 1 To Max Do For J:= 1 To Max Do
Begin AT[I,J]:= 0; ET[I,J]:= 0; PT[I,J]:= 0 End;
With sgLatin Do
Begin
    N:= StrToInt(edN.Text); ColCount:= N+1; RowCount:= N+1;
For I:= 1 To N Do
Begin
Cells[I,0]:= IntToStr(I);
Cells[0,I]:= IntToStr(I);
End;
Init;
Tolto;
End;
btStart.Enabled:= True;
lbVeg.Caption:= 'Vég:'+TimeToStr(Time);
end;

procedure TfmUjLatin.btMentesClick(Sender: TObject);
Var I, J: Word;
begin
DNev:= edNev.Text+'.csv';
AssignFile(FText,DNev); ReWrite(FText);
With sgLatin Do
For I:= 1 To RowCount-1 Do
Begin
For J:= 1 To ColCount-1 Do Write(FText,Cells[J,I],';');
WriteLn(FText);
End;
CloseFile(FText);
end;

end.