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.