Васильев Ф.П. Методы решения экстремальных задач. М: Наука, 1980.-518с

26.      Васильев Ф.П. Методы решения экстремальных задач. М: Наука, 1980.-518с.

Вспомогательные указатели

Перечень сокращений

ЗВ - загрязняющее (вредное) вещество

ИЗА - источник загрязнения атмосферы

ПДВ - предельно допустимый выброс (допустимый выброс)

СЗЗ - санитарно-защитная зона

ПДК_р - максимальная разовая предельно допустимая концентрация загрязняющего вещества в атмосферном воздухе населенных мест

ПДК_с - среднесуточная предельно допустимая концентрация загрязняющего вещества в атмосферном воздухе населенных мест

ОБУВ - ориентировочный безопасный уровень воздействия загрязняющих веществ в атмосферном воздухе населенных мест

ГВС - газовоздушная смесь

ГОУ - газоочистная установка

ОНД - общесоюзный нормативный документ

НМУ - неблагоприятные метеорологические условия

УПРЗА - унифицированная программа расчета загрязнения атмосферы

Приложения

Unit1.pas

unit Unit1;

interface

uses

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

 Dialogs, ShellAPI, ShlObj, StdCtrls, Buttons, CheckLst,Masks,inifiles,

 ComCtrls,simplex, Menus;

const MyDecimalSeparator='.';

type

 tsArray = array of string;

 tExtArrayx2 = array of tExtArray;

 TForm1 = class(TForm)

 Edit1: TEdit;

 GroupBox1: TGroupBox;

 CheckListBox1: TCheckListBox;

 Label1: TLabel;

 BitBtn1: TBitBtn;

 Button3: TButton;

 Memo1: TMemo;

 SpeedButton1: TSpeedButton;

 CheckBox1: TCheckBox;

 SpeedButton2: TSpeedButton;

 SpeedButton3: TSpeedButton;

 SpeedButton4: TSpeedButton;

 procedure FormCreate(Sender: TObject);

 procedure FormActivate(Sender: TObject);

 procedure BitBtn1Click(Sender: TObject);

 procedure Button3Click(Sender: TObject);

 procedure N2Click(Sender: TObject);

 procedure SpeedButton1Click(Sender: TObject);

 procedure SpeedButton2Click(Sender: TObject);

 procedure SpeedButton3Click(Sender: TObject);

 procedure SpeedButton4Click(Sender: TObject);

 private

 { Private declarations }

 public

 { Public declarations }

 end;

var

 Form1: TForm1;

 dir_path:string;

 IniFile: TIniFile;

implementation

{$R *.dfm}

//запись в ini файл

procedure SaveIni(s:string);

var

 IniPath: string;

 FileName: string;

begin

 GetDir(0,IniPath);

 FileName:=IniPath+'\sav.ini';

 IniFile:=TIniFile.Create(FileName);

 Inifile.WriteString('patch','dir',s);

 IniFile.Free;

end;

//чтение ini файла

function ReadIni:string;

var

 IniPath: string;

 FileName: string;

 s:string;

begin

 GetDir(0,IniPath);

 FileName:=IniPath+'\sav.ini';

 IniFile:=TIniFile.Create(FileName);

 ReadIni:=Inifile.ReadString('patch','dir',s);

 IniFile.Free;

end;

//--------- Удаляет пробел или запятую с краёв строки --------------------------

Function DelSpaceAndCap(s:string):string;

begin

 while pos(copy(s,1,1),' ')<>0 do delete(s,1,1);

 while pos(copy(s,length(s),1),' ')<>0 do delete(s,length(s),1);

 result:=s;

end;

//--------- вырезает из строки имя ---------------------------------------------

Function ReturnSubString(Var s:string):string;

var

 position,i : integer;

begin

 s:=DelSpaceAndCap(s);

 position:=0;

 for i:=1 to length(s)-1 do

 if (pos(copy(s,i,1),' ')<>0) and (position=0) then

 position:=i;

 if position=0 then begin

 result:=s;

 s:='';

 end else begin

 result := DelSpaceAndCap(copy(s,1,position));

 Delete(s,1,position);

 s:=DelSpaceAndCap(s);

 end;

end;

//вывод ограничений

//==============================================================================

procedure vv(a:real;mas:tExtArray; Sign: TOperation);

var

 i:integer;

 s,s2,s3:string;

begin

 s:=floattostr(mas[0]);

 for i:=1 to length(mas)-1 do

 s:=s+'+'+floattostr(mas[i]);

 if Sign=less then s2:=' < ';

 if Sign=Greater then s2:=' > ';

 if Sign=Equal then s2:=' = ';

 form1.memo1.lines.Add(s+s2+floattostr(a));

end;

//==============================================================================

//==============================================================================

//замена в строке всех вхождений одной подстроки на другую

function StrReplace(Str, Str1, Str2 : string):string;

 var

 p, L : integer;

 s:string;

begin

 s:=str;

 L:=length(str1);

 repeat

 p:=pos(str1, s);

 if p>0 then begin

 Delete(s,p,L);

 insert(str2, s, P);

 end;

 until P = 0;

 StrReplace:=s;

end;

//==============================================================================

//==============================================================================

//========================= считывание таблиц влияния таблиц источников на точки

procedure get_pointfunnel(s:string;countPoint:integer;countfunnel:integer;funnel_name:tsArray;funnel_m:tExtArray;

 var pointfunnelx2:tExtArrayx2; var point_cf:tExtArray);

var

 h:textfile;

 k,m:integer;

 s_temp,s_temp2,s_temp3:string;

 flag:boolean;

begin

 SetLength(PointFunnelx2,countPoint,countFunnel);

 SetLength(point_cf,countPoint);

 for k:=0 to countPoint-1 do begin

 point_cf[k]:=0;

 for m:=0 to countFunnel-1 do

 PointFunnelx2[k,m]:=0;

 end;

 AssignFile(h,dir_path+'\RESULT\'+'10pd'+s+'.ppp');

 reset(h);

 for k:=1 to 22 do readln(h,s_temp);

 s_temp:=StrReplace(s_temp,'|',' ');

 s_temp2:=s_temp;

 for m:= 0 to CountPoint-1 do begin //общий цикл

 flag:=true;

 while flag do begin

 if ReturnSubString(s_temp2)='Фоновая' then begin

 point_cf[m]:=strtofloat(copy(s_temp,pos('%',s_temp)-4,4));

 end else begin

 s_temp3:=ReturnSubString(s_temp);

 s_temp3:=ReturnSubString(s_temp);

 s_temp3:=ReturnSubString(s_temp);

 for k:=1 to 6 do s_temp2:=ReturnSubString(s_temp);

 //showmessage(s_temp2);

 for k:=0 to countFunnel-1 do

 if s_temp3=copy(funnel_name[k],8,4) then

 PointFunnelx2[m,k]:=strtofloat(s_temp2);//*funnel_m[k];

 end;

 readln(h,s_temp);

 s_temp:=StrReplace(s_temp,'|',' ');

 s_temp2:=s_temp;

 if ReturnSubString(s_temp2)='В' then flag:=false;

 end;

 for k:=1 to 16 do readln(h,s_temp);

 s_temp:=StrReplace(s_temp,'|',' ');

 s_temp2:=s_temp;

 end;

 closefile(h);

end;

//==============================================================================

//==============================================================================

//========================================================= получение источников

procedure get_funnel(s:string; var countFunnel:integer;var funnel_name:tsArray;

 var funnel_m:tExtArray;var funnel_min:tExtArray);

var

 h,h2 : textfile;

 index_funnel : integer;

 i,j : integer;

 s_temp,s_temp2:string;

begin

 AssignFile(h,dir_path+'\DAT\'+'ist_'+s+'.txt');

 reset(h);

 index_funnel:=-11;

 while s_temp<>'endI' do begin //чтение файла (установка размера массива)

 readln(h,s_temp);

 inc(index_funnel);

 end;

 closefile(h);

 CountFunnel:=index_funnel;

 setLength(funnel_m,CountFunnel);

 setLength(funnel_min,CountFunnel);

 setLength(funnel_name,CountFunnel);

 for i:=0 to countFunnel-1 do begin

 funnel_m[i]:=0;

 funnel_min[i]:=0;

 funnel_name[i]:='';

 end;

 AssignFile(h2,dir_path+'\DAT\'+'ist_'+s+'.txt');

 reset(h2);

 for j:=1 to 9 do

 readln(h2,s_temp);

 for i:= 0 to CountFunnel-1 do begin

 readln(h2,s_temp);

 funnel_name[i]:=ReturnSubString(s_temp);

 for j:=1 to 14 do

 s_temp2:=ReturnSubString(s_temp);

 funnel_m[i]:=strtofloat(ReturnSubString(s_temp));

 if DelSpaceAndCap(s_temp)<>'' then

 funnel_min[i]:=strtofloat(DelSpaceAndCap(s_temp))

 else funnel_min[i]:=0;

 end;

closefile(h2);

end;

//==============================================================================

//==============================================================================

//============================================================= получение точек

procedure get_point (s:string;var countPoint:integer;var point_pdk:tExtArray);

var

 index_point : integer;

 i,j : integer;

 h,h2 : textfile;

 s_temp : string;

begin

 index_point:=-2; // переменная для подсчета кол-ва точек

 AssignFile(h,dir_path+'\WORK\'+'htop'+s+'.ppp');

 reset(h);

 while s_temp<>'000' do begin//чтение файла (установка размера массива)

 readln(h,s_temp);

 inc(index_point);

 end;

 closefile(h);

 CountPoint:=index_point;

 setLength(point_pdk,countPoint);

 for i:=0 to countPoint-1 do

 point_pdk[i]:=0; //зануление

 AssignFile(h2,dir_path+'\WORK\'+'htop'+s+'.ppp');

 reset(h2);

 readln(h2,s_temp);

 for i:= 0 to countPoint-1 do begin

 readln(h2,s_temp);

 for j:=1 to 8 do

 point_pdk[i]:=strtofloat(ReturnSubString(s_temp));

 end;

closefile(h2);

end;

//==============================================================================

//==============================================================================

//=========================================== решение при помощи симплекс метода

procedure get_simplexsolve(countPoint:integer;countFunnel:integer;point_pdk:tExtArray;

 point_cf:tExtArray;funnel_m:tExtArray;funnel_min:tExtArray;

 pointfunnelx2:tExtArrayx2;var x:tExtArray;var s_temp:string);

var

 mas_temp : tExtArrayx2;

 i,j : integer;

 sim : TSimplex;

 L : tExtArray;

begin

setLength(mas_temp,countFunnel,countFunnel);

setLength(L,countFunnel);

setLength(x,countFunnel);

for i:=0 to countFunnel-1 do

 for j:=0 to countFunnel-1 do begin

 if i=j then mas_temp[i,j]:=1 else mas_temp[i,j]:=0;

 L[j]:=1;

 end;

Sim:=TSimplex.Create(L,true);

for i:=0 to countPoint-1 do begin

 //showmessage(vv(point_pdk[i],pointfunnelx2[i]));

 Sim.AddCons(point_pdk[i],pointfunnelx2[i],less);

 if form1.CheckBox1.Checked then vv(point_pdk[i],pointfunnelx2[i],less);

end;

for i:=0 to countFunnel-1 do begin

 Sim.AddCons(funnel_m[i],mas_temp[i],less);

 if funnel_min[i]>0 then begin

 Sim.AddCons(funnel_min[i],mas_temp[i],Greater);

 if form1.CheckBox1.Checked then vv(funnel_min[i],mas_temp[i],Greater);

 end;

end;

 if (Sim.Solve=SIMPLEX_DONE) then begin

 s_temp:='решение найдено';

 x:=Sim.GetSolution;

 end

 else s_temp:='Решения не существует';

end;

//==============================================================================

//==============================================================================

//==================================================== общий модуль для подсчета

procedure TForm1.Button3Click(Sender: TObject);

var

 s,s_temp,ss : string;

 countPoint : integer;

 countfunnel : integer;

 point_pdk : tExtArray;

 point_cf : tExtArray;

 funnel_m : tExtArray;

 funnel_min : tExtArray;

 funnel_name : tsArray;

 pointfunnelx2 : tExtArrayx2;

 i,j : integer;

 x : tExtArray;

 empty : boolean;

 h : textfile;

 funnelSumM,sumX:real;

begin

 funnelSumM:=0;

 sumX:=0;

 memo1.Clear;

 for i:=0 to checkListBox1.Items.Count-1 do begin

 if CheckListBox1.Checked[i] then begin

 application.ProcessMessages;

 s:=checklistbox1.Items.Strings[i];

 s:=returnSubString(s);

 application.ProcessMessages;

 get_point (s,countPoint,point_pdk);

 get_funnel(s,countFunnel,funnel_name,funnel_m,funnel_min);

 get_pointfunnel(s,countPoint,countfunnel,funnel_name,funnel_m,pointfunnelx2,point_cf);

 get_simplexsolve(countPoint,CountFunnel,point_pdk,point_cf,funnel_m,funnel_min,pointfunnelx2,x,s_temp);

 AssignFile(h,dir_path+'\RESULT\'+'h_pd'+s+'.gpv');

 rewrite(h);

 if s_temp='решение найдено' then begin

 memo1.lines.Add('');

 memo1.lines.Add(' Результаты расчета ПДВ (симплекс метод):');

 memo1.lines.Add(' ПРИМЕСЬ='+s);

 memo1.lines.Add('');

 memo1.lines.Add('---------------------------------------------------------');

 memo1.lines.Add('| Код |Существую-|Минимально| Расчетное | коэфф. |');

 memo1.lines.Add('| источника |щий выброс|возможный | значение | норми- |');

 memo1.lines.Add('| выброса | г/с | выброс | П Д В | рования |');

 memo1.lines.Add('|-----------|----------|---г/с----|----г/с----|---------|');

 writeln(h,'');

 writeln(h,' Результаты расчета ПДВ (симплекс метод):');

 writeln(h,' ПРИМЕСЬ='+s);

 writeln(h,'');

 writeln(h,'---------------------------------------------------------');

 writeln(h,'| Код |Существую-|Минимально| Расчетное | коэфф. |');

 writeln(h,'| источника |щий выброс|возможный | значение | норми- |');

 writeln(h,'| выброса | г/с | выброс | П Д В | рования |');

 writeln(h,'|-----------|----------|---г/с----|----г/с----|---------|');

 empty:=true;

 for j:=0 to countFunnel-1 do begin

 funnelSumM:=FunnelSumM+funnel_m[j];

 sumX:=SumX+x[j];

 if abs(x[j]-funnel_m[j])>0.0000001 then

 begin

 ss:='|'+funnel_name[j]+'| '+FloatToStrF(funnel_m[j],ffFixed,1000,6)+' | '+FloatToStrF(funnel_min[j],ffFixed,1000,6);

 ss:=ss+' | '+FloatToStrF(x[j],ffFixed,1000,7)+' | '+FloatToStrF(x[j]/funnel_m[j],ffFixed,1000,5)+' |';

 memo1.lines.Add(ss);

 writeln(h,ss);

 empty:=false;

 end;

 end;

 ss:='| в сумме: '+FloatToStrF(funnelSumM,ffFixed,1000,6)+' ';

 ss:=ss+FloatToStrF(sumX,ffFixed,1000,6)+' | '+ FloatToStrF(sumX/funnelSumM,ffFixed,1000,5)+' |';

 if empty then begin

 memo1.lines.Add('| Нет выбросов для снижения |');

 writeln(h,'| Нет выбросов для снижения |');

 end;

 if not empty then begin

 memo1.lines.Add('- - - - - - - - - - - - - - - - - - - - - - - - - - - - -');

 memo1.lines.Add(ss);

 writeln(h,'- - - - - - - - - - - - - - - - - - - - - - - - - - - - -');

 writeln(h,ss);

 end;

 memo1.lines.Add('---------------------------------------------------------');

 memo1.lines.Add('');

 memo1.lines.Add('');

 writeln(h,'---------------------------------------------------------');

 writeln(h,'');

 writeln(h,'');

 end else begin

 memo1.lines.Add('');

 memo1.lines.Add(' Результаты расчета ПДВ (симплекс метод):');

 memo1.lines.Add(' ПРИМЕСЬ='+s);

 memo1.lines.Add('');

 memo1.lines.Add('---------------------------------------------------------');

 memo1.lines.Add('| Решение не найдено |');

 memo1.lines.Add('---------------------------------------------------------');

 writeln(h,'');

 writeln(h,' Результаты расчета ПДВ (симплекс метод):');

 writeln(h,' ПРИМЕСЬ='+s);

 writeln(h,'');

 writeln(h,'---------------------------------------------------------');

 writeln(h,'| Решение не найдено |');

 writeln(h,'---------------------------------------------------------');

 end;

 closefile(h);

 end;

 // closefile(h);

 end;

end;

//==============================================================================

//поиск файла по маске

procedure FindFiles(StartFolder, Mask: string; List: TStrings;

 ScanSubFolders: Boolean = True);

var

 SearchRec: TSearchRec;

 FindResult: Integer;

begin

 List.BeginUpdate;

 try

 StartFolder := IncludeTrailingBackslash(StartFolder);

 FindResult := FindFirst(StartFolder + '*.*', faAnyFile, SearchRec);

 try

 while FindResult = 0 do

 with SearchRec do

 begin

 if (Attr and faDirectory) <> 0 then

 begin

 if ScanSubFolders and (Name <> '.') and (Name <> '..') then

 FindFiles(StartFolder + Name, Mask, List, ScanSubFolders);

 end

 else

 begin

 if MatchesMask(Name, Mask) then begin

 List.Add(copy(Name,5,4));

 //showmessage(StartFolder + Name);

 end;

 end;

 FindResult := FindNext(SearchRec);

 end;

 finally

 FindClose(SearchRec);

 end;

 finally

 List.EndUpdate;

 end;

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

DecimalSeparator:=MyDecimalSeparator;

end;

procedure TForm1.FormActivate(Sender: TObject);

begin

dir_path:=ReadIni;

edit1.Text:=dir_path;

{--}

end;

procedure TForm1.BitBtn1Click(Sender: TObject);

var

 h,h2:textfile;

 i,j,k,n:integer;

 s_temp:string;

 s: array of array of string;

begin

 dir_path:=edit1.Text;

 checklistbox1.Items.Clear;

 i:=0;

 AssignFile(h,dir_path+'\WORK\activ2.txt');

 reset(h);

 //readln(h,s_temp);

 while not EOF(h) do begin//чтение файла (установка размера массива)

 readln(h,s_temp);

 inc(i);

 end;

 closefile(h);

 setlength(s,i,2);

 AssignFile(h2,dir_path+'\WORK\activ2.txt');

 reset(h2);

 for j:=0 to i-1 do begin

 readln(h2,s_temp);

 s[j,0]:=copy(s_temp,24,4);

 s[j,1]:=copy(s_temp,30,55);

 end;

 closefile(h2);

 FindFiles(dir_path, 'htop*.ppp', checklistbox1.items, true);

 n:=checklistbox1.items.Count-1;

 for j:=0 to n do begin

 for k:=0 to i-1 do begin

 //showmessage(s[k,0]+' -| ');

 if checklistbox1.items[0]=s[k,0] then begin

 //showmessage(s[j,0]+' | '+s[j,1]);

 checklistbox1.items.Delete(0);

 checklistbox1.items.Add(s[k,0]+' '+s[k,1]);

 end;

 end;

 end;

end;

procedure TForm1.N2Click(Sender: TObject);

var

 TitleName : string;

 lpItemID : PItemIDList;

 BrowseInfo : TBrowseInfo;

 DisplayName : array[0..MAX_PATH] of char;

 TempPath : array[0..MAX_PATH] of char;

begin

 FillChar(BrowseInfo, siCeof(TBrowseInfo), #0);

 BrowseInfo.hwndOwner := Form1.Handle;

 BrowseInfo.psCDisplayName := @DisplayName;

 TitleName := 'Please specify a directory';

 BrowseInfo.lpsCTitle := PChar(TitleName);

 BrowseInfo.ulFlags := BIF_RETURNONLYFSDIRS;

 lpItemID := SHBrowseForFolder(BrowseInfo);

 if lpItemId <> nil then

 begin

 SHGetPathFromIDList(lpItemID, TempPath);

 edit1.Text:=TempPath;

 GlobalFreePtr(lpItemID);

 end;

//showmessage(tempPath);

dir_path:=tempPath;

//FindFiles(tempPath, 'htop*.ppp', checkmemo1.lines, true); //старая версия

SaveIni(dir_path);

end;

procedure TForm1.SpeedButton1Click(Sender: TObject);

var

 TitleName : string;

 lpItemID : PItemIDList;

 BrowseInfo : TBrowseInfo;

 DisplayName : array[0..MAX_PATH] of char;

 TempPath : array[0..MAX_PATH] of char;

begin

 FillChar(BrowseInfo, siCeof(TBrowseInfo), #0);

 BrowseInfo.hwndOwner := Form1.Handle;

 BrowseInfo.psCDisplayName := @DisplayName;

 TitleName := 'Please specify a directory';

 BrowseInfo.lpsCTitle := PChar(TitleName);

 BrowseInfo.ulFlags := BIF_RETURNONLYFSDIRS;

 lpItemID := SHBrowseForFolder(BrowseInfo);

 if lpItemId <> nil then

 begin

 SHGetPathFromIDList(lpItemID, TempPath);

 edit1.Text:=TempPath;

 GlobalFreePtr(lpItemID);

 end;

//showmessage(tempPath);

dir_path:=tempPath;

//FindFiles(tempPath, 'htop*.ppp', checkmemo1.lines, true); //старая версия

SaveIni(dir_path);

end;

procedure TForm1.SpeedButton2Click(Sender: TObject);

var

 i:integer;

begin

for i:=0 to checklistbox1.Items.Count-1 do

 checklistbox1.Checked[i]:=true;

end;

procedure TForm1.SpeedButton3Click(Sender: TObject);

var

 i:integer;

begin

for i:=0 to checklistbox1.Items.Count-1 do

 checklistbox1.Checked[i]:=false;

end;

procedure TForm1.SpeedButton4Click(Sender: TObject);

var

 i:integer;

begin

for i:=0 to checklistbox1.Items.Count-1 do

 if checklistbox1.Checked[i] then checklistbox1.Checked[i]:=false

 else checklistbox1.Checked[i]:=true;

end;

end.

Simplex.pas

unit simplex;

interface

const

 SIMPLEX_DONE = 0; // оптимизация успешно завершена

 SIMPLEX_NO_SOLUTION = 1; // задача не имеет решения (не удается найти базис)

 SIMPLEX_NO_BOTTOM = 2; // решения нет, т.к. линейная форма не ограничена снизу

 SIMPLEX_NEXT_STEP = 3; // для получения решения нужно сделать еще хотя бы один шаг

 MAX_VAL = 0.1e-12; //точность (значение, удовлетворяющее -MAX_VAL < X < MAX_VAL считается нулем)

type

 TOperation = (Equal,Less,Greater);

 TExtArray = array of extended;

 TConstrain = record

 A : TExtArray;

 B : extended;

 Sign : TOperation;

 isT : boolean;

 end;

 TSimplex = class

 M,N : integer; { M - число строк, N - число столбцов}

 RealN : integer; {реальное число переменных, изначально вошедших в задачу}

 Cons : array of TConstrain;

 C : TExtArray;

 L : extended;

 Basis : array of integer;

 Max : boolean; { направление оптимизации: минимизация или максимизация }

 Constructor Create(_C:TExtArray; MaximiCe:boolean=false);

 Constructor CreateBasis(const Simplex:TSimplex);

 Constructor Copy(const Simplex:TSimplex);

 Procedure AddCons(_B:extended; _A:TExtArray; Sign:TOperation);

 Procedure SetAllLengths(Len:integer);

 Function SimplexStep:integer;

 Function CheckBasis:boolean;

 Function FoundInBasis(num:integer): integer;

 Function DoPrec(num:extended): extended;

 Procedure NormaliCe;

 Procedure MulString(Number:integer; Value:extended);

 Procedure AddString(Num1,Num2:integer; Value:extended); {суммирование строки 1 со строкой 2, домноженной на коэффициент Value }

 Function Solve:integer;

 Function GetMin:extended;

 Function GetSolution:TExtArray;

 Destructor Free;

 end;

 TIntSimplex = class(TSimplex)

 // CurX : TExtArray;

 //CurL : extended;

 // CurFound : boolean;

 Constructor Create(_C:TExtArray; MaximiCe:boolean=false);

 // Procedure DelLastCons;

 Function IntSolve:integer;

 Function GetIntMin:extended;

 Function IsInteger(value:extended):boolean;

 Function GetIntSolution:TExtArray;

 // Function SearchCons(_B:extended;_A:TExtArray):integer;

 end;

implementation

uses Math;

{ TSimplex }

Function TSimplex.DoPrec(num:extended): extended;

begin

 if ((num < MAX_VAL) and (num > -MAX_VAL)) then

 num := 0;

 Result := num;

end;

procedure TSimplex.AddCons(_B: extended; _A: TExtArray; Sign: TOperation);

var

 j : integer;

begin

 if (Length(_A)>N) then SetAllLengths(Length(_A));

 inc(M);

 SetLength(Cons,M);

 //if ((_B=0) and (Sign=Less)) then Sign:=Equal; //???

 Cons[M-1].B:=_B;

 Cons[M-1].Sign:=Sign;

 SetLength(Cons[M-1].A,N);

 for j:=0 to Length(_A)-1 do Cons[M-1].A[j]:=_A[j];

 if Length(_A)<N then for j:=Length(_A) to N-1 do Cons[M-1].A[j]:=0;

end;

{суммирование строки 1 со строкой 2, домноженной на коэффициент Value }

procedure TSimplex.AddString(Num1, Num2: integer; Value: extended);

var

 j : integer;

begin

 for j:=0 to N-1 do Cons[Num1].A[j]:=Cons[Num1].A[j]+Cons[Num2].A[j]*Value;

 Cons[Num1].B:=Cons[Num1].B+Cons[Num2].B*Value;

end;

function TSimplex.CheckBasis: boolean;

var

 i,j,k : integer;

 f : boolean;

begin

 SetLength(Basis,M);

 for i:=0 to M-1 do Basis[i]:=-1;

 for j:=0 to N-1 do begin

 f:=true;

 k:=-1;

 i:=0;

 while (f and (i<M)) do begin

 if ((Cons[i].A[j]<>0) and (Cons[i].A[j]<>1)) then f:=false;

 if (Cons[i].A[j]=1) then begin

 if (k=-1) then k:=i

 else f:=false;

 end;

 inc(i);

 end;

 if (f and (k<>-1)) then Basis[k]:=j;

 end;

 f:=true;

 for i:=0 to M-1 do f:=f and (Basis[i]<>-1);

 Result:=f;

end;

constructor TSimplex.Create(_C: TExtArray; MaximiCe:boolean);

var

 j : integer;

begin

 N:=Length(_C);

 RealN := N;

 M:=0;

 SetLength(C,N);

 Max:=MaximiCe;

 if (not MaximiCe) then for j:=0 to N-1 do C[j]:=-_C[j]

 else for j:=0 to N-1 do C[j]:=_C[j];

 Max:=MaximiCe;

 L := 0;

end;

constructor TSimplex.Copy(const Simplex: TSimplex);

var

 i,j : integer;

begin

 M:=Simplex.M;

 N:=Simplex.N;

 RealN := Simplex.RealN;

 SetLength(Cons,M);

 SetLength(Basis,M);

 SetLength(C,N);

 Max:=Simplex.Max;

 for i:=0 to M-1 do begin

 SetLength(Cons[i].A,N);

 Basis[i]:=-1;

 for j:=0 to N-1 do Cons[i].A[j]:=Simplex.Cons[i].A[j];

 Cons[i].B:=Simplex.Cons[i].B;

 Cons[i].Sign:=Simplex.Cons[i].Sign;

 end;

 for i:=0 to Simplex.N-1 do C[i]:=Simplex.C[i];

 L := Simplex.L;

end;

constructor TSimplex.CreateBasis(const Simplex: TSimplex);

var

 i,j : integer;

begin

 M:=Simplex.M;

 N:=Simplex.N;

 RealN := Simplex.RealN;

 L := 0;

 SetLength(Cons,M);

 SetLength(Basis,M);

 SetLength(C,N);

 for i:=0 to N-1 do C[i]:=0;

 for i:=0 to M-1 do begin

 SetLength(Cons[i].A,N);

 for j:=0 to N-1 do Cons[i].A[j]:=Simplex.Cons[i].A[j];

 Cons[i].B:=Simplex.Cons[i].B;

 Cons[i].Sign:=equal;

 Cons[i].isT := false;

 end;

 for i:=0 to M-1 do begin

 if (Simplex.Basis[i]<>-1) then Basis[i]:=Simplex.Basis[i]

 else begin

 SetAllLengths(N+1);

 for j:=0 to M-1 do Cons[j].A[N-1]:=0;

 Cons[i].A[N-1]:=1;

 Cons[i].isT := true;

 C[N-1] := 0;

 for j:=0 to Simplex.N-1 do C[j] := C[j] + Simplex.Cons[i].A[j];

 L := L + Cons[i].B;

 end;

 end;

end;

destructor TSimplex.Free;

begin

 SetLength(C,0);

 SetLength(Basis,0);

 SetLength(Cons,0);

 M:=0;

 N:=0;

 RealN := 0;

end;

function TSimplex.GetMin: extended;

var

 i : integer;

begin

 if (Max) then

 Result := -L

 else

 Result := L;

end;

function TSimplex.GetSolution: TExtArray;

var

 Solution : TExtArray;

 i,j : integer;

begin

 SetLength(Solution,RealN);

 for j:=0 to RealN-1 do begin

 Solution[j]:=0;

 i:=0;

 while ((i<M) and (Basis[i]<>j)) do inc(i);

 if ((Basis[i]=j) and (i<M)) then Solution[j]:=Cons[i].B;

 end;

 Result:=Solution;

end;

procedure TSimplex.MulString(Number: integer; Value: extended);

var

 j : integer;

begin

 for j:=0 to N-1 do Cons[Number].A[j]:=Cons[Number].A[j]*Value;

 Cons[Number].B:=Cons[Number].B*Value;

end;

procedure TSimplex.NormaliCe;

var

 i : integer;

begin

 for i:=0 to M-1 do if (Cons[i].Sign<>Equal) then begin

 SetAllLengths(N+1);

 if (Cons[i].Sign=Greater) then Cons[i].A[N-1]:=-1

 else Cons[i].A[N-1]:=1;

 Cons[i].Sign := Equal;

 end;

end;

procedure TSimplex.SetAllLengths(Len: integer);

var

 i, j : integer;

 OldN : integer;

begin

 OldN:=N;

 N:=Len;

 SetLength(C,N);

 for i:=0 to M-1 do SetLength(Cons[i].A,N);

 if (OldN<N) then begin

 for j:=OldN to N-1 do begin

 C[j]:=0;

 for i:=0 to M-1 do Cons[i].A[j]:=0;

 end;

 end;

end;

function TSimplex.FoundInBasis(num:integer): integer;

var

 i:integer;

 f:boolean;

begin

 f := false;

 i := 0 ;

 while (not f and (i<M)) do

 begin

 f := (Basis[i] = num);

 inc(i);

 end;

 if (f) then

 Result := i-1

 else

 Result := -1;

end;

function TSimplex.SimplexStep: integer;

var

 i,j : integer;

 f,opt : boolean;

 x,y : integer; //координаты опорного элемента

 CurMax : extended;

 temp : array of TConstrain;

 tempC : TExtArray;

begin

 opt := true;

 CurMax := -1;

 for i := 0 to N-1 do

 begin

 //проверка на разрешимость

 if (C[i] > 0) then

 begin

 opt := false; //а это попутная проверка на оптимальность

 if (C[i] > CurMax) then //а это поиск ведущего столбца (максимальный элемент в C[i])

 begin

 CurMax := C[i];

 x := i;

 end;

 f := true;

 for j := 0 to M-1 do

 f := f and (Cons[j].A[i] < 0);

 if (f) then

 begin

 Result := SIMPLEX_NO_BOTTOM;

 exit;

 end;

 end;

 end;

 if (opt) then

 Result := SIMPLEX_DONE

 else

 begin

 //зная номер ведущего столбца, ищем номер ведущей строки

 CurMax := MaxExtended; //на самом деле тут будем искать минимум, а не Max

 for j := 0 to M-1 do

 if (Cons[j].A[x] > 0) then //идем только по положительным элементам

 if (Cons[j].B/Cons[j].A[x] < CurMax) then

 begin

 CurMax := Cons[j].B/Cons[j].A[x];

 y := j;

 end

 else if (DoPrec(Cons[j].B/Cons[j].A[x] - CurMax) = 0) then

 if (Cons[j].isT) then

 y := j;

 //сохраняем текущие значения

 SetLength(temp, M);

 for j := 0 to M-1 do

 begin

 SetLength(temp[j].A, N);

 for i := 0 to N-1 do

 temp[j].A[i] := Cons[j].A[i];

 temp[j].B := Cons[j].B;

 end;

 SetLength(tempC, N);

 for i := 0 to N-1 do

 tempC[i] := C[i];

 //делаем пересчет таблицы

 //строка делиться на ведущий элемент

 MulString(y, 1/Cons[y].A[x]);

 //преобразование остальных элементов

 for j := 0 to M-1 do

 begin

 if (j <> y) then

 begin

 for i := 0 to N-1 do

 begin

 Cons[j].A[i] := DoPrec(temp[j].A[i] - temp[j].A[x]*temp[y].A[i]/temp[y].A[x]);

 end;

 Cons[j].B := DoPrec(temp[j].B - temp[j].A[x]*temp[y].B/temp[y].A[x]);

 end

 else

 begin

 for i := 0 to N-1 do

 Cons[j].A[i] := DoPrec(Cons[j].A[i]);

 end;

 end;

 //и строка с коэффициентами функции

 for i := 0 to N-1 do

 begin

 C[i] := DoPrec(tempC[i] - tempC[x]*temp[y].A[i]/temp[y].A[x]);

 end;

 Basis[y] := x;

 //и сама функция:

 L := DoPrec(L - tempC[x]*temp[y].B/temp[y].A[x]);

 for i:= 0 to M-1 do

 SetLength(temp[i].A, 0);

 SetLength(temp, 0);

 SetLength(tempC, 0);

 Result := SIMPLEX_NEXT_STEP;

 end;

end;

function TSimplex.Solve: integer;

var

 i,j : integer;

 Simplex : TSimplex;

 f : boolean;

 Step : integer;

 cc : extended;

begin

 //oldN := N;

 NormaliCe;

 f:=false;

 if (not CheckBasis) then begin

 Simplex:=TSimplex.CreateBasis(self);

 Simplex.Solve;

 f:=Simplex.GetMin<>0;

 if (not f) then for i:=0 to M-1 do begin

 for j:=0 to N-1 do Cons[i].A[j]:=Simplex.Cons[i].A[j];

 Cons[i].B:=Simplex.Cons[i].B;

 Cons[i].isT := false;

 Basis[i]:=Simplex.Basis[i];

 cc := C[Basis[i]];

 for j:=0 to N-1 do

 C[j] := DoPrec(C[j] - cc*Cons[i].A[j]);

 L := DoPrec(L - cc*Cons[i].B);

 end;

 Simplex.Free;

 end;

 if (f) then Step:=SIMPLEX_NO_SOLUTION

 else repeat

 Step:=SimplexStep;

 until (Step<>SIMPLEX_NEXT_STEP);

 //SetAllLengths(OldN);

 Result:=Step;

end;

{ TIntSimplex }

constructor TIntSimplex.Create(_C:TExtArray; MaximiCe:boolean=false);

begin

 //CurFound:=false;

 inherited;

end;

function TIntSimplex.GetIntMin: extended;

begin

 Result:=GetMin;

end;

function TIntSimplex.GetIntSolution: TExtArray;

begin

 Result:=GetSolution;

end;

function TIntSimplex.IsInteger(Value:extended):boolean;

begin

 Result:=((Value=floor(Value)) or (Value=ceil(Value)));

end;

function TIntSimplex.IntSolve: integer;

var

 i : integer;

 OldN : integer;

 FractCol : integer;

 FractRow : integer;

 TmpX : TExtArray;

 TmpCons : TExtArray;

 NewValue : extended;

begin

 if (Solve=SIMPLEX_DONE) then begin

 //if (not CurFound or ((Simplex.GetMin<CurL) and not Max) or ((Simplex.GetMin>CurL) and Max)) then begin

 TmpX:=GetSolution;

 i:=0;

 while ((i<RealN) and IsInteger(TmpX[i])) do inc(i);

 FractCol:=i;

 if (FractCol<>RealN) then begin // если найдена хотя бы одна нецелая переменная

 OldN:=N;

 SetLength(TmpCons,N);

 FractRow := FoundInBasis(FractCol);

 for i := 0 to N-1 do

 if (FoundInBasis(i) = -1) then

 TmpCons[i] := Cons[FractRow].A[i] - Floor(Cons[FractRow].A[i])

 else

 TmpCons[i] := 0;

 NewValue := Cons[FractRow].B - Floor(Cons[FractRow].B);

 //if (Max) then

 AddCons(NewValue, TmpCons, Greater);

 //else

 // AddCons(NewValue, TmpCons, Less);

 Result := IntSolve;

 SetAllLengths(OldN); // удаляем пустые столбцы в конце, если они есть

 end

 else begin // если полученное решение - целочисленное\

 Result := SIMPLEX_DONE;

 end;

 //end;

 end

 else

 Result:=SIMPLEX_NO_SOLUTION;

end;

end.