Приложение. Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

unit Unit1;

interface

uses

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

Dialogs, StdCtrls, Grids, ComCtrls, Menus;

type

TForm1 = class(TForm)

PageControl1: TPageControl;

TabSheet1: TTabSheet;

TabSheet2: TTabSheet;

TabSheet3: TTabSheet;

strGrdTrade: TStringGrid;

Label1: TLabel;

edt1: TEdit;

Label2: TLabel;

edt2: TEdit;

Button1: TButton;

Button2: TButton;

strGrdPlan: TStringGrid;

Label3: TLabel;

Edit1: TEdit;

Button3: TButton;

StrGrdPotentials: TStringGrid;

StrGrdZakaz: TStringGrid;

StrGrdTarif: TStringGrid;

Label4: TLabel;

Button4: TButton;

Button5: TButton;

Button7: TButton;

Label5: TLabel;

MainMenu1: TMainMenu;

N1: TMenuItem;

N2: TMenuItem;

N3: TMenuItem;

N4: TMenuItem;

Label7: TLabel;

Edit2: TEdit;

procedure Button1Click(Sender: TObject);

procedure strGrdTradeSetEditText(Sender: TObject; ACol, ARow: Integer;

const Value: String);

procedure StrGrdZakazSetEditText(Sender: TObject; ACol, ARow: Integer;

const Value: String);

procedure edt1Change(Sender: TObject);

procedure edt2Change(Sender: TObject);

procedure Button2Click(Sender: TObject);

procedure TabSheet2Show(Sender: TObject);

procedure Button4Click(Sender: TObject);

procedure Button5Click(Sender: TObject);

procedure Button3Click(Sender: TObject);

procedure TabSheet3Show(Sender: TObject);

procedure strGrdPlanSetEditText(Sender: TObject; ACol, ARow: Integer;

const Value: String);

procedure Button7Click(Sender: TObject);

procedure FormCreate(Sender: TObject);

procedure N1Click(Sender: TObject);

procedure N2Click(Sender: TObject);

procedure N3Click(Sender: TObject);

procedure N4Click(Sender: TObject);

private

function CheckTabsheet1(): boolean;

function CheckTabSheet2(): boolean;

procedure CheckVirojdennost();

function EvaluatePlan(): real;

procedure SetupPotentials_UnV();

procedure SetupRating();

function IsRatingGreaterThenZero(): boolean;

//procedure RebuildInCycle();

procedure GetPlan();

public

{ Public declarations }

end;

const

epsilon = 0.000001;

var

Form1: TForm1;

implementation

{$R *.dfm}

///формирование плана перевозок

procedure TForm1.Button1Click(Sender: TObject);

var row: integer;

begin

row: = strToInt(Edt1.Text);

if(row < 1) then ShowMessage('Строк должно быть больше 1')

else

StrGrdZakaz.RowCount: = row;

StrGrdTarif.ColCount: = StrGrdTrade.RowCount +1;

StrGrdTarif.RowCount: = StrGrdTrade.RowCount +1;

end;

///курорты

procedure TForm1.strGrdTradeSetEditText(Sender: TObject; ACol,

ARow: Integer; const Value: String);

Var str: string;

begin

str: =strGrdTrade.Cells[1, ARow];

StrGrdTarif.Cells[0, ARow+1]: = str;

end;

//аэропорты

procedure TForm1.StrGrdZakazSetEditText(Sender: TObject; ACol,

ARow: Integer; const Value: String);

Var str: string;

begin

str: =strGrdZakaz.Cells[1, ARow];

StrGrdTarif.Cells[ARow+1, 0]: = str;

end;

//указываем кол-во курортов и формируется таблица strgrdtrade

procedure TForm1.edt1Change(Sender: TObject);

var

row: integer;

begin

if(length(Edt1.Text) > 0) then begin

row: = strToInt(Edt1.Text);

if(row < 1) then ShowMessage('Строк должно быть больше 1')

else

StrGrdTrade.RowCount: = row;

end;

StrGrdTarif.RowCount: = StrGrdTrade.RowCount +1;

end;

//указываем кол-во аэропортов и формируется таблица strgrdzakaz

procedure TForm1.edt2Change(Sender: TObject);

var

row: integer;

begin

if(length(Edt2.Text) > 0) then begin

row: = strToInt(Edt2.Text);

if(row < 1) then ShowMessage('Строк должно быть больше 1')

else

StrGrdZakaz.RowCount: = row;

end;

StrGrdTarif.ColCount: = StrGrdZakaz.RowCount +1;

end;

/// переход на вкладку мин элемента и формирование там таблицы

procedure TForm1.Button2Click(Sender: TObject);

var

row, col: integer;

begin

if CheckTabsheet1() then begin

for row: = 1 to strGrdPlan.RowCount -1 do

for col: = 1 to strGrdPlan.ColCount -1 do

strGrdPlan.Cells[col, row]: = '';

TabSheet2.Show();

end;

end;

function TForm1.CheckTabsheet1(): boolean;

var

i, j: integer;

sumTrade, sumZakaz, n: Extended;

tarif_setted: boolean;

begin

tarif_setted: = true;

for j: = 1 to StrGrdTarif.RowCount-1 do

for i: = 1 to StrGrdTarif.ColCount-1 do

if not TryStrToFloat(StrGrdTarif.Cells[i, j], n) then begin

tarif_setted: = false;

break;

end;

if not tarif_setted then begin

ShowMessage('Один или несколько тарифов не указаны. Заполните все тарифы.');

CheckTabSheet1: = false;

exit;

end;

sumTrade: = 0;

for i: = 0 to strGrdTrade.RowCount-1 do

if TryStrToFloat(strGrdTrade.Cells[1, i], n) then

sumTrade: = sumTrade + n

else begin

ShowMessage('Полностью заполните таблицу поставщики');

CheckTabSheet1: = false;

Exit;

end;

sumZakaz: = 0;

for i: = 0 to strGrdZakaz.RowCount-1 do

if TryStrToFloat(strGrdZakaz.Cells[1, i], n) then

sumZakaz: = sumZakaz + n

else begin

ShowMessage('Полностью заполните таблицу заказчики');

CheckTabSheet1: = false;

Exit;

end;

if(abs(sumTrade - SumZakaz) > epsilon) then begin

ShowMessage('Задача открытого типа. Сумма поставок(' + FloatToStr(SumTrade) + ') Сумма потребностей('+ FloatToStr(sumZakaz)+')');

CheckTabSheet1: = false;

Exit;

end;

CheckTabSheet1: = true;

end;

//передаем данныу из таблицы тариф и таблицу план

procedure TForm1.TabSheet2Show(Sender: TObject);

Var

col, row: Integer;

begin

if(CheckTabSheet1()) then begin

strGrdPlan.RowCount: = StrGrdTarif.RowCount;

strGrdPlan.ColCount: = StrGrdTarif.ColCount;

for row: = 0 to strGrdPlan.RowCount -1 do

strGrdPlan.Cells[0, row]: = strGrdTarif.Cells[0, row];

for col: = 0 to strGrdPlan.ColCount -1 do

strGrdPlan.Cells[col, 0]: = strGrdTarif.Cells[col, 0];

end

else TabSheet1.Show();

end;

procedure TForm1.Button4Click(Sender: TObject);

begin

GetPlan();

Edit1.Text: = FloatToStr(EvaluatePlan());

CheckVirojdennost();

end;

////расчет опорного плана

procedure TForm1.GetPlan();

Var

min: TPoint;

i, j, matrHeight, matrWidth: integer;

buf: real;

trade, zakaz: array of real;

matrix: array of array of real;

exit, firstSearch: boolean;

begin

SetLength(trade, strGrdTrade.RowCount); ////SetLength размерность массивов

for i: = 0 to strGrdTrade.RowCount-1 do

trade[i]: = StrToFloat(strGrdTrade.Cells[1, i]);

SetLength(zakaz, strGrdZakaz.RowCount);

for i: = 0 to strGrdZakaz.RowCount-1 do

zakaz[i]: = StrToFloat(strGrdZakaz.Cells[1, i]);

matrHeight: = strGrdTarif.RowCount-1; //кол-строк

matrWidth: = strGrdTarif.ColCount-1; //кол-во столбцов

SetLength(matrix, matrWidth, matrHeight);

for j: = 0 to matrHeight-1 do

for i: = 0 to matrWidth-1 do

matrix[i, j]: = StrToFloat(strGrdTarif.Cells[i+1, j+1]);

repeat

//min

firstSearch: = true;

for j: = 0 to matrHeight-1 do

if trade[j] > 0 then // пропуск исключенных строк

for i: = 0 to matrWidth-1 do

if zakaz[i] > 0 then // пропуск столбцов

if (matrix[i, j] < matrix[min.X, Min.Y]) or (firstSearch) then begin

min.X: = i;

min.Y: = j;

firstSearch: = false;

end;

//определить число

buf: = trade[min.Y] - zakaz[min.X];

if buf < 0 then begin // склад пуст

StrGrdPlan.Cells[min.X+1, min.Y+1]: = FloatToStr(trade[min.Y]);

trade[min.Y]: = 0;

zakaz[min.X]: = abs(buf);

end

else if buf > 0 then begin // spros udovletvoren

StrGrdPlan.Cells[min.X+1, min.Y+1]: = FloatToStr(zakaz[min.X]);

trade[min.Y]: = buf;

zakaz[min.X]: = 0;

end

else if buf = 0 then begin // oboim xopoiiio

StrGrdPlan.Cells[min.X+1, min.Y+1]: = FloatToStr(trade[min.Y]);

trade[min.Y]: = 0;

zakaz[min.X]: = 0;

end;

// Условие окончания

exit: = true;

for i: = 0 to strGrdTrade.RowCount-1 do

if trade[i] < > 0 then begin

exit: = false;

break;

end;

if not(exit) then continue;

for i: = 0 to strGrdZakaz.RowCount-1 do

if zakaz[i] < > 0 then begin

exit: = false;

break;

end;

Until exit;

end;

// Оценка плана. Вычисление общих затрат на перевозку

function TForm1.EvaluatePlan(): real;

var

buf: real;

i, j: integer;

begin

// вычисление стоимости

buf: = 0;

for j: = 1 to strGrdPlan.RowCount-1 do

for i: = 1 to strGrdPlan.ColCount-1 do begin

if strGrdPlan.Cells[i, j] = '' then

strGrdPlan.Cells[i, j]: = '0';

buf: = buf + StrToFloat(strGrdPlan.Cells[i, j]) * StrToFloat(strGrdTarif.Cells[i, j]);

end;

EvaluatePlan: = buf;

end;

procedure TForm1.CheckVirojdennost();

var

i, j, count: integer;

begin

count: = 0;

for j: = 1 to StrGrdPlan.RowCount-1 do

for i: = 1 to StrGrdPlan.ColCount-1 do

if StrToFloat(strGrdPlan.Cells[i, j]) > epsilon then count: = count +1;

if count < (StrGrdTrade.RowCount +StrGrdZakaz.RowCount-1) then

ShowMessage('План считается вырожденным. Базисных ячеек ' + intToStr(count) + ', что меньше чем необходимые ' + intToSTr(StrGrdTrade.RowCount + StrGrdZakaz.RowCount -1)+

'. Для исключения вырожденности добавьте к одному из поставщиков 0.00001 и к одному из заказчиков 0.00001.');

end;

procedure TForm1.Button5Click(Sender: TObject);

var

col, row: integer;

begin

for row: = 0 to strGrdPotentials.RowCount-1 do

for col: = 0 to strGrdPotentials.ColCount-1 do

strGrdPotentials.Cells[col, row]: = '';

SetupPotentials_UnV();

// Проверка решения на оптимальность

// Проставляем оценки

SetupRating();

// поиск отрицательных оценок

if IsRatingGreaterThenZero() then begin

Label5.Caption: = 'Найден оптимальный план';

ShowMessage('Найден оптимальный план');

Edit2.Text: = FloatToStr(EvaluatePlan());

end

else begin

ShowMessage('План не оптимален, пересмотрите тариф');

Label5.Caption: = 'План не оптимален';

{RebuildInCycle(); }

end;

end;

// проставим потенциалы(шапка)

procedure TForm1.SetupPotentials_UnV();

var

i, j: integer;

V, U: Extended;

complete: bool;

begin

// задаём U1 = 0 (альфа1 = 0)

StrGrdPotentials.Cells[0, 1]: = '0';

repeat // повторять пока не найдём все потенциалы

complete: = true;

// Вычисление потенциалов U и V. Делаем проход по таблице и вычисляем что можем

for j: = 1 to StrGrdPotentials.RowCount-1 do

for i: = 1 to StrGrdPotentials.ColCount-1 do begin

if StrToFloat(strGrdPlan.Cells[i, j]) > epsilon then begin // Такая же ячейка в плане > 0...

if not TryStrToFloat(StrGrdPotentials.Cells[i, 0], V) then begin // И мы ещё не вычислили Vi(столбец), то вычисляем...

if TryStrToFloat(StrGrdPotentials.Cells[0, j], U) then begin // и для этой ячейки уже известен Ui(строка)

StrGrdPotentials.Cells[i, 0]: = FloatToStr(StrToFloat(strGrdTarif.Cells[i, j]) - U); // V = с - U

complete: = false;

end;

// else для ячейки оба параметра ещё не известны!!!

end

else if not TryStrToFloat(StrGrdPotentials.Cells[0, j], U) then begin //... и мы ещё не вычислили Ui(строка), вычисляем

StrGrdPotentials.Cells[0, j]: = FloatToStr(StrToFloat(strGrdTarif.Cells[i, j]) - V); // U = C -V

complete: = false;

end

else begin // для ячейки оба параметра ещё не известны, пока пропустим её

end; // второй else

end;

end; // end for

until complete;

end;

/////////////////////////////

//Проставляем оценки ячейкам

procedure TForm1.SetupRating();

var

i, j: integer;

num: real;

begin

// Пробежимся по всем ячейкам в таблице потенциалов...

for j: = 1 to StrGrdPotentials.RowCount-1 do

for i: = 1 to StrGrdPotentials.ColCount-1 do begin

num: = StrToFloat(strGrdPlan.Cells[i, j]);

if num < epsilon then begin // для такая же ячейка в плане больше нуля, поэтому вычислим оценку = C -U -V

StrGrdPotentials.Cells[i, j]: = FloatToStr(StrToFloat(strGrdTarif.Cells[i, j]) - StrToFloat(StrGrdPotentials.Cells[0, j]) - StrToFloat(StrGrdPotentials.Cells[i, 0]));

end

else begin

StrGrdPotentials.Cells[i, j]: = '0'; // поставим оценку 0

end;

end;

end;

////////////////////////////////////////////////////////

// Проверка оценок потенциалов. Если они все больше нуля,

// то это означает, что план оптимальный. true - оптимальный, false -нет

function TForm1.IsRatingGreaterThenZero(): boolean;

var

i, j: integer;

begin

for j: = 1 to StrGrdPotentials.RowCount-1 do

for i: = 1 to StrGrdPotentials.ColCount-1 do

if strToFloat(StrGrdPotentials.Cells[i, j]) < 0 then begin

IsRatingGreaterThenZero: = false;

exit;

end;

IsRatingGreaterThenZero: = true;

end;