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 n² =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 n² =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.