Отправляет email-рассылки с помощью сервиса Sendsay

RFpro.ru: Программирование на Basic / VBA

Подписаться Бесплатная «Золотая» новостная рассылка . Подписчиков 1.824 RSS
←   Март 2010   →
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31


За последние 60 дней ни разу не выходила


Сайт рассылки: http://prog.rusfaq.ru/basic
Открыта: 14-03-2002

Автор
Калашников О.А.

Статистика

1.824 подписчиков
0 за неделю
←   Все выпуски   →

RFpro.ru: Программирование на Basic / VBA


Хостинг портала RFpro.ru:
Московский хостер
Профессиональный хостинг на базе Linux x64 и Windows x64

РАССЫЛКИ ПОРТАЛА RFPRO.RU

Чемпионы рейтинга экспертов в этой рассылке

Гаряка Асмик
Статус: Специалист
Рейтинг: 2966
∙ повысить рейтинг » 		Vasiliy83
Статус: Бакалавр
Рейтинг: 1452
∙ повысить рейтинг » 		Megaloman
Статус: Профессионал
Рейтинг: 1130
∙ повысить рейтинг »

/ КОМПЬЮТЕРЫ И ПО / Программирование / Basic/VBA

Номер выпуска:1003
Дата выхода:30.03.2010, 23:30
Администратор рассылки:Калашников О.А., Руководитель
Подписчиков / экспертов:349 / 100
Вопросов / ответов:1 / 1

Вопрос № 177470: Здравствуйте! Помогите написать программу для решения симплекс метода на VB.NET Спасибо!...

Вопрос № 177470:

Здравствуйте!
Помогите написать программу для решения симплекс метода на VB.NET

Спасибо!

Отправлен: 25.03.2010, 22:16
Вопрос задал: Миронычев Виталий, Посетитель
Всего ответов: 1
Страница вопроса »

Отвечает F®ost, Советник :
Здравствуйте, Миронычев Виталий.
Решение симплекс-метода:
Код:
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;
 SIM
 VB:=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;

 END;

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

PROCEDURE SOKR;
VAR P:INTEGER;
 BEGIN
  Kell:=Kell-1;
  FOR P:=NachKell+DOP_X TO Kell DO
   IF Bvsp[P]=BS[K
 Lstr] 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;
 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,N
 ACH;


BEGIN

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

NachKell:=Kell;
DPx:=Kell+1;DPy:=1;
Kx:=1;Ky:=4;
Epsil
on:=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;
     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;
             END;

NACH:;

REPEAT

PriznacY:=0;

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

FOR I:=1 TO Kstr DO
 BEGIN
 IF I
 NT(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],'&
 #39;,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;

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 (PrGom
 ory='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;
        END;
 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;
    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.

-----
От вопроса к ответу, от проблемы к решению

Ответ отправил: F®ost, Советник
Ответ отправлен: 29.03.2010, 15:02
Номер ответа: 260442
Беларусь, Минск
Тел.: 375292792018
Организация: Минский Промтранспроект
Адрес: ул. В.Хоружей, 13, г. Минск, Беларусь
Адрес сайта: http://www.mptp.by

Вам помог ответ? Пожалуйста, поблагодарите эксперта за это!
Как сказать этому эксперту "спасибо"?
  • Отправить SMS #thank 260442 на номер 1151 (Россия) | Еще номера »
  • Отправить WebMoney:

    • Оценить выпуск »
    Нам очень важно Ваше мнение об этом выпуске рассылки!

    Задать вопрос экспертам этой рассылки »

    Скажите "спасибо" эксперту, который помог Вам!

    Отправьте СМС-сообщение с тестом #thank НОМЕР_ОТВЕТА
    на короткий номер 1151 (Россия)
    Номер ответа и конкретный текст СМС указан внизу каждого ответа.

    Полный список номеров »

    * Стоимость одного СМС-сообщения от 7.15 руб. и зависит от оператора сотовой связи. (полный список тарифов)
    ** При ошибочном вводе номера ответа или текста #thank услуга считается оказанной, денежные средства не возвращаются.
    *** Сумма выплаты эксперту-автору ответа расчитывается из суммы перечислений на портал от биллинговой компании.

    © 2001-2010, Портал RFpro.ru, Россия
    Авторское право: ООО "Мастер-Эксперт Про"
    Автор: Калашников О.А. | Программирование: Гладенюк А.Г.
    Хостинг: Компания "Московский хостер"
    Версия системы: 2010.6.14 от 03.03.2010
    В избранное