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][i]:=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][i]:=0;
if i=(j-KStlbc)then SimTab1[j][i]:=1;
end;{j}end;{i}
{Добавляем строку (дельтаj) (коэфициенты из целевой функции)}
for j:=1 to KStlbc+KStrk+1 do
begin
if j<11 then begin
if StringGrid3.Cells[j,0]='' then SimTab1[j][KStrk+1]:=0


else SimTab1[j][KStrk+1]:=-1*StrToFloat(StringGrid3.Cells[j,0]);
end
else SimTab1[j][KStrk+1]:=0;
end;{j}
{Добавляем столбец (Bi) (значение ограничений)}
for i:=1 to KStrk do
begin
if StringGrid2.Cells[0,i]='' then
SimTab1[KStlbc+KStrk+1][i]:=0
else SimTab1[KStlbc+KStrk+1][i]:=StrToFloat(StringGrid2.Cells[0,i]);
end;{i}
{размеры симплексной таблици}
SStrk:=KStrk+1;
SStlbc:=KStlbc+KStrk+1;
{закончили формировать симплексную таблицу}
{******************************************************************************************}
{находим первый раз разрешающий столбец }
{нименьший элемент последней строки}
for i:=1 to KStrk do DopMas[i]:=i+KStrk-1;//заполняем массив искомых значений первоначальными данными
RasStrk:=0;// стартовые значения
RasStlbc:=1;// координат разрешающей ячейки
{ищем разрешающий столбец}
for i:=2 to SStlbc-1 do begin
if SimTab1[i][SStrk]<SimTab1[RasStlbc][SStrk] then RasStlbc:=i;//находим наименьший элемент последней строки
end;

if SimTab1[RasStlbc][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])<(SimTab1[SStlbc][RasStrk]/SimTab1[RasStlbc][RasStrk])then RasStrk:=j;
end;
end;
end;{j}
end;{SimTab1[RasStlbc][SStrk]>=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][i]:=(SimTab1[j][i]*SimTab1[RasStlbc][RasStrk]-SimTab1[j][RasStrk]*SimTab1[RasStlbc][i])/(SimTab1[RasStlbc][RasStrk]);
if i=RasStrk then SimTab2[j][i]:=SimTab1[j][i]/SimTab1[RasStlbc][RasStrk];//присваеваем значение элементам разрешеющей строки
if j=RasStlbc then SimTab2[j][i]:=0; //присваеваем значение элементам разрешающего столбца
if (i=RasStrk)and(j=RasStlbc) then SimTab2[j][i]:=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]<SimTab1[RasStlbc][SStrk] then RasStlbc:=i;//находим наименьший элемент последней строки
end;
if SimTab1[RasStlbc][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])<(SimTab1[SStlbc][RasStrk]/SimTab1[RasStlbc][RasStrk])then RasStrk:=j;
end;
end;
end;{j}
end;{SimTab1[RasStlbc][SStrk]>=0}
{///////////////////////////////////////////////////////////////////////}
end;{конец основного цикла}
if(RasStlbc>0)and(RasStrk=0) then ShowMessage('L(x)->(бесконечность). Целевая функция неограничена в области допустимых решений.');

For ii:=1 to KStrk do begin
if DopMas[ii]<KStlbc+1 then begin
StringGrid4.Cells[DopMas[ii],0]:=FloatToStr(SimTab1[SStlbc][ii]);
end;
end;
For i:=1 to KStlbc do
begin
if not(StringGrid4.Cells[i,0]='')then
Summa:=Summa+(StrToFloat(StringGrid4.Cells[i,0]))*(StrToFloat(StringGrid3.Cells[i,0])); (*;*)
end;
Label1.Caption:='';
Label1.Caption:=FloatToStr(Summa); {Выводим Значение целевой функции}
end;{конец основной процедуры}


end.