Órarendkészítés ütközésmentesítő algoritmussal

Ez a program a Gépi órarendkészítő demonstrációs program tantárgyfelosztására készített, újabb gépi órarend generáló, demonstrációs program. A rendezés alapja az ütközésmentesítő algoritmus. Mivel az elkészült órarendek a valóságban szintén nem használhatók, a program célja az ütközésmentesítő algoritmus tesztelése órarendkészítésnél.

A program paraméterei: 32 osztály (nem változtatható), az osztályok heti óraszáma 30 (nem változtatható), az osztály tantárgyfelosztása: egy 5 órás, két 4 órás, három 3 órás és négy 2 órás tantárggyal (nem változtatható), pedagógusok száma 33-52, pedagógusok maximális heti óraszáma 22-30. A pedagógusok számának és a heti maximális órarend szorzatának legalább 980-nak kell lenni (különben a tantárgyfelosztás generálása vagy lehetetlen, vagy nehézségekbe ütközik).

A feltöltés szempontjából legkönnyebb tantárgyfelosztás: 52 pedagógus, heti maximum 22 órával. A legnehezebb: 33 pedagógus, heti maximum 30 órával. Ez utóbbi a valóságban szinte elképzelhetetlen. Nem hinném ugyanis, hogy létezik olyan iskola, ahol 32 osztály van, de csak 33 pedagógus. A algoritmus természetesen erre az extrém esetre is tesztelhető.

A nehezen megoldható esetekre a következő újrakezdési feltételeket építettem az algoritmusba: folyamatosan számolja, és a képernyőn megjeleníti az ugyanolyan ütközésszámú próbálkozásokat, és ha ez az érték meghaladja az 6 ezret, akkor teljesen törli az órarendet, és újrakezdi a generálást. Összesen 20-szor enged ilyen újraindulást, és az újraindítások számát is láthatjuk a képernyőn.

Az alapbeállítások után új tantárgyfelosztást kérhetünk, melynek pedagógusonkénti összegzését a képernyő alján, egy listaablakban megtekinthetjük. Egyúttal kapunk egy véletlen feltöltésű órarendet is. Ha az előállított (még ütközéses) órarend nem szimpatikus, új órarendet kérhetünk (ezt egyébként akkor is megtehetjük, ha nem tudta a program a teljes rendezést végrehajtani, így ugyanazon tantárgyfelosztáshoz újabb órarendet generálhatunk). Beállíthatjuk a maximális lépésszámot, mely alapértelmezés szerint 20 ezer. Kétféle generálás közül választhatunk, mely után elindul a rendezgetés (hogy melyik fut, azt a generálás alatt kijelzi a program: R: 2 vagy R:3 formában).

A minél gyorsabb futás érdekében csak minden ezredik lépéskor frissül a képernyő. Akkor kiírja a program a még ütközésben lévő órák számát, mely órákat az órarendben piros alapon láthatunk. Ha a maximális lépésszámon belül sikerül a rendezés, akkor Kész feliratú, ha nem, akkor Vége feliratú üzenet jelenik meg a képernyőn. A gép méri és kijelzi a generáláshoz szükséges lépésszámot, valamint a generálás kezdési és befejezési időpontját.

A továbbiakban lássunk néhány screen-shotot a futtatásról. A start utáni képernyő, amikor a pedagógusok számát és a heti maximális óraszámukat, illetve a maximális lépésszámot beállíthatjuk:

A generált, rendezésre váró órarend (piros alapon az ütközéses órák):

A Rendez-2 típusú rendezés közbeni képernyő:

A kész órarend, melynél a teljes generálási idő 6 másodperc volt:

Az órarendkészítő a kétórás tárgyakat nem helyezi két egymás utáni napra. Ennek helyességéről a Kétórás tantárgyak nyomógomb segítségével könnyen meggyőződhetünk (ezek az órák az órarendben zöld háttérrel látszanak, minden osztályban négy pár ilyen órát találunk):

Nézzünk egy fentebb említett szélsőséges esetet, amikor a pedagógusok száma csak 33. Előfordulhat, hogy a tantárgyfelosztás generálása elsőre nem sikerül, ilyenkor addig kell újra kérni, ameddig létre nem jön. A képernyőről most 1264 ütközési szám olvasható le, ami elég magas (az órarend nagyon sok helyen piros hátterű):

Először csak egy próba feltöltést hajtottunk végre, 20 ezres lépésszámig. Ez alatt a hibaszám 34-re csökkent:

Aztán 200 ezer lépésben próbálta a generálást megoldani. Látható, hogy ez nem sikerült, hiszen 2 ütközés (1 pár) maradt a végére. Ezen nincs mit csodálkozni, hiszen a 33 pedagógusból 15 főnek 30, 12 főnek 29 óráját kellett volna elrendezni és csak további hat főnek van ennél kevesebb órája.

Természetesen lehet olyan tantárgyfelosztás és órarendkezdés még 33 pedagógus esetén is melyet sikerül befejezni. Példa erre a következő futtatási kép (a generálási idő 7 és fél perc volt):

Egy második példa a legnehezebb esetre a következő futtatási képen látható (a generálási idő 18 és fél perc volt):

Még egy futtatási próba a viszonylag elfogadható feltételekkel: 40 pedagógus, maximálisan heti 28 óra (az ütközési szám itt is elég magas, 1194):

Az elkészült órarend (a generálási idő most 33 másodperc volt):

És végül a kétórás tárgyak ellenőrzése:

Egy újabb futtatás eredménye:

A program listája:

unit UUtkOR;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, Grids;

Const OSz= 32;
      PSzMax=52;
type
  St1=String[1];
  St3=String[3];

  TfmUtkOR = class(TForm)
    lbUtkOR: TLabel;
    btKilepes: TButton;
    sgOR: TStringGrid;
    btUjTF: TButton;
    edUTOSz: TEdit;
    btRendez2: TButton;
    edMenet: TEdit;
    edMaxMenet: TEdit;
    lbMaxMenet: TLabel;
    edStart: TEdit;
    edStop: TEdit;
    lbKesz: TLabel;
    lbPSz: TLabel;
    lbPOMax: TLabel;
    btRendez3: TButton;
    btUjOR: TButton;
    ldPTF: TListBox;
btKetoras: TButton;
    lbFeltetel: TLabel;
    lbOsztSz: TLabel;
    edOSz: TEdit;
    lbHetiOSz: TLabel;
    edHetiOSz: TEdit;
    cbPedSz: TComboBox;
    cbPOMax: TComboBox;
    edIsmet: TEdit;
    edRestart: TEdit;
    edPUTOSz: TEdit;
Function PedIndex(PR: St1): Word;
Procedure UjTF;
Procedure Torles;
Procedure UjOR;
Procedure Vissza;
Procedure ORKepre;
Function UTSz(O,S: Word): Word;
Procedure Utkozesek;
procedure btKilepesClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure sgORDrawCell(Sender: TObject; Col, Row: Integer;
Rect: TRect; State: TGridDrawState);
procedure btUjTFClick(Sender: TObject);
procedure btRendez2Click(Sender: TObject);
procedure edMaxMenetChange(Sender: TObject);
procedure btRendez3Click(Sender: TObject);
procedure btUjORClick(Sender: TObject);
procedure btKetorasClick(Sender: TObject);
procedure cbPedSzChange(Sender: TObject);
procedure cbPOMaxChange(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

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


Const ORSz=30;
HetN= 'HKSCP';
      RestartM=20;
      IsmetM=5000;

var
  fmUtkOR: TfmUtkOR;
  ACol,ARow: Integer;
  Oszt: Array[1..OSz] Of St3;
  PTF: Array[1..PSzMax] Of TPTF;
  OTF: Array[1..OSz,1..PSzMax] Of Word;
  OOR, POOR: Array[1..ORSz,1..OSz] Of St1;
  UTT: Array[1..ORsz,1..OSz] Of Word;
  Ind, Zero: Array[1..ORSz*OSz,1..2] Of Word;
  UTOSz, PUTOSz, MaxMenet, Menet: LongInt;
  PSz, POMax: Word;
  Ketora: Boolean;

implementation

{$R *.dfm}

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

procedure TfmUtkOR.sgORDrawCell(Sender: TObject; Col, Row: Integer;
Rect: TRect; State: TGridDrawState);
begin
With sgOR.Canvas.Brush Do
If gdSelected In State Then Color:= clYellow
Else If gdFixed In State Then Color:= clBtnFace Else
Begin
Case Col Of
      1..6, 13..18, 25..30: Color:= clAqua;
End;
If UTT[Col,Row]>0 Then Color:= clRed;
If UTT[Col,Row]=999 Then Color:= clLime;
End;
  sgOR.Canvas.TextRect(Rect,Rect.Left+1,Rect.Top+1,sgOR.Cells[Col,Row]);
If gdFocused In State Then sgOR.Canvas.DrawFocusRect(Rect);
end;

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

procedure TfmUtkOR.cbPedSzChange(Sender: TObject);
begin
  PSz:= cbPedSz.ItemIndex+33;
  Torles;
end;

procedure TfmUtkOR.cbPOMaxChange(Sender: TObject);
begin
  POMax:= cbPOMax.ItemIndex+22;
  Torles;
end;

procedure TfmUtkOR.FormCreate(Sender: TObject);
Var I, J: Word;
begin
  Randomize;
For I:= 1 To OSz Do
  OSzt[I]:= IntToStr(((I-1) Div 8)+1)+'.'+Chr(96+(I-1) Mod 8+1);
For I:= 1 To 26 Do PTF[I].PRov:= Chr(64+I);
For I:= 27 To 52 Do PTF[I].PRov:= Chr(70+I);
With sgOR Do
Begin
For I:= 1 To OSz Do Cells[0,I]:= Oszt[I];
For I:= 1 To 5 Do For J:= 1 To 6 Do
Cells[(I-1)*6+J,0]:= HetN[I]+IntToStr(J);
End;
  Menet:= 0; MaxMenet:= 20000;
  PSz:= 48; POMax:= 26;
  Ketora:= True;
For I:= 1 To ORSz*OSz Do For J:= 1 To 2 Do Zero[I,J]:= 0; Ind:= Zero;
end;

Function TfmUtkOR.PedIndex(PR: St1): Word;
Var I: Word;
Begin
  I:= 1; While PTF[I].PRov<>PR Do Inc(I); PedIndex:= I;
End;

procedure TfmUtkOR.btKetorasClick(Sender: TObject);
Var I, J, K: Word;
begin
For I:= 1 To ORSz Do For J:= 1 To OSz Do UTT[I,J]:= 0;
If Ketora Then For I:= 1 To ORSz Do For J:= 1 To OSz Do
If OTF[J,PedIndex(OOR[I,J])]=2 Then
For K:= 1 To ORSz Do If OOR[K,J]=OOR[I,J] Then UTT[I,J]:= 999;
  sgOR.RePaint;
  Ketora:= Not Ketora;
If Ketora Then Begin Utkozesek; ORKepre End;
end;

Procedure TfmUtkOR.UjTF;
Var I, J, K, L, N, P: Word;
    M: LongInt;
Begin
  Torles;
For I:= 1 To OSz Do For J:= 1 To 4 Do For K:= 1 To J Do
Begin
    M:= 0;
Repeat
      Inc(M);
      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)) Or (M>10000);
If M>=10000 Then Exit;
    PTF[P].PTFe[I]:= 6-J;
End;

For I:= 1 To PSz Do With PTF[I] Do For J:= 1 To OSz Do
If PTFe[J]<>0 Then OTF[J,I]:= PTFe[J];

For I:= 1 To PSz Do With PTF[I] Do For J:= 1 To OSz Do Inc(POSz,PTFe[J]);
For I:= 1 To PSz Do With PTF[I] Do
For J:= 1 To OSz Do If PTFe[J]<>0 Then
Begin
    L:= 0;
While OOR[L+1,J]<>'' Do Inc(L);
For K:= 1 To PTFe[J] Do
    OOR[L+K,J]:= PRov;
End;
With ldPTF Do
Begin
    Clear;
For I:= 1 To PSz Do With PTF[I] Do Items.Add(PRov+': '+IntToStr(POSz));
End;
  UjOR;
End;

Procedure TfmUtkOR.Torles;
Var I, J: Byte;
Begin
For I:= 1 To PSz Do For J:= 1 To OSz Do PTF[I].PTFe[J]:= 0;
For I:= 1 To ORSz Do For J:= 1 To OSz Do OOR[I,J]:= '';
For I:= 1 To ORSz Do For J:= 1 To OSz Do UTT[I,J]:= 0;;
For I:= 1 To PSz Do With PTF[I] Do POSz:= 0;
  ORKepre;
  ldPTF.Clear;
End;

Procedure TfmUtkOR.UjOR;
Var I, J, A, B: Word;
    P: St1;
Begin
For I:= 1 To OSz Do
For J:= 1 To 10000 Do
Begin
    A:= Random(ORSz)+1; B:= Random(ORSz)+1;
    P:= OOR[A,I]; OOR[A,I]:= OOR[B,I]; OOR[B,I]:= P;
End;
End;

Procedure TfmUtkOR.Vissza;
Var I, J, A, B: Word;
    P: St1;
Begin
For I:= 1 To OSz Do
For J:= 1 To 2 Do
Begin
    A:= Random(ORSz)+1; B:= Random(ORSz)+1;
    P:= OOR[A,I]; OOR[A,I]:= OOR[B,I]; OOR[B,I]:= P;
End;
End;

procedure TfmUtkOR.btUjORClick(Sender: TObject);
begin
  UjOR;
  Utkozesek;
  ORKepre;
  edUTOsz.Text:= IntToStr(UTOSz);
  edMenet.Text:= '0';
  edIsmet.Text:= '0';
  edRestart.Text:= '0';
  edStart.Text:= '';
  edStop.Text:= '';
  lbKesz.Visible:= False;
  PUTOSz:= 0; POOR:= OOR;
end;

Procedure TfmUtkOR.ORKepre;
Var I, J: Word;
Begin
With sgOR Do
For I:= 1 To ORSz Do For J:= 1 To OSz Do Cells[I,J]:= OOR[I,J];
End;

Function TfmUtkOR.UTSz(O, S: Word): Word;
Var I, J, N: Word;
Begin
  N:= 0;
For I:= 1 To OSz Do If (I<>S) And (OOR[O,I]=OOR[O,S]) Then Inc(N);
For I:= O-((O-1) Mod 6) To O-((O-1) Mod 6)+5 Do
If (I<>O) And (OOR[I,S]=OOR[O,S]) Then Inc(N);
If OTF[S,PedIndex(OOR[O,S])]=2 Then
Begin
For J:= 1 To ORSz Do If (J<>O) And (OOR[J,S]=OOR[O,S]) Then Break;
If Abs( ((O-1) Div 6)-((J-1) Div 6) )=1 Then Inc(N);
End;
  UTSz:= N;
End;

Procedure TfmUtkOR.Utkozesek;
Var I, J: Word;
Begin
  UTOSz:= 0; For I:= 1 To ORSz Do For J:= 1 To OSz Do
Begin UTT[I,J]:= UTSz(I,J); Inc(UTOSz,UTT[I,J]) End;
End;

procedure TfmUtkOR.btUjTFClick(Sender: TObject);
begin
If PSz*POMax<980 Then Exit;
  UjTF;
  ORKepre;
  Utkozesek;
  edUTOsz.Text:= IntToStr(UTOSz);
  edIsmet.Text:= '0';
  edRestart.Text:= '0';
  edStart.Text:= '';
  edStop.Text:= '';
  lbKesz.Visible:= False;
  btRendez2.Enabled:= True;
  btRendez3.Enabled:= True;
  edMenet.Text:= '0';
  lbKesz.Visible:= False;
  PUTOSz:= 0; POOR:= OOR;
end;

procedure TfmUtkOR.btRendez2Click(Sender: TObject);
Var I, J, X1, X2, Y, A, B, OldUTOSz, Ismet, Restart, Index, RIndex: Word;
    P: St1;
    Volt: Boolean;
begin
  btRendez2.Enabled:= False;
btRendez3.Enabled:= False;
  Volt:= False;
  edStart.Text:= TimeToStr(GetTime); edStart.Repaint;
  edStop.Text:= ''; edStop.Repaint;
With lbKesz Do Begin Caption:= 'R: 2  '; Visible:= True; Repaint End;
  Menet:= 0; ResTart:= 0; Ismet:= 0; OldUTOSz:= 0; PUTOSz:= 65000;
  edPUTOSz.Text:= '0'; edPUTOSz.Repaint;
While (UTOSz>0) And (Menet<MaxMenet) And (Restart<RestartM) Do
Begin

If OldUTOSz=UTOSz Then
Begin Inc(Ismet); edIsmet.Text:= IntToStr(Ismet); edIsmet.Repaint End
Else Begin OldUTOSz:= UTOSz; Ismet:= 0 End;
If (Ismet>IsmetM) And (Restart<RestartM) Then
Begin
If UTOSz<PUTOsz Then
Begin
        POOR:= OOR; PUTOSz:= UTOSz;
        edPUTOSz.Text:= IntToStr(PUTOSz); edPUTOSz.Repaint;
End;
      Inc(Restart); edRestart.Text:= IntToStr(Restart); edRestart.Repaint;
      Ismet:= 0; If Odd(Restart) Then UjOR Else Vissza;
      Utkozesek; ORKepre; sgOR.Repaint;
End;

    Inc(Menet); Utkozesek; A:= UTOSz; OldUTOSz:= A;
If Volt Then
Begin
      Ind:= Zero; Index:= 0;
For I:= 1 To ORSz Do For J:= 1 To OSz Do If UTT[I,J]>0 Then
Begin Inc(Index); Ind[Index,1]:= I; Ind[Index,2]:= J End;
End;
    RIndex:= Random(Index)+1;
X1:= Ind[RIndex,1]; Y:= Ind[RIndex,2];
    X2:= Random(ORSz)+1;
    P:= OOR[X1,Y]; OOR[X1,Y]:= OOR[X2,Y]; OOR[X2,Y]:= P;
    Utkozesek; B:= UTOSz;
If B>A Then
Begin P:= OOR[X2,Y]; OOR[X2,Y]:= OOR[X1,Y]; OOR[X1,Y]:= P; Volt:= False End
Else Volt:= True;
    Utkozesek;
If Menet Mod 1000=0 Then
Begin
      edMenet.Text:= IntToStr(Menet); edMenet.RePaint;
      edUtOSz.Text:= IntToStr(UTOSz); edUTOsz.RePaint;
      ORKepre; sgOR.Repaint;
End;
End;
If (UTOSz>0) And (PUTOSz>0) And (PUTOSz<65000) Then
Begin OOR:= POOR; Utkozesek; UTOSz:= PUTOSz End;
ORKepre; sgOR.Repaint;
  edMenet.Text:= IntToStr(Menet);
  edUtOSz.Text:= IntToStr(UTOSz);
  edIsmet.Text:= IntToStr(Ismet);
  edRestart.Text:= IntToStr(Restart);
With lbKesz Do If UTOSz=0 Then
  Caption:= 'Kész' Else Caption:= 'Vége';
  lbKesz.Visible:= True;
  edStop.Text:= TimeToStr(GetTime);
  btRendez2.Enabled:= True;
  btRendez3.Enabled:= True;
end;

procedure TfmUtkOR.btRendez3Click(Sender: TObject);
Var I, J, X1, X2, X3, Y, A, B, OldUTOSz, Ismet, Restart, Index, RIndex: Word;
    P: St1;
    Volt: Boolean;
begin
  btRendez2.Enabled:= False;
  btRendez3.Enabled:= False;
Volt:= False;
  edStart.Text:= TimeToStr(GetTime); edStart.Repaint;
  edStop.Text:= ''; edStop.Repaint;
With lbKesz Do Begin Caption:= 'R: 3  '; Visible:= True; Repaint End;
  Menet:= 0; ResTart:= 0; Ismet:= 0; OldUTOSz:= 0; PUTOSz:= 65000;
  edPUTOSz.Text:= '0'; edPUTOSz.Repaint;
While (UTOSz>0) And (Menet<MaxMenet) And (Restart<RestartM) Do
Begin

If OldUTOSz=UTOSz Then
Begin Inc(Ismet); edIsmet.Text:= IntToStr(Ismet); edIsmet.Repaint End
Else Begin OldUTOSz:= UTOSz; Ismet:= 0 End;
If (Ismet>IsmetM) And (Restart<RestartM) Then
Begin
If UTOSz<PUTOsz Then
Begin
        POOR:= OOR; PUTOSz:= UTOSz;
        edPUTOSz.Text:= IntToStr(PUTOSz); edPUTOSz.Repaint;
End;
      Inc(Restart); edRestart.Text:= IntToStr(Restart); edRestart.Repaint;
      Ismet:= 0; If Odd(Restart) Then UjOR Else Vissza;
      Utkozesek; ORKepre; sgOR.Repaint
End;

    Inc(Menet); Utkozesek; A:= UTOSz;
If Volt Then
Begin
      Ind:= Zero; Index:= 0;
For I:= 1 To ORSz Do For J:= 1 To OSz Do If UTT[I,J]>0 Then
Begin Inc(Index); Ind[Index,1]:= I; Ind[Index,2]:= J End;
End;
    RIndex:= Random(Index)+1;
    X1:= Ind[RIndex,1]; Y:= Ind[RIndex,2];
X2:= Random(ORSz)+1; X3:= Random(ORSz)+1;
    P:= OOR[X1,Y]; OOR[X1,Y]:= OOR[X2,Y];
    OOR[X2,Y]:= OOR[X3,Y]; OOR[X3,Y]:= P;
    Utkozesek; B:= UTOSz;
If B>A Then
Begin
      P:= OOR[X3,Y]; OOR[X3,Y]:= OOR[X2,Y];
      OOR[X2,Y]:= OOR[X1,Y]; OOR[X1,Y]:= P; Volt:= False;
End Else Volt:= True;
    Utkozesek;
If Menet Mod 1000=0 Then
Begin
      edMenet.Text:= IntToStr(Menet); edMenet.RePaint;
      edUtOSz.Text:= IntToStr(UTOSz); edUTOsz.RePaint;
      ORKepre; sgOR.Repaint;
End;
End;
If (UTOSz>0) And (PUTOSz>0) And (PUTOSz<65000) Then
Begin OOR:= POOR;  Utkozesek; UTOSz:= PUTOSz End;
  ORKepre; sgOR.Repaint;
  edMenet.Text:= IntToStr(Menet);
  edUtOSz.Text:= IntToStr(UTOSz);
  edIsmet.Text:= IntToStr(Ismet);
  edRestart.Text:= IntToStr(Restart);
With lbKesz Do If UTOSz=0 Then
  Caption:= 'Kész' Else Caption:= 'Vége';
  lbKesz.Visible:= True;
  edStop.Text:= TimeToStr(GetTime);
  btRendez2.Enabled:= True;
  btRendez3.Enabled:= True;
end;

end.