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

  GraphicsControlsFormsDialogs, StdCtrlsGrids;

type
  TfmUjLatin = class(TForm)
    lbLatinTLabel;
    btKilepTButton;
    sgLatinTStringGrid;
    edNTEdit;
    btStartTButton;
    lbKezdTLabel;
    lbVegTLabel;
    btMentesTButton;
    edNevTEdit;
    Procedure Kepre(M: Word);
    Procedure Init;
    Function Veletlen(M: Word): Boolean;
    Procedure Tolto;
    procedure btKilepClick(SenderTObject);
    procedure FormCreate(SenderTObject);
    procedure btStartClick(SenderTObject);
    procedure btMentesClick(SenderTObject);
  private
    Private declarations }
  public
    Public declarations }
  end;
Const Max=100;
var
  fmUjLatinTfmUjLatin;
  N: Word;
  AT, ET, PT: Array[1..Max, 1..Max] Of Integer;
  DNevString;
  FTextText;

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;
    WiWe: 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(SenderTObject);
begin
  Close;
end;

procedure TfmUjLatin.FormCreate(SenderTObject);
begin
  Randomize;
end;

procedure TfmUjLatin.btStartClick(SenderTObject);
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(SenderTObject);
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.