unit fmMain;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, StdCtrls, genetic,math, Grids;

type

  TTargetFunction = function(X1,X2 : double):double;// of object;

  TfrmMain = class(TForm)
    Panel1: TPanel;
    Panel2: TPanel;
    GroupBox1: TGroupBox;
    GA1: TGeneticAlgorithm;
    Label1: TLabel;
    edtChromosomeCount: TEdit;
    Label2: TLabel;
    cbxGeneDegree: TComboBox;
    Label3: TLabel;
    edtCrossoverP: TEdit;
    Label4: TLabel;
    edtMutationP: TEdit;
    Label5: TLabel;
    edtInversionP: TEdit;
    Label6: TLabel;
    Label7: TLabel;
    cbxOptimizeMethod: TComboBox;
    Label8: TLabel;
    cbxFunction: TComboBox;
    btnStart: TButton;
    chbUseElitism: TCheckBox;
    GroupBox2: TGroupBox;
    Label9: TLabel;
    stxTarget: TStaticText;
    Label12: TLabel;
    edtMaxCount: TEdit;
    Label13: TLabel;
    btnStop: TButton;
    orders: TStringGrid;
    Label14: TLabel;
    workers: TStringGrid;
    Label15: TLabel;
    StaticText1: TStaticText;
    Label10: TLabel;
    maxTime: TEdit;
    Label11: TLabel;
    Label16: TLabel;
    Edit1: TEdit;
    procedure FormCreate(Sender: TObject);
    function GA1GetSutability(
      Chromosome: TChromosome): Double;
    procedure btnStartClick(Sender: TObject);
    procedure btnStopClick(Sender: TObject);
  private
    { Private declarations }
    fTarget : TTargetFunction;
    fImage  : TBitmap;
    procedure DoResetSampleData;
    procedure ShowResult(Ch: TChromosome);
  public
    { Public declarations }
    StopFlag : boolean;

    property Target : TTargetFunction read fTarget write fTarget;
    procedure OneEpoch;
  end;

var
  frmMain: TfrmMain;


implementation

const // Битовые маски
 work: array[1..8] of byte = (1,2,4,8,16,32,64,128);
{$R *.DFM}

procedure TfrmMain.FormCreate(Sender: TObject);
begin
  DecimalSeparator := '.';
  // инициализируем интерфейс
  cbxGeneDegree.ItemIndex := 0;
  cbxOptimizeMethod.ItemIndex := 1;
  cbxFunction.ItemIndex := 0;
  // инициализируем внутренние переменные
  fImage := TBitmap.Create;
  fImage.Width := 100;
  fImage.Height := 100;


  orders.Cells[1,0] := 'Трудоемкость';
  orders.Cells[2,0] := 'Прибыль';

  workers.Cells[1,0] := 'Стоимость';
  workers.Cells[2,0] := 'Произодительность';

  DoResetSampleData;
end;

function TfrmMain.GA1GetSutability(
  Chromosome: TChromosome): Double;


var
  textCh : string;
  i,j: integer;
  w: integer;
  p: integer;
  br: integer; // Кол-во исполнителей на заказ
  L: array[1..8] of double;
  k: double;
  wCount: integer;
  ordercost, workercost, orderwork, workerpr: integer;
begin
  textCh:='';
  wCount := workers.RowCount-1;
  p:=0; k:=1;
  for i:=1 to 8 do L[i]:=0;
  // рассчитываем приспособленность
  for i := 0 to Chromosome.GeneCount-1 do
   begin
     textCh:=textCh+'(';
     w:=Chromosome.GeneValue[i];
     br:=0;
     for j:=1 to 8 do
     if (w and work[j]) = work[j] then
      begin
        ordercost:=StrToInt(orders.Cells[2,i+1]);
        orderwork:=StrToInt(orders.Cells[1,i+1]);
        workercost:=StrToInt(workers.Cells[1,j]);
        workerpr:=StrToInt(workers.Cells[2,j]);
        P := P +  ordercost - round(orderwork/workerpr*workercost);
        textCh:=textCh+IntToStr(j);
        L[j]:=L[j]+orderwork/workerpr;
        br:=br+1;
      end;
     if w=0 then k:=0;
     if br>2 then k:=0;
     textCh:=textCh+') ';
   end;

  for i:=1 to wCount do if L[i]>StrToInt(maxTime.Text) then k:=0;

  Result := k*P;
  // рисуем хромосому
  StaticText1.Caption := textCh;
end;

procedure TfrmMain.btnStartClick(Sender: TObject);
var
  I : integer;
  xCnt : integer;
  xOldS : double;
  xMaxCnt : integer;
  GeneCount: integer;
begin
  // инициализируем все переменные
  xMaxCnt             := StrToInt(edtMaxCount.Text);
  GeneCount := orders.RowCount-1;
  GA1.OptimizeMethod  := TOptimizeMethod(cbxOptimizeMethod.ItemIndex);
  GA1.UseElita        := chbUseElitism.Checked;
  GA1.Inversion_P     := StrToFloat(edtInversionP.Text);
  GA1.Mutation_P      := StrToFloat(edtMutationP.Text);
  GA1.Crossover_P     := StrToFloat(edtCrossoverP.Text);
  GA1.GeneDegree      := TGeneDegree(cbxGeneDegree.ItemIndex);
  GA1.ChromosomeCount := StrToInt(edtChromosomeCount.Text);
  GA1.GeneCount:=GeneCount;
  GA1.Init;
  xOldS := 0;
  xCnt  := 0;
  btnStart.Enabled := False;
  btnStop.Enabled  := True;
  StopFlag := False;
  for I := 0 to 1000000 do
  begin
    if xCnt >= xMaxCnt then
    begin
      Application.MessageBox(PChar(Format('Обучение остановлено'#10#13+
      'Приспособленность не менялась в течении %d эпох',[xMaxCnt])),
        'Завершение обучения',0);
      break;
    end;
    if StopFlag then break;
    OneEpoch;
    if (abs(xOldS - GA1.BestChromosome.Suitability) < 1.0E-8) then
      inc(xCnt)
    else
      xCnt := 0;
    xOldS := GA1.BestChromosome.Suitability;
    stxTarget.Caption := FloatToStr(GA1.BestChromosome.Suitability);
    ShowResult(GA1.BestChromosome);
    Application.ProcessMessages;
  end;
  btnStart.Enabled := True;
  btnStop.Enabled  := False;
end;

procedure TfrmMain.OneEpoch;
begin

  GA1.OneEpoch;
end;

procedure TfrmMain.btnStopClick(Sender: TObject);
begin
  StopFlag := True;
end;

procedure TfrmMain.DoResetSampleData;
var
 i: integer;
begin
 with orders do
  begin
   for i:=1 to 5 do Cells[0,i]:=IntToStr(i);
   Cells[1,1]:='400'; Cells[2,1]:='3000';
   Cells[1,2]:='370'; Cells[2,2]:='600';
   Cells[1,3]:='900'; Cells[2,3]:='2500';
   Cells[1,4]:='700'; Cells[2,4]:='1700';
   Cells[1,5]:='950'; Cells[2,5]:='2800';
  end;

 with workers do
  begin
   for i:=1 to 8 do Cells[0,i]:=IntToStr(i);
   Cells[1,1]:='100'; Cells[2,1]:='200';
   Cells[1,2]:='200'; Cells[2,2]:='350';
   Cells[1,3]:='150'; Cells[2,3]:='180';
   Cells[1,4]:='170'; Cells[2,4]:='210';
   Cells[1,5]:='370'; Cells[2,5]:='110';
   Cells[1,6]:='220'; Cells[2,6]:='190';
   Cells[1,7]:='50'; Cells[2,7]:='160';
   Cells[1,8]:='80'; Cells[2,8]:='150';
  end;

end;

procedure TfrmMain.ShowResult(Ch: TChromosome);
var i, j: integer;
    textCh: string;
begin
  for i := 0 to Ch.GeneCount-1 do
   begin
     textCh:=textCh+'(';
     for j:=1 to 8 do
     if (Ch.GeneValue[i] and work[j]) = work[j] then textCh:=textCh+IntToStr(j);
     textCh:=textCh+') ';
   end;
  StaticText1.Caption := textCh;
end;

end.