Sudoku tábla előállítása ütközésmentesítő algoritmussal

A véletlen Latin négyzet előállításának negyedik verziójában alkalmazott ütközésmentesítő algoritmust alkalmazzuk Sudoku táblák előállítására.

A tapasztalat azt mutatja, hogy az ütközésmentesítéshez a legtöbb esetben nem elegendő két elemet kiválasztani. Ha viszont hármas elemcserét alkalmazunk, akkor olyan algoritmust kapunk, mely egyrészt nagyon gyors (a futási idő soha nem volt nagyobb, mint két másodperc) és mindig végeredményt adott, vagyis még nem sikerült egyetlen olyan esetet sem találni, amikor nem tudta volna befejezni a tábla generálását. Mivel a fejlesztést a kételemes cserékkel kezdtem, ennek a kipróbálása is lehetőség van a Rendez-2 nyomógomb segítségével. A tuti végeredményt természetesen a Rendez-3 nyomógomb szolgáltatja.

A program generálás előtti futási képe (fehér és cián alapszín az ütközésmentes, zöld alapszín az ütközéses mezőket jelenti):

Valamint a hármas cserét alkalmazó generálás után:

A program listája:

unit USudoUtk;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, 

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

Const GAl=3;
      Max=GAl*GAl;
type
  TfmSudoUtk = class(TForm)
    lbSudoUtk: TLabel;
    btKilepes: TButton;
    sgTabla: TStringGrid;
    btInit: TButton;
    lbMaxMenet: TLabel;
    edMaxMenet: TEdit;
    btRendez3: TButton;
    edMenet: TEdit;
    edUtOSz: TEdit;
    edStart: TEdit;
    edStop: TEdit;
    lbKesz: TLabel;
    btRendez2: TButton;
Procedure Init;
Procedure Tablara;
Function UTSz(O, S: Word): Word;
Procedure Utkozesek;
procedure btKilepesClick(Sender: TObject);
procedure sgTablaDrawCell(Sender: TObject; Col, Row: Integer;
      Rect: TRect; State: TGridDrawState);
procedure FormCreate(Sender: TObject);
procedure btInitClick(Sender: TObject);
procedure edMaxMenetChange(Sender: TObject);
procedure btRendez3Click(Sender: TObject);
procedure btRendez2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
  fmSudoUtk: TfmSudoUtk;
  SUD, UTT: Array[1..Max,1..Max] Of Word;
  MaxMenet, Menet, UTOsz: LongInt;

implementation

{$R *.dfm}

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

procedure TfmSudoUtk.sgTablaDrawCell(Sender: TObject; Col, Row: Integer;
  Rect: TRect; State: TGridDrawState);
begin
With sgTabla.Canvas.Brush Do
Begin
If Not((gdSelected In State) Or (gdFixed In State)) Then
If Odd(((Col-1) Div GAl)+((Row-1) Div GAl)) Then
    Color:= clAqua Else Color:= clWindow;
If UTT[Col,Row]>0 Then Color:= clLime;
End;
  sgTabla.Canvas.TextRect(Rect,Rect.Left+11,Rect.Top+2,
                            sgTabla.Cells[Col,Row]);
If gdFocused In State Then sgTabla.Canvas.DrawFocusRect(Rect);
end;

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

procedure TfmSudoUtk.FormCreate(Sender: TObject);
begin
  Randomize;
With sgTabla Do
Begin
    ColCount:= Max+2;
    RowCount:= Max+2;
    ColWidths[0]:= 0;
    RowHeights[0]:= 0;
    ColWidths[ColCount-1]:= 0;
    RowHeights[RowCount-1]:= 0;
    Col:= ColCount-1;
    Row:= RowCount-1;
End;
  Init;
  Tablara;
  MaxMenet:= 100000;
end;

Procedure TfmSudoUtk.Init;
Var I, J, A, B, P: Word;
Begin
For I:= 1 To Max Do For J:= 1 To Max Do SUD[I,J]:= I;
For I:= 1 To Max Do For J:= 1 To 10000 Do
Begin
    A:= Random(Max)+1; B:= Random(Max)+1;
    P:= SUD[A,I]; SUD[A,I]:= SUD[B,I]; SUD[B,I]:= P;
End;
  Menet:= 0;
  Utkozesek;
  edMenet.Text:= IntToStr(Menet);
  edUtOSz.Text:= IntToStr(UTOSz);
End;

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

procedure TfmSudoUtk.btInitClick(Sender: TObject);
begin
  Init; Tablara;
end;

Function TfmSudoUtk.UTSz(O, S: Word): Word;
Var I, N, P, Q: Word;
Begin
  N:= 0;
For I:= 1 To Max Do If (I<>O) And (SUD[I,S]=SUD[O,S]) Then Inc(N);
For I:= 1 To Max Do If (I<>S) And (SUD[O,I]=SUD[O,S]) Then Inc(N);
For P:= O-((O-1) Mod GAl) To O-((O-1) Mod GAl)+GAl-1 Do
For Q:= S-((S-1) Mod GAl) To S-((S-1) Mod GAl)+GAl-1 Do
If Not ((P=O) And (Q=S)) And (SUD[P,Q]=SUD[O,S]) Then Inc(N);
  UTSz:= N;
End;

Procedure TfmSudoUtk.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,J); Inc(UTOSz,UTT[I,J]) End;
End;

procedure TfmSudoUtk.btRendez2Click(Sender: TObject);
Var X1, Y1, X2, Y2, P, A, B: 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); Utkozesek; A:= UTOSz;
    X1:= 1; Y1:= 1;
While UTT[X1,Y1]=0 Do Begin X1:= Random(Max)+1; Y1:= Random(Max)+1 End;
    X2:= Random(Max)+1; Y2:= Random(Max)+1;
    P:= SUD[X1,Y1]; SUD[X1,Y1]:= SUD[X2,Y2]; SUD[X2,Y2]:= P;
    Utkozesek; B:= UTOSz;
If B>A Then
Begin P:= SUD[X2,Y2]; SUD[X2,Y2]:= SUD[X1,Y1]; SUD[X1,Y1]:= P 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;

procedure TfmSudoUtk.btRendez3Click(Sender: TObject);
Var X1, Y1, X2, Y2, X3, Y3, P, A, B: 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); Utkozesek; A:= UTOSz; X1:= 1; Y1:= 1;
While UTT[X1,Y1]=0 Do Begin X1:= Random(Max)+1; Y1:= Random(Max)+1 End;
    X2:= Random(Max)+1; Y2:= Random(Max)+1;
    X3:= Random(Max)+1; Y3:= Random(Max)+1;
    P:= SUD[X1,Y1]; SUD[X1,Y1]:= SUD[X2,Y2];
    SUD[X2,Y2]:= SUD[X3,Y3]; SUD[X3,Y3]:= P;
    Utkozesek; B:= UTOSz;
If B>A Then
Begin
P:= SUD[X3,Y3]; SUD[X3,Y3]:= SUD[X2,Y2];
      SUD[X2,Y2]:= SUD[X1,Y1]; SUD[X1,Y1]:= P;
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.