У вас вопросы?
У нас ответы:) SamZan.net

Object; procedure ExitClickSender- TObject; procedure OpenClickSender- TObject; procedure SveClickSender- TObject; procedure HelpClickSender- TObject;

Работа добавлена на сайт samzan.net: 2016-03-13

Поможем написать учебную работу

Если у вас возникли сложности с курсовой, контрольной, дипломной, рефератом, отчетом по практике, научно-исследовательской и любой другой работой - мы готовы помочь.

Предоплата всего

от 25%

Подписываем

договор

Выберите тип работы:

Скидка 25% при заказе до 7.6.2025

type

 TMio = class(TForm)

   condition: TPanel;

   ogr1: TEdit;

   ogr2: TEdit;

   ogr3: TEdit;

   ogr4: TEdit;

   ogr5: TEdit;

   ogr6: TEdit;

   ogr7: TEdit;

   ogrminus: TSpeedButton;

   ogrplus: TSpeedButton;

   Ogr: TLabel;

   Exit: TSpeedButton;

   Help: TSpeedButton;

   Calculate: TSpeedButton;

   func: TEdit;

   FuncLabel: TLabel;

   Open: TSpeedButton;

   Save: TSpeedButton;

   OpenFile: TOpenDialog;

   SaveFile: TSaveDialog;

   procedure ogrplusClick(Sender: TObject);

   procedure ExitClick(Sender: TObject);

   procedure OpenClick(Sender: TObject);

   procedure SaveClick(Sender: TObject);

   procedure HelpClick(Sender: TObject);

   procedure CalculateClick(Sender: TObject);

   procedure funcChange(Sender: TObject);

 private

   { Private declarations }

 public

   { Public declarations }

 end;

var

 Mio: TMio;

 m:integer=3;//количество ограничений

 minmax:boolean=false;

 endc:boolean;//признак окончания решения

 n:integer;//количество переменных

 a:array[0..10,0..7,0..12] of Real;//массив решений задачи

 Ab:array[0..10,0..7] of integer;

 Cj1,Cj:array[0..12] of Real;//массив базисных переменных

 i,j:integer;

 counter:integer;//счетчик итераций

 b:array [0..7,0..12] of Real;

 Cb:array [0..10,0..6] of Real;

 onmax:boolean=false;//направление поиска

 delta:array [0..10,0..12] of Real;//массив симплекс разностей

 optimum:real;

 correct:boolean;

 zogr:boolean;

implementation

uses TablCalc, tablhelp;

{$R *.DFM}

function ogrcorrectfill:boolean;//проверка правильности заполнения ограничений

var

 ss,s:string;

 k,i,j:integer;

begin

 zogr:=true;

 correct:=true;

 for k:=1 to m do

   begin

     if k=1 then

       s:=mio.ogr1.text;

     if k=2 then

       s:=mio.ogr2.text;

     if k=3 then

       s:=mio.ogr3.text;

     if k=4 then

       s:=mio.ogr4.text;

     if k=5 then

       s:=mio.ogr5.text;

     if k=6 then

       s:=mio.ogr6.text;

     if k=7 then

       s:=mio.ogr7.text;

     for j:=1 to strlen(pchar(s))-1 do

       begin

         if strlen(pchar(s))=0 then

           correct:=false;

         ss:=copy(s,j,2);

         if ss='>=' then

           begin

             miomain.correct:=false;

             miomain.zogr:=false;

           end;

       end;

   end;

 if zogr=false then

   showmessage('Все ограничения должны иметь знак <=');

end;

procedure Func;//нахождение коэффициентов целевой функции

var

 s:string;

 s2,s1:string;

 maxj:integer;

 still:boolean;

 return:boolean;

begin

   maxj:=0;

   for j:=0 to 4 do

     Cj[j]:=0;

   n:=0;

   s:=mio.func.text;

   if strlen(pchar(s))=0 then correct:=false;

   j:=0;

   i:=1;

   still:=true;

   if uppercase(copy(s,1,1))='X' then

     begin

       j:=strtoint(copy(s,2,1));

       Cj[j-1]:=1;

       i:=3

     end;

   while i<=strlen(pchar(s)) do

     begin

       s1:='';

       s2:=copy(s,i,1);

       if still=true then

         begin

           while ((uppercase(s2)<>'X')

           and (s2<>'=') and (

           still=true)) do

             begin

               if s2='=' then

                 still:=false;

               i:=i+1;

               s1:=s1+s2;

               s2:=copy(s,i,1);

             end;

           if uppercase(s2)='X' then

             begin

              j:=strtoint(copy(s,i+1,1));

              if j>maxj then

                maxj:=j;

             end;

           if ((strlen(pchar(s1))>0) and

           (still=true)) then

             begin

             if ((s1='-') or (s1='+')) then

               s1:=s1+'1';

             Cj[j-1]:=strtoint(s1);

             end;

           if s2='=' then

             still:=false;

         end;

       s1:='';

       i:=i+2;

     end;

   n:=maxj;

   for i:=n to n+m do

     Cj[i]:=0;

end;

procedure Ogr;//нахождение коэффициентов при переменных в ограничениях

var

 s:string;

 s2,s1:string;

 s22:integer;

 still:boolean;

 k:integer;

begin

 ogrcorrectfill;

 if zogr=true  then

   begin

     for k:=0 to m-1 do

       begin

         if k=0 then

           s:=mio.ogr1.text;

         if k=1 then

           s:=mio.ogr2.text;

         if k=2 then

           s:=mio.ogr3.text;

         if k=3 then

           s:=mio.ogr4.text;

         if k=4 then

           s:=mio.ogr5.text;

         if k=5 then

           s:=mio.ogr6.text;

         if k=6 then

           s:=mio.ogr7.text;

         j:=0;

         i:=1;

         still:=true;

         if uppercase(copy(s,1,1))='X' then

           begin

             j:=strtoint(copy(s,2,1));

             a[0,k,j]:=1;

             i:=3

           end;

         while i<=strlen(pchar(s)) do

           begin

             s1:='';

             s2:=copy(s,i,1);

             if still=true then

               begin

                 while ((uppercase(s2)<>'X') and

                 (s2<>'=') and

                 (s2<>'<') and

                 (still=true)) do

                   begin

                     if s2='=' then

                       still:=false;

                     i:=i+1;

                     s1:=s1+s2;

                     s2:=copy(s,i,1);

                   end;

                 if ((strlen(pchar(s1))>0) and (still=true))  then

                   begin

                     if uppercase(s2)='X'

                       then j:=strtoint(copy(s,i+1,1));

                     if ((s1='-') or (s1='+')) then

                       s1:=s1+'1';

                     a[0,k,j]:=strtoint(s1);

                   end;

                 if ((s2='=') or (s2='<') or (s2='>')) then

                   still:=false;

               end;

             s1:='';

             i:=i+2;

           end;

         s22:=pos('=',s);

         a[0,k,0]:=strtofloat(copy(s,s22+1,strlen(pchar(s))-s22));

       end;

   end;

end;

procedure calc;

var

 min:real;

 mins:real;

 temp:real;

 tempa:integer;

 index_col,index_str:integer;

 f:textfile;

 found:boolean;

begin

 counter:=0;

 for i:=0 to m do

   for j:=0 to n+m do

     a[counter,i,j]:=0;

 for j:=0 to n+m do

   delta[counter,j]:=0;

 for j:=0 to m-1 do

   Cb[counter,j]:=0;

 func;

 ogr;

 if miomain.correct=true then

   begin

     for i:=0 to m-1 do

       a[counter,i,i+n+1]:=1;

     //канонизация задачи

     endc:=false;

     for j:=0 to m+n do

       Ab[counter,j-m]:=0;

     for j:=0 to m-1 do

       Ab[counter,j]:=n+j+1;

     while (counter<=9) and (endc=false) do

       begin

         for j:=0 to n+m do

           delta[counter,j]:=0;

         //расчет симплекс разностей

         for j:=0 to n+m do

           begin

             for i:=0 to m-1 do

               delta[counter,j]:=delta[counter,j]+Cb[counter,i]*a[counter,i,j];

             if j<>0 then delta[counter,j]:=delta[counter,j]-Cj[j-1];

           end;

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

         endc:=true;

         if onmax=true then

           for i:=0 to m+n do

             if delta[counter,i]<0 then

               endc:=false;

         if onmax=false then

           for i:=0 to m+n do

             if delta[counter,i]>0 then

               endc:=false;

         //поиск направляющего столбца

         min:=delta[counter,1];

         index_col:=1;

         if onmax=true  then

           for j:=0 to n+m do

             if delta[counter,j]<min then

               begin

                 min:=delta[counter,j];

                 index_col:=j

               end;

         if onmax=false then

           for j:=0 to n+m do

             if delta[counter,j]>min then

               begin

                 min:=delta[counter,j];

                 index_col:=j

               end;

         //поиск направляющей строки

         index_str:=0;

         j:=0;

         found:=false;

         for i:=0 to m-1 do

           if ((a[counter,i,0]>0 )and

           (a[counter,i,index_col]>0) and

           (found=false))then

             begin

               mins:=a[counter,i,0]/a[counter,i,index_col];found:=true ;

               index_str:=i

             end;

         for i:=0 to m-1 do

           if ((a[counter,i,0]>0 )and

           (a[counter,i,index_col]>0) and

           (a[counter,i,0]/a[counter,i,index_col]<=mins)) then

             begin

               mins:=a[counter,i,0]/a[counter,i,index_col];

               index_str:=i;

             end;

         for j:=0 to n+m do

           Cj1[j]:=Cj[j];

         for j:=0 to n+m do

           begin

             temp:=a[counter,index_str,j]/a[counter,index_str,index_col];

             b[index_str,j]:=temp;

           end;

         //заполнение таблицы

         for j:=0 to n+m do

           Cj[j]:=Cj1[j];

         for i:=0 to m-1 do

           if i<>index_str then

              for j:=0 to n+m do

                b[i,j]:=a[counter,i,j]-b[index_str,j]*a[counter,i,index_col];

         for i:=0 to m-1 do

           begin

             temp:=Cb[counter,i];

             Cb[counter+1,i]:=temp;

             tempa:=Ab[counter,i];

             Ab[counter+1,i]:=tempa

           end;

         for i:=0 to m-1 do

           if i=index_str then

             begin

               temp:=Cj[index_col-1];

               Cb[counter+1,i]:=temp;

               Ab[counter+1,i]:=index_col;

             end

           else

             Ab[counter+1,i]:=Ab[counter+1,i];

         for i:=0 to m-1 do

           for j:=0 to n+m do

             a[counter+1,i,j]:=b[i,j];

         if endc=true then

           tablres.answer.tabvisible:=true;

         counter:=counter+1;

       end;

     if counter=10 then

       begin

         showmessage('Программа не смогла выполнить расчет,'+

         'так как необходимо слишком много итераций');

         counter:=9;

       end;

     if counter<=9 then tablres.showmodal;

   end;

end;

Procedure FillVar;

//чтение целевой функции и ограничений из файла

var

 fil:text;

 fun,ogr:string;

begin

 AssignFile(fil,mio.openfile.filename);

 reset(fil);

 mio.ogr1.visible:=false;

 mio.ogr2.visible:=false;

 mio.ogr3.visible:=false;

 mio.ogr4.visible:=false;

 mio.ogr5.visible:=false;

 mio.ogr6.visible:=false;

 mio.ogr7.visible:=false;

 if not eof(fil) then

   begin

     readln(fil,fun);

     if UpperCase(copy(fun,1,4))='FMIN' then

       begin

         Onmax:=false;

         fun:=copy(fun,6,strlen(pchar(fun)))+'=min'

       end;

     if UpperCase(copy(fun,1,4))='FMAX' then

       begin

         Onmax:=true;

         fun:=copy(fun,6,strlen(pchar(fun)))+'=max'

       end;

   mio.func.text:=fun

 end;

 m:=0;

 while ((not eof(fil)) and (m<7))  do

   begin

     m:=m+1;

     if m=1 then

       begin

         mio.ogr1.visible:=true;

         readln(fil,ogr);

         mio.ogr1.text:=ogr

       end;

     if m=2 then

       begin

         mio.ogr2.visible:=true;

         readln(fil,ogr);

         mio.ogr2.text:=ogr

       end;

     if m=3 then

       begin

         mio.ogr3.visible:=true;

         readln(fil,ogr);

         mio.ogr3.text:=ogr

       end;

     if m=4 then

       begin

         mio.ogr4.visible:=true;

         readln(fil,ogr);

         mio.ogr4.text:=ogr

       end;

     if m=5 then

       begin

         mio.ogr5.visible:=true;

         readln(fil,ogr);

         mio.ogr5.text:=ogr

       end;

     if m=6 then

       begin

         mio.ogr6.visible:=true;

         readln(fil,ogr);

         mio.ogr6.text:=ogr

       end;

     if m=7 then

       begin

         mio.ogr7.visible:=true;

         readln(fil,ogr);

         mio.ogr7.text:=ogr

       end;

 end;

 CloseFile(fil)

end;

Procedure SaveVar;

//сохранение целевой функции и ограничений в файле

var

 fil:text;

 fnc:string;

 num:integer;

begin

 AssignFile(fil,mio.SaveFile.filename+'.dat');

 rewrite(fil);

 fnc:='F'+copy(mio.func.text,strlen(pchar(mio.func.text))-2,3)+'='+copy(mio.func.text,1,strlen(pchar(mio.func.text))-4);

 writeln(fil,fnc);

 for num:=1 to m do

   begin

     if num=1 then writeln(fil,mio.ogr1.text);

     if num=2 then

       writeln(fil,mio.ogr2.text);

     if num=3 then

       writeln(fil,mio.ogr3.text);

     if num=4 then

       writeln(fil,mio.ogr4.text);

     if num=5 then

       writeln(fil,mio.ogr5.text);

     if num=6 then

       writeln(fil,mio.ogr6.text);

     if num=7 then

       writeln(fil,mio.ogr7.text);

   end;

 CloseFile(fil)

end;

procedure TMio.ogrplusClick(Sender: TObject);

//добавление или удаление ограничений

begin

 if sender=ogrplus then

   begin

     m:=m+1;

     if m>7 then

       m:=7;

   end;

 if sender=ogrminus then

   begin

     m:=m-1;

     if m<1 then

       m:=1;

   end;

   if m=1 then

     begin

       ogr1.visible:=true;

       ogr2.visible:=false;

       ogr2.text:='';

     end;

   if m=2 then

     begin

       ogr2.visible:=true;

       ogr3.visible:=false;

       ogr3.text:='';

     end;

   if m=3 then

     begin

       ogr3.visible:=true;

       ogr4.visible:=false;

       ogr4.text:='';

     end;

   if m=4 then

     begin

       ogr4.visible:=true;

       ogr5.visible:=false;

       ogr5.text:='';

     end;

   if m=5 then

     begin

       ogr5.visible:=true;

       ogr6.visible:=false;

       ogr6.text:='';

     end;

   if m=6 then

     begin

       ogr6.visible:=true;

       ogr7.visible:=false;ogr7.text:='';

     end;

   if m=7 then

     begin

       ogr7.visible:=true;

     end;

end;

procedure TMio.ExitClick(Sender: TObject);

begin

 close

end;

procedure TMio.OpenClick(Sender: TObject);

//открытие файла

begin

 if OpenFile.Execute then FillVar;

end;

procedure TMio.SaveClick(Sender: TObject);

//сохранение файла

begin

 if SaveFile.Execute then SaveVar;

end;

procedure TMio.HelpClick(Sender: TObject);

//вызов справки

begin

 tabhelp.showmodal;

end;

procedure TMio.CalculateClick(Sender: TObject);

//расчет задачи

begin

 calc;

end;

procedure TMio.funcChange(Sender: TObject);

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

begin

 if minmax=true then

   begin

     if copy(mio.func.text,strlen(pchar(mio.func.text)),1)='0' then

       begin

         Onmax:=false;

         mio.func.text:=copy(mio.func.text,1,strlen(pchar(mio.func.text))-1)+'min';

         minmax:=false;

       end;

     if copy(mio.func.text,strlen(pchar(mio.func.text)),1)='1' then begin OnMax:=true;mio.func.text:=copy(mio.func.text,1,strlen(pchar(mio.func.text))-1)+'max';minmax:=false;end;

   end;

 if copy(mio.func.text,strlen(pchar(mio.func.text)),1)='=' then minmax:=true;

end;

end.




1. Борис Годунов
2. объем реализованной продукции Ссг среднегодовая стоимость ОПФ руб
3. Ипотечное кредитование- зарубежный опыт и российская практика
4. кваліфікаційного рівня напряму 0101 Педагогічна освіта шифр і назва напряму спеціальності 6
5. Живопись Диего Веласкеса
6. Реферат- Краткая характеристика стандартов на системы качеств
7. Продуктивное использование воспитательных моментов в образовательном процессе
8. партии по интересам партии по афоректам ориентированных на лидера партии по принципам
9. Антропологические основания этики как философии счастья
10. Сумма которую индивид может потратить за какойто период времени без изменения размера своего капитала.html