Órarendkészítés genetikus algoritmussal

A Gépi órarendkészítő demonstrációs program menüpontban alkalmazott, géppel generált tantárgyfelosztáshoz írjunk órarendkészítő programot, mely a genetikus algoritmust használja. Emlékeztetőül: az osztályok száma 32, minden osztálynak 30 órája van (egy 5-órás, két 4-órás, három 3-órás és négy 2-órás tantárgyakkal - a teljes intézményre nézve ez 960 óra), a pedagógusok száma 50, egy tanár egy osztályban csak egy tantárgyat tanít, egy pedagógusnak maximum 26 órája lehet. A program nem tart nyilván tantárgyakat és tantermeket.

Az így előállított órarend szintén nem lesz a gyakorlatban használható. A programnak nem is ez a célja, hanem tesztelni a genetikus algoritmust órarend-készítési feladatra. Az említett menüpontbeli programnál ez a program többet követel meg, és mint láthatjuk, teljesít is az elkészült órarendre vonatkozóan, éspedig: kétórás tárgyat nem tesz két egymás utáni napra.

A genetikus algoritmust akkor célszerű használni, ha a probléma megoldására nem létezik egyszerű keresési eljárás többek között épp azért nem, mert a keresési tér nagyon nagyszámú elemet tartalmaz, melynek bejárása gyakorlatilag lehetetlen. Órarendkészítésnél pedig éppen ez a helyzet. Genetikus algoritmusban a keresés alapja a véletlen választás, majd a generációnkénti vizsgálat, minősítés mely a keresztezésnek és a mutációnak az alapja, melyek szintén véletlen választásokat használnak.

A program a genetikus algoritmusok alapelvét alkalmazva, először generál egy teljes populációt, az órarendeket véletlenül feltöltve. A populáció egyedszáma 50. Az órarendek alapján a program egy ütközési táblát készít, melyben a nem 0 elemeknek a száma, az egyed fitnesz értéke lesz. Cél a 960-as fitnesz érték elérése.

A program a genetikus algoritmus alapelvei szerint keres két átlagosnál nagyobb fitnesz értékű egyedet, melyeket egy keresztezési ponttal keresztez (160-as indexnél) és a két leggyengébb elemet ezekkel helyettesíti. Ezt mindaddig ismétli, amíg a jók száma nagyon alacsony vagy nagyon magas lesz, mert ekkor egy 3 tized százalékos teljes mutációt hajt végre, a jókra vonatkozóan egy 10 mutációs rátával.

A program paraméterei, kezelése. Először generálnunk kell egy új tantárgyfelosztást. Majd beállítjuk a szükséges egyedszámot. Kísérleteim szerint ezt 30 és 100 között célszerű megválasztani. Alacsonyabb egyedszám esetén, a generálás elején gyorsabban haladhatunk, de ekkor a végén lassabb az előrejutás. Magasabb egyedszám esetén pontosan fordítva: először lassúbb, majd később relatíve gyorsabb az újabb jó megoldás megtalálása. Célszerűbb az utóbbit választani, hiszen a generálás a vége felé a kezdeti ütemnek csak töredéke (tízezred, százezred része). Én konkrétan, szem előtt tartva a gépem teljesítményét, a legtöbb teszt esetén 50 egyedszámmal futtattam a programot.

A generálás végének gyorsítása, azaz a megoldás megtalálási idejének csökkentése végett, az algoritmus a túl lassú konvergálás esetére egy perturbációt (egy relatíve erős véletlen mutációt) használ, mely tapasztalataim szerint segít átlendíteni a keresést a dermedési pontokon. Ezek után előállíthatunk egy új populációt. További beállítási lehetőségek: módosíthatjuk az alapértelmezett mutációs értékeket, a keresztezési számot. Meghatározhatjuk a populációk maximális számát, mint korlátozó értéket arra az esetre, ha a végén az algoritmus kényelmetlenül hosszú ideig keresgélne.

A továbbiakban lássunk néhány eredményt. A legfontosabb korlátozó beállítás a megengedett óra-időpontok. A következő táblázat a különböző időpontokra a kezdeti populációk körülbelüli fitnesz értékeit tartalmazza.

Óra-időpontok	Átlagos fitnesz érték
0.-9.	740
1.-9.	720
1.-8.	695
1.-7.	660
1.-6.	625

Ezen fitnesz értékeknek a 960-ra való feljuttatása, az egyre kisebb megengedett napi óraszám mellett, egyre nehezebb. Lássuk ezt is táblázatosan.

Óra-időpontok	Átlagos populációszám	Átlagos generálási idő
0.-9.	9.000	10 sec
1.-9.	12.000	12 sec
1.-8.	40.000	40 sec
1.-7.	90.000	1 perc
1.-6.	3.200.000	30 perc

A következő screenshot-okon egy-egy futási kép látható. Középen az elkészített órarend. A jobboldali listadobozban az egyedek fitnesz értékei, alul a beviteli mezők és kezelő gombok találhatók. A program méri és kiírja a futási időt.

Először a 0.-9. órarendi órák esetén:

Az 1.-9. órarendi órák esetén:

Az 1.-8. órarendi órák esetén:

Az 1.-7. órarendi órák esetén:

Végül pedig az 1.-6. órarendi órák esetén egy futási kép, ami legtöbb esetben a legfontosabb cél. Itt minden osztály minden órája főhelyre kerül. Nincs egyetlen osztálynak sem lyukasórája és nincs hetedik vagy későbbi sem.

A program listája:

unit UGenOR;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, 

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

Const OSz=32;
      EOSz=320;
      PSz=50;
      GAl=5;
      EgyedSzM=100;
type
  TfmGenOR = class(TForm)
    lbGenOR: TLabel;
    btKilepes: TButton;
    sgGenOR: TStringGrid;
    btUjTF: TButton;
    btUjPop: TButton;
    lbEOra: TLabel;
    edEOra: TEdit;
    lbUOra: TLabel;
    edUOra: TEdit;
    ldPop: TListBox;
    lbEgyedSz: TLabel;
    edEgyedSz: TEdit;
    lbKereszt: TLabel;
    edKereszt: TEdit;
    lbMutSz: TLabel;
    edMutSz: TEdit;
    lbPopMaxSz: TLabel;
    edPopMaxSz: TEdit;
    lbPopJosag: TLabel;
    edPopJosag: TEdit;
    lbJoEgyedSz: TLabel;
    edJoEgyedSz: TEdit;
    btStart: TButton;
    lbPopSz: TLabel;
    edPopSz: TEdit;
    lbKesz: TLabel;
    edKesz: TEdit;
    lbIndex: TLabel;
    edIndex: TEdit;
    lbMutRata: TLabel;
    edMutR: TEdit;
    edStart: TEdit;
    edStop: TEdit;
    edPopInd: TEdit;
Procedure PopInit;
Procedure Josaga(E: Word);
Procedure Vizsgal;
Procedure Keresztez;
Procedure Mutacio;
procedure btKilepesClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure edEOraChange(Sender: TObject);
procedure edUOraChange(Sender: TObject);
procedure edMutSzChange(Sender: TObject);
procedure edMutRChange(Sender: TObject);
procedure edEgyedSzChange(Sender: TObject);
procedure edKeresztChange(Sender: TObject);
procedure edPopMaxSzChange(Sender: TObject);
procedure btUjTFClick(Sender: TObject);
procedure btUjPopClick(Sender: TObject);
procedure ldPopClick(Sender: TObject);
procedure sgGenORDrawCell(Sender: TObject; Col, Row: Integer;
      Rect: TRect; State: TGridDrawState);
procedure sgGenORClick(Sender: TObject);
procedure btStartClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

  St1=String[1];
  St3=String[3];

  TPTF=Record
    PRov: St1;
    PTFe: Array[1..OSz] Of Word;
End;

  TOra=Record
    OSzam: Byte;
    ORend: Array[1..5,0..9] Of Byte;
End;

  TEgyed=Record
    EOR: Array[1..EOSz] Of TOra;
    EOM: Array[1..OSz,1..5,0..9] Of Byte;
    EOK: Word;
    EJo: Boolean;
End;

Const POMax= 26;
      Oszt: Array[1..Osz] Of St3=
            ('1.a','1.b','1.c','1.d','1.e','1.f','1.g','1.h',
             '2.a','2.b','2.c','2.d','2.e','2.f','2.g','2.h',
             '3.a','3.b','3.c','3.d','3.e','3.f','3.g','3.h',
             '4.a','4.b','4.c','4.d','4.e','4.f','4.g','4.h');
      PedN: String[PSz]= 'ABCDEFGHIJKLMNOPQRSTUVWXYabcdefghijklmnopqrstuvwxy';
      HetN= 'HKSCP';

var
  fmGenOR: TfmGenOR;
  ACol, ARow: Integer;
  PTF: Array[1..PSz] Of TPTF;
  EgyedT: Array[1..EgyedSzM] Of TEgyed;
  Uj1, Uj2: TEgyed;
  EOra, UOra, EgyedSz, MutSz, MutR, Kereszt: Word;
  JokSz, IR1, IR2, IJ1, IJ2, OKMax, IMax, OldMax: Word;
  OsszJo, PopSz, PopMax, PopMaxSz, OldPopSz: LongInt;
  Josag: Real;

implementation

{$R *.dfm}

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

procedure TfmGenOR.sgGenORDrawCell(Sender: TObject; Col, Row: Integer;
  Rect: TRect; State: TGridDrawState);
begin
With sgGenOR.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:= clLime;
If Not((gdSelected In State) Or (gdFixed In State)) Then
If (Col+8) Mod 10<6 Then Color:= clAqua Else Color:= clWindow;
End;
  sgGenOR.Canvas.TextRect(Rect,Rect.Left+1,Rect.Top+1,sgGenOR.Cells[Col,Row]);
With sgGenOR Do If gdFocused In State Then Canvas.DrawFocusRect(Rect);
end;

procedure TfmGenOR.sgGenORClick(Sender: TObject);
begin
With sgGenOR Do Begin ACol:= Col; ARow:= Row; RePaint End;
end;

procedure TfmGenOR.FormCreate(Sender: TObject);
Var I, J: Word;
begin
  Randomize; ACol:= 1; ARow:= 1;
For I:= 1 To PSz Do PTF[I].PRov:= PedN[I];
  EOra:= 1; UOra:= 7; MutSz:= 3; MutR:= 10;
  EgyedSz:= 50; Kereszt:= 160; PopMaxSz:= 10000000;
With sgGenOR Do
Begin
    ColWidths[0]:= 21; ColWidths[ColCount-1]:= 21;
For I:= 1 To OSz Do Cells[0,I]:= Oszt[I];
For I:= 1 To 5 Do For J:= 0 To 9 Do
    Cells[(I-1)*10+J+1,0]:= HetN[I]+IntToStr(J);
End;
end;

procedure TfmGenOR.edEOraChange(Sender: TObject);
Var Kod: Integer;
begin
  Val(edEOra.Text,EOra,Kod);
end;

procedure TfmGenOR.edUOraChange(Sender: TObject);
Var Kod: Integer;
begin
  Val(edUOra.Text,UOra,Kod);
end;

procedure TfmGenOR.edMutSzChange(Sender: TObject);
Var Kod: Integer;
begin
  Val(edMutSz.Text,MutSz,Kod);
end;

procedure TfmGenOR.edMutRChange(Sender: TObject);
Var Kod: Integer;
begin
  Val(edMutR.Text,MutR,Kod);
end;

procedure TfmGenOR.edEgyedSzChange(Sender: TObject);
Var Kod: Integer;
begin
  Val(edEgyedSz.Text,EgyedSz,Kod);
end;

procedure TfmGenOR.edKeresztChange(Sender: TObject);
Var Kod: Integer;
begin
  Val(edKereszt.Text,Kereszt,Kod);
end;

procedure TfmGenOR.edPopMaxSzChange(Sender: TObject);
Var Kod: Integer;
begin
  Val(edPopMaxSz.Text,PopMaxSz,Kod);
end;

procedure TfmGenOR.btUjTFClick(Sender: TObject);
Var I, J, K, L, N, P, S: Word;
begin
  btStart.Enabled:= False;
For I:= 1 To PSz Do For J:= 1 To OSz Do PTF[I].PTFe[J]:= 0;
For I:= 1 To OSz Do For J:= 1 To 4 Do For K:= 1 To J Do
Begin
Repeat
      P:= Random(PSz)+1; N:= 0; For L:= 1 To OSz Do Inc(N,PTF[P].PTFe[L]);
Until (PTF[P].PTFe[I]=0) And (N+(6-J)<=POMax);
    PTF[P].PTFe[I]:= 6-J;
End;
With sgGenOR Do
Begin
For I:= 1 To ColCount-1 Do For J:= 1 To RowCount-1 Do Cells[I,J]:= '';
For I:= 1 To PSz Do For J:= 1 To OSz Do If PTF[I].PTFe[J]<>0 Then
    Cells[I,J]:= IntToStr(PTF[I].PTFe[J]);
For I:= 1 To PSz Do With PTF[I] Do
Begin
      S:= 0; For J:= 1 To OSz Do S:= S+PTFe[J];
      Cells[I,RowCount-1]:= IntToStr(S);
End;
For I:= 1 To OSz Do
Begin
      S:= 0; For J:= 1 To PSz Do S:= S+PTF[J].PTFe[I];
      Cells[ColCount-1,I]:= IntToStr(S);
End;
For I:= 1 To PSz Do Cells[I,0]:= PTF[I].PRov;
    Cells[ColCount-1,RowCount-1]:= IntToStr(3*EOSz);
End;
  btUjPop.Enabled:= True;
end;

Procedure TfmGenOR.PopInit;
Var I, J, K, L, M, N, O, P, U, H: Word;
Begin
For K:= 1 To EgyedSz Do With EgyedT[K] Do
Begin
    EOK:= 0; L:= 0;
For I:= 1 To OSz Do For J:= 1 To PSz Do With PTF[J] Do
If PTFe[I]<>0 Then
Begin
      Inc(L);
With EOR[L] Do
Begin
        OSzam:= PTFe[I];
For N:= 1 To 5 Do For O:= 0 To 9 Do ORend[N,O]:= 0;
If OSzam<>2 Then
For M:= 1 To OSzam Do
Begin
Repeat
            N:= Random(5)+1; O:= EOra+Random(UOra-EOra+1);
            U:= 0; For P:= 0 To 9 Do If ORend[N,P]<>0 Then Inc(U);
Until (ORend[N,O]=0) And (U=0);
          ORend[N,O]:= J;
End
Else
Begin
          N:= Random(3)+1; O:= EOra+Random(UOra-EOra+1); ORend[N,O]:= J;
          H:= 4-N; If H<>1 Then N:= N+Random(H)+2 Else N:= 5;
          O:= EOra+Random(UOra-EOra+1); ORend[N,O]:= J;
End;
End;
End;
    EJo:= False;
End;
End;

Procedure TfmGenOR.Josaga(E: Word);
Var I, J, K, S: Word;
Begin
With EgyedT[E] Do
Begin
    EOK:= 0;
For K:= 1 To OSz Do For I:= 1 To 5 Do For J:= 0 To 9 Do EOM[K,I,J]:= 0;
For K:= 1 To EOSz Do With EOR[K] Do For I:= 1 To 5 Do For J:= 0 To 9 Do
If ORend[I,J]<>0 Then EOM[((K-1) Div 10)+1,I,J]:= 1;
    S:= 0;
For K:= 1 To OSz Do For I:= 1 To 5 Do For J:= 0 To 9 Do S:= S+EOM[K,I,J];
    EOK:= S;
End;
end;

Procedure TfmGenOR.Vizsgal;
Var I: Word;
Begin
  OsszJo:= 0; OKMax:= 0; IMax:= 1; JokSz:= 0;
For I:= 1 To EgyedSz Do With EgyedT[I] Do
Begin Inc(OsszJo,EOK); If EOK>OKMax Then Begin OKMax:= EOK; IMax:= I End End;
  Josag:= OsszJo/EgyedSz; edPopJosag.Text:= FloatToStr(Josag);
For I:= 1 To EgyedSz Do With EgyedT[I] Do If EOK>Josag Then
Begin Inc(JokSz); EJo:= True; End Else EJo:= False;
  edJoEgyedSz.Text:= IntToStr(JokSz);
End;

procedure TfmGenOR.btUjPopClick(Sender: TObject);
Var I, J: Word;
begin
  PopInit; For I:= 1 To 5 Do For J:= 0 To 9 Do
  sgGenOR.Cells[(I-1)*10+J+1,0]:= HetN[I]+IntToStr(J);
For I:= 1 To EgyedSz Do Josaga(I); Vizsgal; With ldPop Do
Begin Clear; For I:= 1 To EgyedSz Do Items.Add(IntToStr(EgyedT[I].EOK)) End;
  btStart.Enabled:= True;
end;

procedure TfmGenOR.ldPopClick(Sender: TObject);
Var I, J, K, E, S, T: Word;
begin
  E:= ldPop.ItemIndex+1; edPopInd.Text:= IntToStr(E);
With EgyedT[E] Do With sgGenOR Do
Begin
For I:= 1 To ColCount-1 Do For J:= 1 To RowCount-1 Do Cells[I,J]:= '';
For K:= 1 To OSz Do For I:= 1 To 5 Do For J:= 0 To 9 Do
If EOM[K,I,J]<>0 Then Cells[(I-1)*10+J+1,K]:= IntToStr(EOM[K,I,J]);
    T:= 0;
For I:= 1 To RowCount-2 Do
Begin
      S:= 0; For J:= 1 To ColCount-2 Do If Cells[J,I]<>'' Then Inc(S);
      Cells[ColCount-1,I]:= IntToStr(S); Inc(T,S);
End;
    Cells[ColCount-1,0]:= IntToStr(T);
    T:= 0;
For I:= 1 To ColCount-2 Do
Begin
      S:= 0; For J:= 1 To RowCount-2 Do If Cells[I,J]<>'' Then Inc(S);
      Cells[I,RowCount-1]:= IntToStr(S); Inc(T,S);
End;
    Cells[0,RowCount-1]:= IntToStr(T);
End;
end;

Procedure TfmGenOR.Keresztez;
Var I, V, R: Word;
Begin
  Inc(PopSz);
  V:= Random(EgyedSz)+1; R:= 3*EOSz; IR1:= 0;
For I:= V+1 To EgyedSz Do With EgyedT[I] Do
If EOK<R Then Begin R:= EOK; IR1:= I End;
For I:= 1 To V  Do With EgyedT[I] Do
If EOK<R Then Begin R:= EOK; IR1:= I End;
  V:= Random(EgyedSz)+1; R:= 3*EOSz; IR2:= 0;
For I:= V+1 To EgyedSz Do With EgyedT[I] Do If I<>IR1 Then
If EOK<R Then Begin R:= EOK; IR2:= I End;
For I:= 1 To V  Do With EgyedT[I] Do If I<>IR1 Then
If EOK<R Then Begin R:= EOK; IR2:= I End;
  V:= Random(EgyedSz)+1; R:= 0; IJ1:= 0;
For I:= V+1 To EgyedSz Do With EgyedT[I] Do
If EOK>R Then Begin R:= EOK; IJ1:= I End;
For I:= 1 To V  Do With EgyedT[I] Do
If EOK>R Then Begin R:= EOk; IJ1:= I End;
  V:= Random(EgyedSz)+1; IJ2:= 0;
For I:= V+1 To EgyedSz Do With EgyedT[I] Do If I<>IJ1 Then
If EJo Then IJ2:= I;
For I:= 1 To V  Do With EgyedT[I] Do If I<>IJ1 Then
If EJo Then IJ2:= I;
If IJ1*IJ2<>0 Then
Begin
For I:= 1 To Kereszt Do Uj1.EOR[I]:= EgyedT[IJ1].EOR[I];
For I:= Kereszt+1 To EOSz Do Uj1.EOR[I]:= EgyedT[IJ2].EOR[I];
For I:= 1 To Kereszt Do Uj2.EOR[I]:= EgyedT[IJ2].EOR[I];
For I:= Kereszt+1 To EOSz Do Uj2.EOR[I]:= EgyedT[IJ1].EOR[I];
End;
End;

Procedure TfmGenOR.Mutacio;
Var I, J, K, M, N, O, P, U, H: Word;
    Kod: Integer;
Begin
  Inc(PopSz);
If (PopSz>OSz*OSz*OSz) And (PopSz/OldPopSz>1.1) Then
If Random(2)=0 Then MutSz:= 10*MutSz;
For K:= 1 To EgyedSz Do With EgyedT[K] Do
For I:= 1 To EOSz Do With EOR[I] Do
If Not EJo And (Random(1000)<MutSz) Or EJo And (Random(1000)<MutSz/MutR) Then
Begin
    J:= 0; For N:= 1 To 5 Do For O:= 0 To 9 Do If ORend[N,O]<>0 Then
Begin J:= ORend[N,O]; ORend[N,O]:= 0 End;
If OSzam<>2 Then
For M:= 1 To OSzam Do
Begin
Repeat
        N:= Random(5)+1; O:= EOra+Random(UOra-EOra+1);
        U:= 0; For P:= 0 To 9 Do If ORend[N,P]<>0 Then Inc(U);
Until (ORend[N,O]=0) And (U=0);
      ORend[N,O]:= J;
End
Else
Begin
        N:= Random(3)+1; O:= EOra+Random(UOra-EOra+1); ORend[N,O]:= J;
        H:= 4-N; If H<>1 Then N:= N+Random(H)+2 Else N:= 5;
        O:= EOra+Random(UOra-EOra+1); ORend[N,O]:= J;
End;
End;
  Val(edMutSz.Text,MutSz,Kod);
End;

procedure TfmGenOR.btStartClick(Sender: TObject);
Var I, J, K, S: Word;
    VoltMut: Boolean;
begin
  btStart.Enabled:= False;
  OKMax:= 0; IMax:= 0; PopSz:= 1;
  edStart.Text:= TimeToStr(GetTime); edStart.Repaint;
  edStop.Text:= ''; edStop.Repaint;
Repeat
    OldMax:= OKMax; Keresztez; VoltMut:= False;
If (JokSz<=GAl) Or (EgyedSz-JokSz<=GAl) Then
Begin Mutacio; VoltMut:= True End Else
Begin EgyedT[IR1]:= Uj1; EgyedT[IR2]:= Uj2 End;
If VoltMut Then For I:= 1 To EgyedSz Do Josaga(I) Else
Begin Josaga(IR1); Josaga(IR2) End; Vizsgal;
If PopSz Mod 1000=0 Then
Begin edPopSz.Text:= IntToStr(PopSz); edPopSz.Repaint End;
If OKMax>OldMax Then With ldPop Do
Begin
      OldPopSz:= PopSz; sgGenOR.Repaint;
      edKesz.Text:= IntToStr(OKMax); edKesz.Repaint;
      edIndex.Text:= IntToStr(IMax); edIndex.Repaint;
      edPopInd.Text:= IntToStr(IMax); edPopInd.Repaint;
      Clear; For I:= 1 To EgyedSz Do Items.Add(IntToStr(EgyedT[I].EOK));
      ItemIndex:= IMax-1; ldPopClick(Sender); RePaint;
End;
Until (OKMax>=3*EOSz) Or (PopSz>PopMaxSz);
  edPopSz.Text:= IntToStr(PopSz);
  edKesz.Text:= IntToStr(OKMax);
  edIndex.Text:= IntToStr(IMax);
  edPopInd.Text:= IntToStr(IMax);
  ldPop.ItemIndex:= IMax-1; ldPopClick(Sender);
With ldPop Do
Begin
    Clear; For I:= 1 To EgyedSz Do Items.Add(IntToStr(EgyedT[I].EOK));
    ItemIndex:= IMax-1; ldPopClick(Sender);
End;
With EgyedT[IMax] Do With sgGenOR DO
Begin
For K:= 1 To EOSz Do With EOR[K] Do For I:= 1 To 5 Do For J:= 0 To 9 Do
If ORend[I,J]<>0 Then
    Cells[(I-1)*10+J+1,((K-1) Div 10)+1]:= PTF[ORend[I,J]].PRov;
    S:= 0;
For K:= 1 To OSz Do For I:= 1 To 5 Do For J:= 0 To 9 Do S:= S+EOM[K,I,J];
    EOK:= S;
End;
  edStop.Text:= TimeToStr(GetTime);
end;

end.