Форум на Исходниках.RU

PROGRAM SIMPLEX_METOD;

USES CRT;

LABEL ZN,ST,ELL,_END;

TYPE MAS=ARRAY[1..30] OF REAL;

MASB=ARRAY[1..30] OF STRING[3];

MASX=ARRAY[1..30,1..30] OF REAL;

VAR Fo,FunctPr,B,H,Hnew,C,Cnew,CPr,CPrnew,FX:MAS;

X,Xnew:MASX;

BS,Bvsp,ZNAC:MASB;

MIN,I1,I,J,Kx,Ky,Kit,NachKell,NachY,K_st:INTEGER;

PriznacY,KLstr,KLst,ErrCode,Dop_X:INTEGER;

P,P1,Mo,F0,Epsilon,Z:REAL;

VSP,S,PrGomory:STRING;

F:TEXT;

DPx,DPy,Fm,Kell,Kstr:INTEGER;

{ Функция создания индексов }

FUNCTION SIMVB(V:INTEGER;S:CHAR):STRING;

VAR M,Z:STRING;

BEGIN

STR(V,M);

Z:=S+M;

SIMVB:=Z;

END;

{ Процедура записи данных в файл }

PROCEDURE SAVE(X1:REAL;K:STRING;Mstr:INTEGER);

VAR V:STRING;

BEGIN

ASSIGN(F,'SIMPLEX.DAT');

APPEND(F);

CASE Mstr OF

0:WRITELN(F,'');

1:BEGIN

IF K=' ' THEN STR(X1:1:0,V) ELSE STR(X1:10:4,V);

WRITE(F,V);

WRITE(F,' ');

END;

2:WRITE(F,K);

3:WRITELN(F,K);

END;

CLOSE(F);

END;

{ Определение дополнительных переменных }

PROCEDURE DOP_PER;

BEGIN

IF ZNAC[I1]='=' THEN

BEGIN

Kell:=Kell+1;Bvsp[Kell]:=SIMVB(DPy,'Y');

DPy:=DPy+1;

Xnew[I1,Kell]:=1;

IF Fm=1 THEN FX[Kell]:=-1 ELSE FX[Kell]:=1;

FunctPr[Kell]:=1;

FOR I:=1 TO Kstr DO

IF I<>I1 THEN Xnew[I,Kell]:=0;

END;

IF ZNAC[I1]='>=' THEN

BEGIN

Kell:=Kell+1;Bvsp[Kell]:=SIMVB(DPx,'X');

DPx:=DPx+1;Dop_X:=Dop_X+1;

Xnew[I1,Kell]:=-1;FX[Kell]:=0;

FOR I:=1 TO Kstr DO

IF I<>I1 THEN Xnew[I,Kell]:=0;

Kell:=Kell+1;Bvsp[Kell]:=SIMVB(DPy,'Y');

DPy:=DPy+1;

Xnew[I1,Kell]:=1;

IF Fm=1 THEN FX[Kell]:=-1 ELSE FX[Kell]:=1;

FunctPr[Kell]:=1;

FOR I:=1 TO Kstr DO

IF I<>I1 THEN Xnew[I,Kell]:=0;

END;

IF ZNAC[I1]='<=' THEN

BEGIN

Kell:=Kell+1;Bvsp[Kell]:=SIMVB(DPx,'X');

DPx:=DPx+1;Dop_X:=Dop_X+1;

Xnew[I1,Kell]:=1;FX[Kell]:=0;

FOR I:=1 TO Kstr DO

IF I<>I1 THEN Xnew[I,Kell]:=0;

END;

{ Процедура сокращения Y }

PROCEDURE SOKR;

VAR P:INTEGER;

BEGIN

Kell:=Kell-1;

FOR P:=NachKell+DOP_X TO Kell DO

IF Bvsp[P]=BS[KLstr] THEN BEGIN

FOR J:=P TO Kell DO

Bvsp[J]:=Bvsp[J+1];

FunctPr[J]:=FunctPr[J+1];

Fx[J]:=Fx[J+1];

FOR I:=1 TO Kstr DO

Xnew[I,J]:=Xnew[I,J+1]

END;

{ Процедура, выполняющая метод Гомори }

PROCEDURE GOMORY;

VAR MAX,Z:REAL;

BEGIN

KLstr:=1;

MAX:=H[1]-INT(H[1]);

FOR I1:=2 TO Kstr DO

IF (H[I1]-INT(H[I1]))>=MAX THEN BEGIN MAX:=H[I1]; KLstr:=I1;END;

Kstr:=Kstr+1;

Hnew[Kstr]:=H[KLstr]-INT(H[KLstr]);

FOR I1:=1 TO Kell DO

BEGIN

Z:=INT(X[KLstr,I1]);

IF X[KLstr,I1]<0 THEN Z:=Z-1;

Xnew[Kstr,I1]:=X[KLstr,I1]-Z;

END;

ZNAC[Kstr]:='>=';

END;

{ Процедура, выполняющая Симплекс метод }

PROCEDURE SIMPLEX;

LABEL POVZNAC,NACH;

BEGIN

{ Подготовка к вводу данных }

NachKell:=Kell;

DPx:=Kell+1;DPy:=1;

Kx:=1;Ky:=4;

Epsilon:=0.00001;

CLRSCR;

WRITELN('Введите систему уравнений:');

WRITELN('(коэффициенты при всех Х,знак и свободные члены)');

{ Ввод данных }

FOR I:=1 TO Kstr DO

BEGIN

POVZNAC:

WRITELN('Введите ',I,'-е уравнение:');

{ Ввод коэффициентов при X в I-том уравнении }

FOR J:=1 TO Kell DO

BEGIN

GOTOXY(Kx,Ky);Kx:=Kx+6;

READLN(Xnew[I,J]);

END;

{ Ввод знака в I-том уравнении }

Kx:=Kx+6;GOTOXY(Kx,Ky);READLN(ZNAC[I]);

{Проверка введенного знака на правильность}

IF (ZNAC[I]<>'>=') AND (ZNAC[I]<>'=') AND (ZNAC[I]<>'<=')

THEN BEGIN

WRITELN('Неправильно задан знак');

Ky:=Ky+3;Kx:=1;

GOTO POVZNAC;

END;

IF (ZNAC[I]='=') OR (ZNAC[I]='>=') THEN PriznacY:=1;

{ Ввод свободного члена в I-том уравнении }

Kx:=Kx+6;GOTOXY(Kx,Ky);READ(B[I]);

Kx:=1;

Ky:=Ky+2;

END;

WRITELN('Введите коэффициенты при Х в целевой функции:');

{ Ввод коэффициентов при Х в целевой функции }

FOR J:=1 TO Kell DO

BEGIN

GOTOXY(Kx,Ky);Kx:=Kx+6;

READ(FX[J]);

END;

{ Подготовка индексации X }

FOR J:=1 TO Kell DO

Bvsp[J]:=SIMVB(J,'X');

{ Определение дополнительных переменных }

FOR I1:=1 TO Kstr DO

DOP_PER;

{ Замена оптимальной функции с MAX на MIN при наличии

в базисе Y-ков если идет исследование на минимум }

MIN:=0;

IF (Fm=1) AND (PriznacY=1) THEN

BEGIN

MIN:=Fm;Fm:=2;

FOR J:=1 TO Kell DO

FX[J]:=-FX[J];

END;

{ Сортировка дополнительных переменных по индексу }

FOR I1:=NachKell+1 TO Kell DO

FOR J:=I1+1 TO Kell DO

IF Bvsp[J]<Bvsp[I1] THEN

BEGIN

VSP:=Bvsp[J];Bvsp[J]:=Bvsp[I1];Bvsp[I1]:=VSP;

P:=FX[J];FX[J]:=FX[I1];FX[I1]:=P;

P:=FunctPr[J];FunctPr[J]:=FunctPr[I1];FunctPr[I1]:=P;

FOR I:=1 TO Kstr DO

BEGIN

P:=Xnew[I,I1];Xnew[I,I1]:=Xnew[I,J];Xnew[I,J]:=P;

END;

Kit:=1;

CLRSCR;

{ Подготовка столбцов C,B,H }

FOR I:=1 TO Kstr DO

BEGIN

Hnew[I]:=B[I];

FOR J:=NachKell+1 TO Kell DO

IF Xnew[I,J]=1 THEN

BEGIN

BS[I]:=Bvsp[J];

Cnew[I]:=FX[J];

CPrnew[I]:=FunctPr[J];

END;

NACH:;

REPEAT

PriznacY:=0;

{ Передача данных в исходные переменные c обнулением чисел,

по модулю меньших чем 0.00001 }

FOR I:=1 TO Kstr DO

BEGIN

IF INT(10000*Hnew[I])=0 THEN H[I]:=+0 ELSE H[I]:=Hnew[I];

C[I]:=Cnew[I];

CPr[I]:=CPrnew[I];

IF BS[I][1]='Y' THEN PriznacY:=1;

FOR J:=1 TO Kell DO

IF INT(10000*Xnew[I,J])=0 THEN X[I,J]:=+0 ELSE X[I,J]:=Xnew[I,J];

END;

{ Обнуление и вывод индексации элементов индексной строки }

SAVE(0,' C Б H ',2);

FOR J:=1 TO Kell DO

BEGIN

SAVE(0,Bvsp[J],2);

P1:=LENGTH(Bvsp[J]);

IF P1=2 THEN SAVE(0,' ',2);

SAVE(0,' ',2);

Fo[J]:=0;

END;

SAVE(0,'',0);

{ Вывод Симплекс-таблицы }

P1:=0;

FOR I:=1 TO Kstr DO

BEGIN

IF CPr[I]=1 THEN

IF C[I]<0 THEN SAVE(0,'-M ',2)

ELSE SAVE(0,'+M ',2)

ELSE SAVE(C[I],'',1);

SAVE(0,BS[I],2);

P1:=LENGTH(BS[I]); IF P1=2 THEN SAVE(0,' ',2);

SAVE(0,' ',2);SAVE(H[I],'',1);

FOR J:=1 TO Kell DO

SAVE(X[I,J],'',1);

SAVE(0,'',0);

END;

{ Вычисление значений в индексной строке }

F0:=0;

FOR J:=1 TO Kell DO

Fo[J]:=0;

FOR I1:=1 TO Kstr DO

BEGIN

IF PriznacY=1 THEN

IF BS[I1][1]='Y' THEN

BEGIN

F0:=F0+H[I1];

FOR J:=1 TO Kell DO

Fo[J]:=Fo[J]+X[I1,J];

END;

IF PriznacY=0 THEN

BEGIN

F0:=F0+H[I1]*C[I1];

FOR J:=1 TO Kell DO

Fo[J]:=Fo[J]+C[I1]*X[I1,J];

END;

FOR J:=1 TO Kell DO

IF Bvsp[J][1]='Y' THEN Fo[J]:=+0

ELSE IF ABS(Fo[J])<Epsilon THEN Fo[J]:=+0;

END;

{ Вывод значений целевой функции }

SAVE(0,' ',2);SAVE(F0,'',1);

FOR J:=1 TO Kell DO

BEGIN

IF PriznacY<>1 THEN Fo[J]:=Fo[J]-FX[J];

SAVE(Fo[J],'',1);

END;

SAVE(0,'',0);

{ Проверка условия оптимальности }

P:=0;

FOR J:=1 TO Kell DO

IF Fm=1 THEN IF Fo[J]<-Epsilon THEN

BEGIN

P:=1;

CONTINUE;

END ELSE

ELSE IF Fo[J]>Epsilon THEN

BEGIN

P:=1;

CONTINUE;

END;

IF P<>1 THEN

BEGIN

SAVE(0,'В ',2);SAVE(Kit,' ',1);

SAVE(0,'-й итерации было получено оптимальное решение',3);

SAVE(0,'т.к. при исследовании на ',2);

IF Fm=1 THEN

SAVE(0,'МАКСИМУМ индексная строка не содержит отицательных элементов.',3)

ELSE

SAVE(0,'МИНИМУМ индексная строка не содержит положительных элементов.',3);

FOR I1:=1 TO Kstr DO

IF BS[I1][1]='Y' THEN

BEGIN

SAVE(0,'Но т.к. из базиса не выведены все Y, то ',3);

SAVE(0,'можно сделать вывод, что РЕШЕНИЙ НЕТ',3);

HALT;

END;

{ Округление значений массива Х до целого числа,

если разность округленного и обычного значений

по модулю меньше чем 0.00001 }

FOR I:=1 TO Kstr DO

BEGIN

Z:=ROUND(H[I]);

IF ABS(Z-H[I])<Epsilon THEN H[I]:=ROUND(H[I]);

FOR J:=1 TO Kell DO

BEGIN

IF X[I,J]<0 THEN Z:=ROUND(X[I,J]);

IF ABS(Z-X[I,J])<Epsilon THEN X[I,J]:=ROUND(X[I,J]);

END;

{ Проверка целочисленности решения }

P1:=0;

FOR I:=1 TO Kstr DO

BEGIN

IF INT(10000*FRAC(H[I]))<>0 THEN BEGIN P1:=1;CONTINUE; END;

FOR J:=1 TO Kell DO

IF BS[I]=Bvsp[J] THEN

FOR I1:=1 TO Kstr DO

IF ABS(FRAC(X[I1,J]))>=Epsilon THEN BEGIN P1:=1;CONTINUE; END;

END;

{ Составление новой базисной строки для целочисленного решения }

IF (PrGomory='Y') AND (P1=1) THEN

BEGIN

GOMORY;

NachKell:=Kell;

I1:=Kstr;DPy:=1;

DOP_PER;

BS[Kstr]:=Bvsp[Kell];

CPrnew[Kstr]:=FunctPr[Kell];

Cnew[Kstr]:=FX[Kell];

GOTO NACH;

END;

IF P1=0 THEN SAVE(0,'Данное решение является целочисленым.',3);

SAVE(0,'При этом:',3);

IF MIN=1 THEN BEGIN F0:=-F0;Fm:=MIN; END;

IF Fm=1 THEN

SAVE(0,'Fmax=',2)

ELSE

SAVE(0,'Fmin=',2);

SAVE(F0,'',1);

SAVE(0,'',0);

FOR I1:=1 TO Kstr DO

BEGIN

SAVE(0,' ',2);

SAVE(0,BS[I1],2);SAVE(0,'=',2);

SAVE(H[I1],'',1);

SAVE(0,'',0);

END;

HALT;

END;

{ Нахождение ключевого столбца }

KLst:=1;Mo:=0;

FOR J:=1 TO Kell DO

IF Fm=1 THEN

IF Fo[J]<Mo THEN Mo:=Fo[J];

FOR J:=1 TO Kell DO

BEGIN

IF Bvsp[J][1]<>'Y' THEN

IF Fm=1 THEN

BEGIN

IF Fo[J]<0 THEN

IF Fo[J]>=Mo THEN

BEGIN

Mo:=Fo[J]; KLst:=J;

END;

END

ELSE

BEGIN

IF Fo[J]>0 THEN

IF Fo[J]>=Mo THEN

BEGIN

Mo:=Fo[J]; KLst:=J;

END;

SAVE(0,'Ключевой столбец: ',2);SAVE(KLst,' ',1);

{ Нахождение ключевой строки }

P1:=0;K_st:=0;

FOR J:=1 TO Kell DO

IF ABS(Mo-Fo[J])<Epsilon THEN

BEGIN

K_st:=K_st+1;

FOR I:=1 TO Kstr DO

IF X[I,KLst]>0 THEN BEGIN B[I]:=H[I]/X[I,KLst]; P:=B[I];KLstr:=I; END

ELSE BEGIN B[I]:=-1; P1:=P1+1; END;

END;

IF P1=Kstr*K_st THEN

BEGIN

SAVE(0,'',0);

SAVE(0,'РЕШЕНИЙ НЕТ т.к. невозможно определить ключевую строку',3);

HALT;

END;

P1:=0;

FOR J:=1 TO Kell DO

IF ABS(Mo-Fo[J])<Epsilon THEN

FOR I:=1 TO Kstr DO

IF B[I]>=0 THEN BEGIN

IF B[I]<P THEN IF Bvsp[KLst]<>BS[I] THEN BEGIN P:=B[I]; KLstr:=I; END;

IF INT(10000*B[I])=INT(10000*P) THEN

IF (BS[I][1]='Y') AND (BS[KLstr][1]='X') THEN

IF Bvsp[KLst]<>BS[I] THEN BEGIN P:=B[I]; KLstr:=I; END;

END;

SAVE(0,'Ключевая строка: ',2);SAVE(KLstr,' ',1);

SAVE(0,'',0);

FOR I:=1 TO Kstr DO

IF Bvsp[KLst]=BS[I] THEN

BEGIN

SAVE(0,'РЕШЕНИЙ НЕТ т.к. в базисном столбце уже есть ',3);

SAVE(0,'такая переменная.',3);

HALT;

END;

{ Вызов процедуры сокращения Y }

IF CPr[KLstr]=1 THEN SOKR;

{ Построение следующей Симплекс-таблицы }

BS[KLstr]:=Bvsp[KLst];

Cnew[KLstr]:=FX[KLst];

CPrnew[KLstr]:=FunctPr[KLst];

FOR I:=1 TO Kstr DO

BEGIN

IF I=KLstr THEN Hnew[I]:=H[I]/X[KLstr,KLst]

ELSE Hnew[I]:=H[I]-(H[KLstr]*X[I,KLst]/X[KLstr,KLst]);

FOR J:=1 TO Kell DO

BEGIN

IF (I=KLstr) AND (J=KLst) THEN Xnew[I,J]:=1;

IF (I=KLstr) AND (J<>KLst) THEN Xnew[I,J]:=X[I,J]/X[KLstr,KLst];

IF (I<>KLstr) AND (J=KLst) THEN Xnew[I,J]:=0;

IF (I<>KLstr) AND (J<>KLst) THEN

Xnew[I,J]:=X[I,J]-(X[KLstr,J]*X[I,KLst]/X[KLstr,KLst]);

END;

KLst:=0;KLstr:=0;

Kit:=Kit+1;

UNTIL (Kit=0);

END;

{ Основная программа }

BEGIN

CLRSCR;

Kit:=0;Dop_X:=0;

ASSIGN(F,'SIMPLEX.DAT');

REWRITE(F);

CLOSE(F);

ST:;

WRITE('Введите кол-во строк:');READLN(Kstr);

IF Kstr>10 THEN

BEGIN

WRITELN('Программа не расчитана на введенное кол-во строк!');

GOTO ST;

END;

ELL:

WRITE('Введите кол-во элементов:');READLN(Kell);

IF Kell>10 THEN

BEGIN

WRITELN('Программа не расчитана на введенное кол-во элементов!');

GOTO ELL;

END;

ZN:

WRITE('Исследуем на МАКСИМУМ(1) или МИНИМУМ(2):');READLN(Fm);

IF (Fm<>1) AND (Fm<>2) THEN

BEGIN

WRITELN('Введите снова');GOTO ZN;

END;

WRITE('Целочисленное решение(Y/N): ');READLN(PrGomory);

IF (PrGomory='Y') OR (PrGomory='y') THEN PrGomory:='Y' ELSE PrGomory:='N';

{ Вызов процедуры SIMPLEX}

SIMPLEX;

END.