Delphi - Симплекс метод

[Jenek56Rus]

Задача:

При подкормке посевов необходимо внести на 1га почвы не менее 6 единиц химического вещества А, не менее 37 единиц химического вещества В, не менее 26 единиц химического вещества С и не менее 4 единиц химического вещества D. Фермер закупает комбинированные удобрения четырех видов В1, В2, В3 и В4. В таблице указано содержание количества единиц химического вещества в 10 кг каждого вида удобрений и цена 1 кг удобрений. Определите потребность фермера в удобрениях В1, В2, В3 и В4 на 1 га посевной площади при минимальных затратах на их приобретение.



Сделал задачу, находит максимум затрат, что изменить что бы найти минимум

код:

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

Dialogs, ComCtrls, Grids, ExtCtrls, StdCtrls, Menus, Spin;

type

TForm1 = class(TForm)

StringGrid1: TStringGrid;

StringGrid2: TStringGrid;

StringGrid3: TStringGrid;

Label1: TLabel;

Button1: TButton;

Button2: TButton;

Button3: TButton;

StringGrid4: TStringGrid;

Button4: TButton;

procedure FormShow(Sender: TObject);

procedure Button2Click(Sender: TObject);

procedure Button3Click(Sender: TObject);

procedure Button1Click(Sender: TObject);

procedure Button4Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;



var

Form1: TForm1;





implementation





{$R *.dfm}

procedure TForm1.FormShow(Sender: TObject);

var

i:integer;

begin



StringGrid1.Cells[0,1]:='A';

StringGrid1.Cells[0,2]:='B';

StringGrid1.Cells[0,3]:='C';

StringGrid1.Cells[0,4]:='D';



StringGrid1.Cells[1,0]:='B1';

StringGrid1.Cells[2,0]:='B2';

StringGrid1.Cells[3,0]:='B3';

StringGrid1.Cells[4,0]:='B4';



StringGrid2.Cells[0,0]:='Количество вещества';

StringGrid3.Cells[0,0]:='Цена';

StringGrid4.Cells[0,0]:='Xопт:=';



end;



procedure TForm1.Button2Click(Sender: TObject);

begin{Стандартные данные}

StringGrid1.Cells[1,1]:='32';StringGrid1.Cells[2,1]:='14';

StringGrid1.Cells[1,2]:='11';StringGrid1.Cells[2,2]:='5';

StringGrid1.Cells[1,3]:='6';StringGrid1.Cells[2,3]:='5';

StringGrid1.Cells[1,4]:='4';StringGrid1.Cells[2,4]:='3';



StringGrid1.Cells[3,1]:='27';StringGrid1.Cells[4,1]:='20';

StringGrid1.Cells[3,2]:='9';StringGrid1.Cells[4,2]:='2';

StringGrid1.Cells[3,3]:='13';StringGrid1.Cells[4,3]:='7';

StringGrid1.Cells[3,4]:='7';StringGrid1.Cells[4,4]:='5';



StringGrid2.Cells[0,1]:='6';StringGrid2.Cells[0,2]:='37';

StringGrid2.Cells[0,3]:='26';StringGrid2.Cells[0,4]:='4';



StringGrid3.Cells[1,0]:='240';StringGrid3.Cells[2,0]:='170';

StringGrid3.Cells[3,0]:='300';StringGrid3.Cells[4,0]:='120';

end;



procedure TForm1.Button3Click(Sender: TObject);

var

j,i:integer;

begin{очистка таблиц}

for i:=1 to 10 do

begin

for j:=1 to 10 do

begin

StringGrid1.Cells[i,j]:='';

end;{j}

StringGrid2.Cells[0,i]:='';

StringGrid3.Cells[i,0]:='';

StringGrid4.Cells[i,0]:='';

end;{i}

Label1.Caption:='';

end;

procedure TForm1.Button4Click(Sender: TObject);

begin

Close;

end;



{*************************************************************************************************** *****************}

{*********************************************ОСНОВНАЯ ПРОЦЕДУРА*****************************************************}

{*************************************************************************************************** *****************}

procedure TForm1.Button1Click(Sender: TObject);

var

{служебные переменные}

i,j,ii:integer;

S:string;

{основные}

SimTab1:array [1..21,1..11] of double;{Основная таблица для расчетов}

SimTab2:array [1..21,1..11] of double;{Вспомогательная таблица для расчетов}

KStrk:integer; {количество строк в данной таблице}

KStlbc:integer; {количество столбцов в данной таблице}

SStrk:integer; {количество строк в симплекс таблице}

SStlbc:integer; {количество столбцов в симплекс таблице}

RasStrk:integer; {разрешающая строка}

RasStlbc:integer; {разрешающий столбец}

DopMas:array [1..11] of integer;

Summa:Double;

begin

{********************************START**************************************************}

{определяем количество строк}

for j:=1 to 10 do begin

if (StringGrid1.Cells[1,j]='')and(not(StringGrid1.Cells[1,j-1]=''))then KStrk:=j-1;

end;{j}

if not(StringGrid1.Cells[1,10]='')then KStrk:=j;

{определяем количество столбцов}

for j:=1 to 10 do begin

if (StringGrid1.Cells[j,1]='')and(not(StringGrid1.Cells[j-1,1]=''))then KStlbc:=j-1;

end;{j}

if not(StringGrid1.Cells[10,1]='')then KStlbc:=j;



{считываем данные таблици StringGrid1}

for i:=1 to KStrk do begin

for j:=1 to KStlbc do begin

SimTab1[j]:=StrToFloat(StringGrid1.Cells[j,i]);

end;{j} end;{i}

{добавляем единичную матрицу}

for i:=1 to KStrk do begin

for j:=KStlbc+1 to KStlbc+KStrk do begin

SimTab1[j]:=0;

if i=(j-KStlbc)then SimTab1[j]:=1;

end;{j}end;{i}

{Добавляем строку (дельтаj) (коэфициенты из целевой функции)}

for j:=1 to KStlbc+KStrk+1 do

begin

if j0 then//если элемент разрешающего столбца положительный тогда

begin

if RasStrk=0 then RasStrk:=j//ессли это первый положительный элемент в столбце тогда просто присваеваем значение j

else begin

{если соотношение элемент текущей строки последнего столбца на элемент текущей строки разрешающего столбца меньше соотношения элементов предпологаемой разрешающей строки последнего столбца на элемент предпологаемой разрешающей строки разрешающего столбца }

if (SimTab1[SStlbc][j]/SimTab1[RasStlbc][j])=0}

{Основной цикл пересчета выполняется пока находится разрешающий элемент}

While (RasStlbc>0)and(RasStrk>0) do begin

DopMas[RasStrk]:=RasStlbc;

{Пересчет сиплексной таблици (крест на крест)(по правилу прямоугольника)

сначало результаты вычислений сохраняем в промежуточной таблици}

for i:=1 to SStrk do begin

for j:=1 to SStlbc do begin

SimTab2[j]:=(SimTab1[j]*SimTab1[RasStlbc][RasStrk]-SimTab1[j][RasStrk]*SimTab1[RasStlbc])/(SimTab1[RasStlbc][RasStrk]);

if i=RasStrk then SimTab2[j]:=SimTab1[j]/SimTab1[RasStlbc][RasStrk];//присваеваем значение элементам разрешеющей строки

if j=RasStlbc then SimTab2[j]:=0; //присваеваем значение элементам разрешающего столбца

if (i=RasStrk)and(j=RasStlbc) then SimTab2[j]:=1; //присваеваем значение разрешающему элементу

end;{j} end;{i}

{перебрассываем значение массивов}

for i:=1 to SStrk do begin

for j:=1 to SStlbc do begin

SimTab1[j][i]:=SimTab2[j][i];

end;{j} end;{i}

{закончили пересчет}

{Ищем в очередной раз разрешающий элемент}

{//////////////////////////////////////////////////////////////////////////////}

{нименьший элемент последней строки}

RasStrk:=0;// стартовые значения

RasStlbc:=1;// координат разрешающей ячейки

{ищем разрешающий столбец}

for i:=2 to SStlbc-1 do begin

if SimTab1[i][SStrk]=0 then RasStlbc:=0

else begin {если нашли разрешающий столбец ищим разрешающию строку}

for j:=1 to SStrk-1 do begin

if SimTab1[RasStlbc][j]>0 then//если элемент разрешающего столбца положительный тогда

begin

if RasStrk=0 then RasStrk:=j//ессли это первый положительный элемент в столбце тогда просто присваеваем значение j

else begin

{если соотношение элемент текущей строки последнего столбца на элемент текущей строки разрешающего столбца меньше соотношения элементов предпологаемой разрешающей строки последнего столбца на элемент предпологаемой разрешающей строки разрешающего столбца }

if (SimTab1[SStlbc][j]/SimTab1[RasStlbc][j])=0}

{///////////////////////////////////////////////////////////////////////}

end;{конец основного цикла}

if(RasStlbc>0)and(RasStrk=0) then ShowMessage('L(x)->(бесконечность). Целевая функция неограничена в области допустимых решений.');



For ii:=1 to KStrk do begin

if DopMas[ii]