A latin négyzet egy
olyan N x N-es számtömb, melynek minden sorában és oszlopában pontosan egyszer
fordul elő minden szám 1-től N-ig. Nevezhetjük véletlen latin négyzetnek azt a
latin négyzetet, amelynek generálását a számítógép véletlen generátorára
bíztuk. A jelen latin négyzet is ilyen.
Generálása úgy történik,
hogy soronként haladva előállítja a számok egy véletlen permutációját, megnézi,
hogy a felette lévőkkel nem ütközik-e, ha nem, akkor áttér a következő sorra,
de ha elég sokszor próbálgatva nem talál megfelelőt, akkor sorokat törölve
visszalép, és újra próbálkozik mindaddig, amíg az utolsó sor is jó nem lesz. Ez
egy igen gyenge algoritmus, egy 10 x 10-e mező feltöltéséhez már több percnyi
gépidő kell még egy gyors (2GHz, két magos) PC esetén is (de ez még mindig
elfogadható sebesség, ahhoz képest, amit valaha a HT1080Z iskola-számítógép
produkált, a maga 3 órájával). Ha az eredmény nem tetszik, vagy rendezgetni
szeretnénk, akkor megtehetjük a jobb oldali beviteli mezők és nyomógombok
segítségével (egyik beviteli mezőbe az egyik, a másikba a másik indexet kell
írni, majd a megfelelő gombbal kiválasztjuk, hogy oszlopot, vagy sort akarunk
cserélni). Mivel teljes sorokat és oszlopokat cserél, a latin-négyzet
tulajdonság megmarad.
A program futási képe:
A program listája:
unit ULatin;
interface
uses
Windows, Messages, SysUtils, Classes,
Graphics, Controls, Forms, Dialogs,
StdCtrls, Grids;
type
TfmLatin = class(TForm)
lbLatin: TLabel;
btKilep: TButton;
sgLatin: TStringGrid;
edN: TEdit;
edCsA: TEdit;
edCsB: TEdit;
btStart: TButton;
btOCsere: TButton;
btSCsere: TButton;
procedure btKilepClick(Sender: TObject);
procedure btStartClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure btOCsereClick(Sender: TObject);
procedure btSCsereClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
Const Max=100;
var
fmLatin: TfmLatin;
N: Word;
T: Array[1..Max,1..Max] Of Word;
V, Vegso: Array[1..Max] Of Word;
Joe: Boolean;
implementation
{$R *.DFM}
Procedure Veletlen(N: Word);
Var Vl: Array[1..Max] Of Boolean;
K,W: Word;
Begin
For K:= 1 To N Do Vl[K]:= False;
For K:= 1 To N Do
Begin
Repeat W:= Random(N)+1 Until Not Vl[W];
Vl[W]:= True; V[K]:= W;
End;
End;
Function Jo(N,M: Word): Boolean;
Var Lp: Boolean;
K,L: Word;
Begin
Lp:= True; For K:= 1 To M-1 Do If Lp Then
For L:= 1 To N Do If V[L]=T[K,L] Then Lp:= False; Jo:= Lp;
End;
procedure TfmLatin.btKilepClick(Sender: TObject);
begin
Close;
end;
procedure TfmLatin.btStartClick(Sender: TObject);
Var I, J, S: Word;
begin
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;
I:= 0;
Repeat
Inc(I);
If I=1 Then
Begin
Veletlen(N);
For J:= 1 To N Do Begin T[I,J]:= V[J]; Cells[J,I]:= IntToStr(V[J]) End;
End;
Joe:= False; S:= 0;
If I>1 Then
Repeat
Veletlen(N); For J:= 1 To N Do Cells[J,I]:= IntToStr(V[J]);
Joe:= Jo(N,I); Inc(S);
If S>10000*I Then Begin Dec(I,2); S:= 0 End;
Until Joe;
For J:= 1 To N Do T[I,J]:= V[J];
Until N=I;
End;
end;
procedure TfmLatin.FormCreate(Sender: TObject);
begin
Randomize;
end;
procedure TfmLatin.btOCsereClick(Sender: TObject);
Var A,B, I: Word;
P: Array[1..Max] Of String;
begin
A:= StrToInt(edCsA.Text);
B:= StrToInt(edCsB.Text);
With sgLatin Do
Begin
For I:= 1 To N Do P[I]:= Cells[A,I];
For I:= 1 To N Do Cells[A,I]:= Cells[B,I];
For I:= 1 To N Do Cells[B,I]:= P[I];
End;
end;
procedure TfmLatin.btSCsereClick(Sender: TObject);
Var A,B, I: Word;
P: Array[1..Max] Of String;
begin
A:= StrToInt(edCsA.Text);
B:= StrToInt(edCsB.Text);
With sgLatin Do
Begin
For I:= 1 To N Do P[I]:= Cells[I,A];
For I:= 1 To N Do Cells[I,A]:= Cells[I,B];
For I:= 1 To N Do Cells[I,B]:= P[I];
End;
end;
end.
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.
Az előző két Latin
négyzet-generáló programokhoz képest ez a program kész meglepetés. A
megengedett maximális oldalméret 100 x 100. Bármilyen oldalméretet is
választunk, a program észrevétlenül gyorsan generál véletlen Latin négyzetet. A
trükk felfedezését érdeklődő olvasóimra bízom. A generált táblázatot itt is
lemezre menthetjük.
A Latin négyzetek nagy
segítséget nyújtanak az egyik kedvelt rejtvény, a Soduku tábláinak
előállításában. Nem lehetetlen, hogy az órarendkészítő programok is használni
tudnak, elég nagy oldalszámú Latin négyzetet.
A program futási képe:
A program listája:
unit ULUjLatin;
interface
uses
Windows, Messages, SysUtils, Classes,
Graphics, Controls, Forms, Dialogs,
StdCtrls, Grids;
type
TfmLUJLatin = class(TForm)
lbLatin: TLabel;
edN: TEdit;
btStart: TButton;
btKilep: TButton;
sgLatin: TStringGrid;
btMentes: TButton;
edNev: TEdit;
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
fmLUJLatin: TfmLUJLatin;
N: Word;
T: Array[1..Max,1..Max] Of Word;
P: Array[1..Max] Of Word;
DNev: String;
FText: Text;
implementation
{$R *.DFM}
procedure TfmLUJLatin.btKilepClick(Sender: TObject);
begin
Close;
end;
procedure TfmLUJLatin.FormCreate(Sender: TObject);
begin
Randomize;
end;
procedure TfmLUJLatin.btStartClick(Sender: TObject);
Var I, J, K, L, PP, M: Word;
begin
N:= StrToInt(edN.Text); If N>Max Then Exit;
edNev.Text:= edN.Text;
For I:= 1 To N Do P[I]:= I; M:= Max+Random(Max);
For I:= 1 To M Do
Begin
K:= Random(N)+1; L:= Random(N)+1;
PP:= P[K]; P[K]:= P[L]; P[L]:= PP;
End;
For I:= 1 To N Do T[I,1]:= P[I];
For J:= 2 To N Do
Begin
For I:= 1 To N-1 Do T[I,J]:= T[I+1,J-1];
T[N,J]:= T[1,J-1];
End;
M:= Max+Random(Max);
For I:= 1 To M Do
Begin
K:= Random(N)+1; L:= Random(N)+1;
For J:= 1 To N Do P[J]:= T[K,J];
For J:= 1 To N Do T[K,J]:= T[L,J];
For J:= 1 To N Do T[L,J]:= P[J];
End;
M:= Max+Random(Max);
For I:= 1 To M Do
Begin
K:= Random(N)+1; L:= Random(N)+1;
For J:= 1 To N Do P[J]:= T[J,K];
For J:= 1 To N Do T[J,K]:= T[J,L];
For J:= 1 To N Do T[J,L]:= P[J];
End;
With sgLatin Do
Begin
ColCount:= N+1; RowCount:= N+1;
For I:= 1 To N Do
Begin
Cells[I,0]:= IntToStr(I);
Cells[0,I]:= IntToStr(I);
End;
For I:= 1 To N Do For J:= 1 To N Do Cells[I,J]:= IntToStr(T[I,J]);
End;
end;
procedure TfmLUJLatin.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.
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.
Sudoku táblák előállítása genetikus
algoritmussal
A Sudoku tábla egy olyan speciális Latin négyzet, ahol
a sor és oszlop szerinti számismétlés tiltása mellett még kisebb, négyzet
(esetleg téglalap) alakú területen sem ismétlődhetnek a számok. A legelterjedtebb
Sudoku táblák négyzetesek.
Ha a generálás alapjául n=2-t választunk, akkor n2
=4 db, 2x2-es négyzetben összesen 16 db számot kell elhelyezni úgy, hogy minden
sorban és oszlopban az 1..4 számok ismétlés nélkül
szerepeljenek, valamint a teljes négyzetet alkotó 4 db 2x2-esben sem lehet
számismétlés. Egy ilyen Sudoku tábla például a következő:
|
3 |
2 |
1 |
4 |
|
4 |
1 |
3 |
2 |
|
2 |
3 |
4 |
1 |
|
1 |
4 |
2 |
3 |
Ha a generálás alapja n=3, akkor n2 =9 db,
3x3-as négyzetben összesen 81 számot kell elhelyezni. A fenti alapelv szerint
egy ilyen Sudoku tábla így néz ki:
|
2 |
7 |
6 |
9 |
1 |
4 |
3 |
8 |
5 |
|
3 |
8 |
1 |
2 |
5 |
7 |
6 |
4 |
9 |
|
5 |
4 |
9 |
6 |
3 |
8 |
1 |
7 |
2 |
|
7 |
6 |
5 |
1 |
4 |
9 |
2 |
3 |
8 |
|
4 |
3 |
2 |
5 |
8 |
6 |
9 |
1 |
7 |
|
9 |
1 |
8 |
7 |
2 |
3 |
4 |
5 |
6 |
|
8 |
5 |
3 |
4 |
9 |
2 |
7 |
6 |
1 |
|
1 |
9 |
7 |
3 |
6 |
5 |
8 |
2 |
4 |
|
6 |
2 |
4 |
8 |
7 |
1 |
5 |
9 |
3 |
Az n=3 esethez tartozó táblatípus a legelterjedtebb,
feladványként leggyakrabban ezzel a típussal találkozhatunk.
Írjunk programot, amely a fentebb bemutatott Sudoku
táblák generálására alkalmas. A program a megoldást genetikus algoritmus
segítségével keresse meg. Az algoritmus során egy generációban az egyedek száma
minimum 30 legyen. A program egy táblázatban jelenítse meg a keresés során épp
legjobbnak talált megoldást. Színezéssel (például zöld háttér), érzékeltesse,
hogy az elrendezésben mely számok ütközésmentesek. A program maximum 10000
generáción keresztül keressen megoldásokat. A generáció bármely egyedét
lehessen a táblán megjeleníteni.
A program futási képe induláskor:
A program futási képe munka közben:
A program futási képe akkor, amikor előállított egy
Sudoku táblát:
A program listája:
unit UGenSudo;
interface
uses
Windows, Messages, SysUtils, Variants, Classes,
Graphics, Controls, Forms, Dialogs, StdCtrls, Grids;
Const EgyedSz=30;
GAl=3;
Max=GAl*GAl;
type
TfmGenSudo = class(TForm)
lbGenSudo: TLabel;
btKilepes: TButton;
sgGenSudo: TStringGrid;
sgTabla: TStringGrid;
lbEgyedSz: TLabel;
lbJosag: TLabel;
edEgyedSz: TEdit;
edJosag: TEdit;
lbJokSz: TLabel;
edJokSz: TEdit;
btUjPop: TButton;
lbKereszt: TLabel;
edKereszt: TEdit;
lbMutacio: TLabel;
edMutacio: TEdit;
btStart: TButton;
lbPopSz: TLabel;
edPopSz: TEdit;
lbSzazalek: TLabel;
lbKesz: TLabel;
edKesz: TEdit;
Label1: TLabel;
edIndex: TEdit;
Procedure PopInit;
Procedure PopKepre;
Procedure Tablara(Ind: Word);
Procedure Vizsgal;
Procedure Keresztez;
Procedure Mutacio;
procedure btKilepesClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure sgGenSudoDrawCell(Sender: TObject; Col, Row: Integer;
Rect: TRect; State: TGridDrawState);
procedure sgGenSudoClick(Sender: TObject);
procedure sgTablaDrawCell(Sender: TObject; Col, Row: Integer;
Rect: TRect; State: TGridDrawState);
procedure btUjPopClick(Sender: TObject);
procedure btStartClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
TSzam=Record
N: Byte;
Jo: Boolean; //true, ha a nincs számütközés
End;
TEgyed=Record
EN: Array[1..Max,1..Max] Of TSzam;
EOK: Byte; //a ütközésben nem álló számok száma
JoEgyed: Boolean; //true, ha az ütközésben állók száma átlag feletti
End;
var
fmGenSudo: TfmGenSudo;
ACol, ARow: Integer;
EgyedT: Array[0..EgyedSz] Of TEgyed;
Tablan: Word; //táblán megjelenített indexe
JokSz: Word; //az átlag feletti egyedek száma
Josag: Real; //a populáció ütközési számainak átlaga
Kereszt: Byte; //a keresztezési index
Uj1, Uj2: TEgyed; //új egyedek
IR1, IR2, IJ1, IJ2: Word; //régi és új egyedek tömbindexei
PopSz: Word; //populációk száma
OKMax, IMax, OldMax, //segédváltozók a populációk generálásánál
MutSz: Word; //mutáció erősségét mutató százalékérték
implementation
{$R *.dfm}
procedure TfmGenSudo.btKilepesClick(Sender: TObject);
begin
Close;
end;
procedure TfmGenSudo.sgGenSudoDrawCell(Sender: TObject; Col,
Row: Integer; Rect: TRect; State: TGridDrawState);
begin
With sgGenSudo.Canvas.Brush Do
Begin
If (gdFixed In State) And ((Col=ACol) Or (Row=ARow)) Then
Color:= clYellow Else Color:=clBtnFace;
If gdSelected In State Then Color:= clRed;
If Not((gdSelected In State) Or (gdFixed In State)) Then
If (Col-1) Mod 18<9 Then Color:= clAqua Else Color:= clWindow;
End;
sgGenSudo.Canvas.TextRect(Rect,Rect.Left+1,Rect.Top,
sgGenSudo.Cells[Col,Row]);
If gdFocused In State Then sgGenSudo.Canvas.DrawFocusRect(Rect);
end;
procedure TfmGenSudo.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 EgyedT[Tablan].EN[Col,Row].Jo Then Color:= clGreen;
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 TfmGenSudo.sgGenSudoClick(Sender: TObject);
begin
PopKepre;
With sgGenSudo Do Begin ACol:= Col; ARow:= Row; RePaint End;
Tablan:= ARow;
Tablara(ARow);
end;
procedure TfmGenSudo.FormCreate(Sender: TObject);
Var I, J: Word;
begin
ACol:= 1; ARow:= 1; Tablan:= 0;
With sgGenSudo Do
Begin
RowCount:= EgyedSz+1;
ColWidths[0]:= 28;
ColWidths[ColCount-1]:= 18;
Cells[ColCount-1,0]:= 'OK';
For I:= 1 To 9 Do For J:= 1 To 9 Do Cells[(I-1)*9+J,0]:= IntToStr(J);
For I:= 1 To EgyedSz Do Cells[0,I]:= IntToStr(I)+'.';
End;
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;
Randomize;
PopInit;
Vizsgal;
PopKepre;
//kezdő és alapértelmezett értékek:
edEgyedSz.Text:= IntToStr(EgyedSz);
PopSz:= 1; edPopSz.Text:= IntToStr(PopSz);
MutSz:= 25; edMutacio.Text:= IntToStr(MutSz);
Kereszt:= Max Div 2; edKereszt.Text:= IntToStr(Kereszt);
end;
Procedure TfmGenSudo.PopInit;
Var I, J, K: Word;
Begin
//egy teljes populáció létrehozása
For K:= 1 To EgyedSz Do With EgyedT[K] Do
Begin
For I:= 1 To Max Do For J:= 1 To Max Do With EN[I,J] Do
Begin N:= Random(Max)+1; Jo:= True End;
EOK:= 0;
JoEgyed:= False;
End;
End;
Procedure TfmGenSudo.PopKepre;
Var I, J, K: Word;
Begin
With sgGenSudo Do
For K:= 1 To EgyedSz Do With EgyedT[K] Do
For I:= 1 To Max Do For J:= 1 To Max Do
Begin
Cells[(J-1)*Max+I,K]:= IntToStr(EN[I,J].N);
Cells[ColCount-1,K]:= IntToStr(EOK);
End;
edPopSz.Text:= IntToStr(PopSz);
End;
Procedure TfmGenSudo.Tablara(Ind: Word);
Var I, J: Word;
Begin
With sgTabla Do With EgyedT[Ind] Do For I:= 1 To Max Do For J:= 1 To Max Do
Cells[I,J]:= IntToStr(EN[I,J].N); Tablan:= Ind;
End;
Procedure TfmGenSudo.Keresztez;
Var I, V, R: Word;
Begin
Inc(PopSz);
//a két legrosszabb egyed keresése
V:= Random(EgyedSz)+1; R:= Max*Max; IR1:= 0;
For I:= V+1 To EgyedSz Do With EgyedT[I] Do
If Not JoEgyed And (EOK<R) Then Begin R:= EOK; IR1:= I End;
For I:= 1 To V Do With EgyedT[I] Do
If Not JoEgyed And (EOK<R) Then Begin R:= EOK; IR1:= I End;
V:= Random(EgyedSz)+1; R:= Max*Max; IR2:= 0;
For I:= V+1 To EgyedSz Do With EgyedT[I] Do If I<>IR1 Then
If Not JoEgyed And (EOK<R)Then Begin R:= EOK; IR2:= I End;
For I:= 1 To V Do With EgyedT[I] Do If I<>IR1 Then
If Not JoEgyed And (EOK<R) Then Begin R:= EOK; IR2:= I End;
//két jó egyed keresése:
//nem a két legjobbat, mert akkor nem lenne eléggé nagy a változatosság
V:= Random(EgyedSz)+1; IJ1:= 0;
For I:= V+1 To EgyedSz Do With EgyedT[I] Do If JoEgyed Then IJ1:= I;
For I:= 1 To V Do With EgyedT[I] Do If JoEgyed Then IJ1:= I;
V:= Random(EgyedSz)+1; IJ2:= 0;
For I:= V+1 To EgyedSz Do With EgyedT[I] Do If I<>IJ1 Then
If JoEgyed Then IJ2:= I;
For I:= 1 To V Do With EgyedT[I] Do If I<>IJ1 Then
If JoEgyed Then IJ2:= I;
//két jó egyed keresztezése -> Uj1, Uj2: TEgyed
If IJ1*IJ2<>0 Then
Begin
For I:= 1 To Kereszt Do Uj1.EN[I]:= EgyedT[IJ1].EN[I];
For I:= Kereszt+1 To Max Do Uj1.EN[I]:= EgyedT[IJ2].EN[I];
For I:= 1 To Kereszt Do Uj2.EN[I]:= EgyedT[IJ2].EN[I];
For I:= Kereszt+1 To Max Do Uj2.EN[I]:= EgyedT[IJ1].EN[I];
End;
End;
Procedure TfmGenSudo.Mutacio;
Var I, J, K: Word;
Begin
//a populáció minden egyedét MutSz valószínűséggel
//módosítjuk egy véletlen értékre
For K:= 1 To EgyedSz Do With EgyedT[K] Do
For I:= 1 To Max Do For J:= 1 To Max Do With EN[I,J] Do If Not Jo Then
If Random(100)<MutSz Then N:= Random(Max)+1;
End;
Procedure TfmGenSudo.Vizsgal;
Var I, J, K, L, P, Q, Sz: Word;
Utkozik: Boolean;
Begin
//a populáció vizsgálata
//megállapítja minden számról, hogy ütközésben van-e (-> Utkozik)
//megállapítja minden egyedről, hogy hány szám elhelyezkedése jó (-> Jo)
JokSz:= 0; OKMax:= 0;
For K:= 1 To EgyedSz Do With EgyedT[K] Do
Begin
Sz:= 0;
For I:= 1 To Max Do For J:= 1 To Max Do
Begin
Utkozik:= False;
//sor ütközés
For L:= 1 To Max Do If (L<>I) And (EN[L,J].N=EN[I,J].N) Then
Begin EN[I,J].Jo:= False; Utkozik:= True End;
//oszlop ütközés
If Not Utkozik Then
For L:= 1 To Max Do If (L<>J) And (EN[I,L].N=EN[I,J].N) Then
Begin EN[I,J].Jo:= False; Utkozik:= True End;
//területi ütközés (e nélkül latin négyzet)
If Not Utkozik Then
For P:= I-((I-1) Mod GAl) To I-((I-1) Mod GAl)+GAl-1 Do
For Q:= J-((J-1) Mod GAl) To J-((J-1) Mod GAl)+GAl-1 Do
If Not ((P=I) And (Q=J)) And (EN[P,Q].N=EN[I,J].N) Then
Begin EN[I,J].Jo:= False; Utkozik:= True End;
EN[I,J].Jo:= Not Utkozik;
If Not Utkozik Then Inc(Sz);
End;
EOK:= Sz; If EOK>OKMax Then Begin OKMax:= EOK; IMax:= K End;
Inc(JokSz,EOK);
End;
//megállapítja a populáció jóságát:
//az ütközésben nem lévő számok számának átlaga-> Josag
Josag:= JokSz/EgyedSz;
edJosag.Text:= FloatToStr(Josag);
//minden egyedről megállapítja, hogy jó-e:
//átlag feletti az ütközésben nem álló számok száma -> JoEgyed:= True
JokSz:= 0;
For K:= 1 To EgyedSz Do With EgyedT[K] Do If EOK>Josag Then
Begin
Inc(JokSz);
JoEgyed:= True;
End Else JoEgyed:= False;
edJokSz.Text:= IntToStr(JokSz);
End;
procedure TfmGenSudo.btUjPopClick(Sender: TObject);
Var I, J: Word;
begin
//új populáció generálása
Tablan:= 0;
With sgTabla Do
For I:= 1 To ColCount-1 Do For J:= 1 To RowCount-1 Do Cells[I,J]:= '';
PopInit;
Vizsgal;
PopKepre;
PopSz:= 1; edPopSz.Text:= IntToStr(PopSz);
end;
procedure TfmGenSudo.btStartClick(Sender: TObject);
Var I, J: Word;
begin
//populációk generálása és vizsgálata
OKMax:= 0; IMax:= 0; PopSz:= 1;
Repeat
OldMax:= OKMax;
Keresztez;
If (JokSz<=GAl) Or (EgyedSz-JokSz<=GAl) Then Mutacio Else
If (IR1*IR2<>0) And (IJ1*IJ2<>0) Then
Begin
EgyedT[IR1]:= Uj1;
EgyedT[IR2]:= Uj2;
End
Else Mutacio;
Vizsgal;
PopKepre; //sgGenSudo.Repaint;
edPopSz.Repaint;
If OKMax>OldMax Then
Begin
sgGenSudo.Repaint;
edKesz.Text:= IntToStr(OKMax); edKesz.Repaint;
edIndex.Text:= IntToStr(IMax); edIndex.Repaint;
Tablara(IMax); sgTabla.Repaint;
End;
Until (OKMax>=Max*Max) Or (PopSz>10000);
//max*max értékig, vagy maximum 10000 generációig keresünk
If OKMax=Max*Max Then
For I:= 1 To Max Do For J:= 1 To Max Do EgyedT[IMax].EN[I,J].Jo:= False;
sgGenSudo.Repaint;
edKesz.Text:= IntToStr(OKMax); edKesz.Repaint;
edIndex.Text:= IntToStr(IMax); edIndex.Repaint;
Tablara(IMax); sgTabla.Repaint;
end;
end.
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.
Sudoku feladvány megoldása Backtrack
algoritmussal
Ez a program Sudoku feladványok megoldásra alkalmas. A
használt algoritmus a Backtrack. Csak egyetlen megoldást keres, és ha a
feladvány megoldható, akkor talál is. Alapértelmezésben ez így helyes is, mert
minden feladványnak csak egyetlen megoldása lehetséges.
A
következő lehetőségeket kínálja a program:
-
a megjelenített táblára magunk beírhatjuk a megoldandó feladványt,
-
a beírt számokat rögzíthetjük, mely piros színnel jelenik meg,
-
a már rögzített számok kézzel sem írhatók át,
-
megtehetjük, hogy magunk próbáljuk megoldani a feladványt,
-
a kézi megoldás keresése közben a gép folyamatosan ellenőrzi, hogy az épp beírt
szám beírható-e, ha igen akkor megmarad a mezőben, ha nem a gép automatikusan
törli azt,
-
a feladvány megoldását a gépre is bízhatjuk, melyet a Backtrack algoritmus
segítségével keres,
-
a gépi megoldás közben, ha ezt a Megjelenít
jelölőnézettel kérjük, lépésenként megjeleníti a keresési állapotokat,
-
a gép kijelzi a keresés kezdő és befejező időpontját,
-
ha sikerül a feladványt megoldani, akkor Kész felirat jelenik meg, ha nem akkor
Vége,
-
a gép maximum 1 millió lépésig keres megoldásokat, és minden ezredik lépésben
megjeleníti az aktuális állapotot a képernyőn,
-
ha kedvünk van, véletlen feladványt kérhetünk a géptől, de ezek nem igazi Sudoku
feladványok lesznek, lehet, hogy meg sem oldhatók, de az is lehet, hogy több
megoldása is van, ami ugye nem szabályos.
A
program indulási képe:
A
futási kép gépi generálás előtt:
Az
elkészült megoldás:
A
program listája:
unit USudokuBTr;
interface
uses
Windows, Messages, SysUtils, Variants, Classes,
Graphics, Controls, Forms,
Dialogs, StdCtrls, Grids, ExtCtrls;
Const GAl=3;
Max=GAl*GAl;
LMax=1000000;
type
TfmSudokuBTr = class(TForm)
lbSudokuBTr: TLabel;
btKilepes: TButton;
sgTabla: TStringGrid;
btStart: TButton;
tiIdozito: TTimer;
cbMegjelenit: TCheckBox;
btTorles: TButton;
edIndex: TEdit;
edStart: TEdit;
edStop: TEdit;
lbKesz: TLabel;
edLepes: TEdit;
btRandom: TButton;
btRogzit: TButton;
Procedure Vizsgal;
Function Utkozik(H: Word): Boolean;
procedure btKilepesClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure sgTablaDrawCell(Sender: TObject; Col, Row: Integer;
Rect: TRect; State: TGridDrawState);
procedure btStartClick(Sender: TObject);
procedure tiIdozitoTimer(Sender: TObject);
procedure btTorlesClick(Sender: TObject);
procedure btRandomClick(Sender: TObject);
procedure btRogzitClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
fmSudokuBTr: TfmSudokuBTr;
SB, SC: Array[1..Max*Max] Of Word;
Lepes: LongInt;
Keres: Boolean;
implementation
{$R *.dfm}
procedure TfmSudokuBTr.btKilepesClick(Sender: TObject);
begin
Close;
end;
procedure TfmSudokuBTr.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 (gdSelected In State) Then Color:= clYellow;
End;
With sgTabla.Canvas.Font Do If SC[(Row-1)*Max+Col]=0 Then
Color:= clBlack Else Color:= clRed;
sgTabla.Canvas.TextRect(Rect,Rect.Left+16,Rect.Top+4,
sgTabla.Cells[Col,Row]);
If gdFocused In State Then sgTabla.Canvas.DrawFocusRect(Rect);
end;
procedure TfmSudokuBTr.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;
Keres:= False;
end;
procedure TfmSudokuBTr.btRogzitClick(Sender: TObject);
begin
SC:= SB; sgTabla.Repaint;
end;
procedure TfmSudokuBTr.btTorlesClick(Sender: TObject);
Var I, J: Word;
begin
For I:= 1 To Max*Max Do Begin SB[I]:= 0; SC[I]:= 0 End;
For I:= 1 To Max Do For J:= 1 To Max Do sgTabla.Cells[I,J]:= '';
edIndex.Text:= ''; edLepes.Text:= '';
edStart.Text:= ''; edStop.Text:= '';
lbKesz.Visible:= False;
end;
Procedure TfmSudokuBTr.Vizsgal;
Var Kod: Integer;
Begin
With sgTabla Do If Cells[Col,Row]<>'' Then
Begin
Val(Cells[Col,Row][1],SB[(Row-1)*Max+Col],Kod);
If (SC[(Row-1)*Max+Col]<>0) And
(SC[(Row-1)*Max+Col]<>SB[(Row-1)*Max+Col]) Then
Begin
SB[(Row-1)*Max+Col]:= SC[(Row-1)*Max+Col];
Cells[Col,Row]:= IntToStr(SB[(Row-1)*Max+Col]);
End;
If Utkozik((Row-1)*Max+Col) Then
Begin SB[(Row-1)*Max+Col]:= 0; Cells[Col,Row]:= '' End
End;
End;
procedure TfmSudokuBTr.tiIdozitoTimer(Sender: TObject);
begin
If Keres Then Exit; Vizsgal;
end;
Function TfmSudokuBTr.Utkozik(H: Word): Boolean;
Var A, B, I, J, K: Word;
Ut: Boolean;
Begin
Ut:= False;
A:= H-((H-1) Mod Max); B:= H+Max-1-((H-1) Mod Max);
For I:= A To B Do
If (SB[H]<>0) And (I<>H) And (SB[H]=SB[I]) Then
Begin Ut:= True; Break End;
If Not Ut Then
Begin
I:= 1+(H-1) Mod Max;
While I<Max*Max Do
Begin If (I<>H) And (SB[H]=SB[I]) Then Ut:= True; Inc(I,Max) End;
End;
If Not Ut Then
Begin
K:= GAl*Max*((H-1) Div (Gal*Max))+GAl*(((H-1) Mod Max) Div GAl)+1;
For J:= 1 To Gal Do For I:= K+(J-1)*Max To K+(J-1)*Max+Gal-1 Do
If (I<>H) And (SB[H]=SB[I]) Then Begin Ut:= True; Break End;
End;
Utkozik:= Ut;
End;
procedure TfmSudokuBTr.btStartClick(Sender: TObject);
Var I: Word;
begin
Keres:= True;
edStart.Text:= TimeToStr(GetTime); edStart.Repaint;
edStop.Text:= ''; edStop.Repaint;
SC:= SB; sgTabla.Repaint;
I:= 1; Lepes:= 0;
While (I In [1..Max*Max]) And (Lepes<=LMax) Do
Begin
Inc(Lepes);
If Lepes Mod 1000=0 Then
Begin
edIndex.Text:= IntToStr(I);
edLepes.Text:= IntToStr(Lepes);
RePaint;
End;
While SC[I]<>0 Do Inc(I);
Inc(SB[I]);
With sgTabla Do
Begin
If SB[I]<>0 Then Cells[(I-1) Mod Max+1,(I-1) Div Max+1]:= IntToStr(SB[I])
Else Cells[(I-1) Mod Max+1,(I-1) Div Max+1]:= '';
If cbMegjelenit.Checked Then Repaint;
End;
If SB[I]>Max Then
Begin
SB[I]:= 0;
With sgTabla Do
Begin
Cells[(I-1) Mod Max+1,(I-1) Div Max+1]:= '';
If cbMegjelenit.Checked Then Repaint;
End;
Dec(I); While SC[I]<>0 Do Dec(I);
End Else
With sgTabla Do If Not Utkozik(I) Then
Begin
If SB[I]<>0 Then
Cells[(I-1) Mod Max+1,(I-1) Div Max+1]:= IntToStr(SB[I])
Else Cells[(I-1) Mod Max+1,(I-1) Div Max+1]:= '';
If cbMegjelenit.Checked Then Repaint;
Inc(I);
End;
End;
edIndex.Text:= IntToStr(I);
edLepes.Text:= IntToStr(Lepes);
Keres:= False;
edStop.Text:= TimeToStr(GetTime);
With lbKesz Do
Begin
If I=Max*Max+1 Then Caption:= 'Kész' Else Caption:= 'Vége';
Visible:= True;
End;
end;
procedure TfmSudokuBTr.btRandomClick(Sender: TObject);
Var I, H: Word;
begin
btTorlesClick(Sender);
With sgTabla Do
For I:= 1 To 60 Do
Begin
H:= Random(Max*Max)+1; SB[H]:= Random(Max)+1;
Col:= ((H-1) Mod Max)+1;
Row:= ((H-1) Div Max)+1;
Cells[Col,Row]:= IntToStr(SB[H]);
Vizsgal;
End;
end;
end.