Оптимизация методом Розенброка

@{Дмитрий} · Регистрация: 20.04.2012

Студворк — интернет-сервис помощи студентам

Помогите пожалуйста написать программу по методам оптимизации найти минимум функции:
f(x)=a*x1+b*x2+e^(c*x1+d*x2)
Методом Розенброка.

@{Дмитрий} · 22.04.2012, 09:30 **[ТС]**

нашел код на делфи но разобраться с ним не могу

Delphi
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
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
Пример приведен для квадратичной функции 
procedure TFrmMain.Rosenbrouke(eps:double;fp:TWorldPoint);
const n=2;
var wavex,curx:TWorldPoint;
    basis,a,b:array [1..n] of TWorldPoint;
    screen:TScreenPoint;
    gamma:double;
    cappa:array[1..n] of double;
    k,j,i:integer;
begin
basis[1].x:=1;basis[1].y:=0;//сначала базис совпадает со стандартным
basis[2].x:=0;basis[2].y:=1;
curx:=fp;{нормальные к-ые точки (используются после исчерпывающего спуска)}
wavex:=fp;{x с волной и с нижним индексом-промежуточные точки}
k:=1;
while true do
begin
  for j:=1 to n do
  begin
    xk:=wavex;
    uk:=basis[j];
        cappa[j]:=MakeDichotomy(-1,1,1e-5,eps/100,Pseudo1D);
        wavex.x:=wavex.x+cappa[j]*basis[j].x;
        wavex.y:=wavex.y+cappa[j]*basis[j].y;
        World2Screen(Area,CopyScr.Canvas.ClipRect,wavex,Screen);
        Copyscr.Canvas.LineTo(Screen.x,Screen.y);
  end; {for j}
  if sqrt(sqr(wavex.x-curx.x)+sqr(wavex.y-curx.y))<eps then break
  else curx:=wavex;
      World2Screen(Area,CopyScr.Canvas.ClipRect,curx,Screen);
      Copyscr.Canvas.LineTo(Screen.x,Screen.y);
      SetPoint(curx);
      BuiltReport(curx,curx,k,0);
  for j:=1 to n do
  begin
    if abs(cappa[j])<eps*0.01 then
           a[j]:=basis[j]
        else
         begin
            a[j].x:=0;a[j].y:=0;
            for i:=j to n do
            begin
                a[j].x:=a[j].x+cappa[i]*basis[i].x;
                a[j].y:=a[j].y+cappa[i]*basis[i].y;
            end;
         end;
  end;{for j}
  b[1]:=a[1];
       gamma:=sqrt(sqr(b[1].x)+sqr(b[1].y));
       basis[1].x:=b[1].x/gamma;
       basis[1].y:=b[1].y/gamma;
  for j:=2 to n do
  begin
      b[j]:=a[j];
      for i:=1 to j-1 do
      begin
        gamma:=(a[j].x*basis[i].x+a[j].y*basis[i].y);
        b[j].x:=b[j].x-gamma*basis[i].x;
        b[j].y:=b[j].y-gamma*basis[i].y;
      end;
      gamma:=sqrt(sqr(b[j].x)+sqr(b[j].y));
      basis[j].x:=b[j].x/gamma;
      basis[j].y:=b[j].y/gamma;
  end; {for j}
  inc(k);
  wavex:=curx;
end; {while}
end;

@{Дмитрий} · 13.05.2012, 14:19 **[ТС]**

ABC Pascal ругается на тип extended.
Подскажите что делать?

@sheldon-yura · 13.05.2012, 14:24

попробуй его убрать. АВС не знает что это.

@Puporev · 13.05.2012, 14:53

замени на real;

@{Дмитрий} · 13.05.2012, 17:11 **[ТС]**

когда я пишу тип real, прога выдает ошибку о переполнении.

@Puporev · 13.05.2012, 17:14

Значит выкинь АВС.

Добавлено через 1 минуту
А вообще что за задача, требующая extended?

@{Дмитрий} · 13.05.2012, 17:16 **[ТС]**

прога по методу оптимизации. Метод Розеброка.

@{Дмитрий} · 13.05.2012, 17:33 **[ТС]**

Попробывал сделать прогу по нахождению минимума методом розенброка.
помогите исправить ошибки.

Pascal
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
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
program Project1;
{$N+,E+}
uses crt;
const
a=3;
q=-0.5;
eps=0.01;
label 0,1,2,3,4,5,6,7,8,9,10;
var k,h,ps,bs,fy1,fb,fi,fl,norm :real;
z:extended;
i,j,n,fe :integer;
x,y,b,p,d1,d2,y1,l,aa,bb :array[1..10] of real;
 
procedure calculate;
begin
z:=x[1]-1.4*x[2]+exp(0.01*x[1]+0.11*x[2]);
fe:=fe+1; (*** chetchik ***)
end;
 
begin
write('Vvedite chislo peremenych:');
readln(n);
writeln;
writeln('Vvedite nachalnuy tochku x1,x2,…,xN');
for i:=1 to n do readln(x[i]);
writeln;
writeln('Vvedite dlinu chaga');
readln(h);
writeln;
k:=h;
fe:=0;
d1[1]:=1;
d1[2]:=0;
d2[1]:=0;
d2[2]:=1;
for i:=1 to n do
    begin
    y[i]:=x[i];
    p[i]:=x[i];
    b[i]:=x[i];
    end;
calculate;
fi:=z;
writeln('Nachalnoe znacenie function', z:2:6);
for i:=1 to n do writeln(x[i]:2:6);
ps:=0;
bs:=1;
(*** Isledovanie vokrug basisnoi tochki ***)
j:=1;
fb:=fi;
fl:=fi;
 
0: x[j]:=y[j]+(k*d1[i]+k*d2[i]);
calculate;
if z<fi then goto 1;
x[j]:=y[j]-(k*d1[i]+k*d2[i]);
calculate;
if z>=fi then goto 4;
1: y[j]:=x[j];
   k:=k*a;
   goto 2;
4:x[j]:=y[j];
     k:=k*q;
     goto 2;
2: calculate;
fi:=z;
if j=n then goto 3
else
j:=j+1;
goto 0;
3: if fi<fl then goto 6;
if fi=fl then goto 5;
5:
if fi<fb then goto 8;
if fi=fb then
  if k<=eps then goto 7
else j:=1;
    y[i]:=x[j];
goto 0;
 
6: for i:=1 to n do
   begin
   y[i]:=x[j];
   end;
j:=1;
goto 0;
8:   x[j]:=y[i];
 norm:=sqrt(sqr(x[fe+1]-x[fe]));
 if norm<=eps then goto 7
 else
 l[1]:=(x[j]-y[j])/d1[i];
 l[2]:=(x[j]-y[j])/d2[i];
 if l[i]=0 then aa[1]:=d1[i];
 aa[2]:=d2[i];
  if l[i]<>0 then aa[1]:=l[1]*d1[i];
  aa[2]:=l[2]*d2[i];
  if j=1 then bb[i]:=aa[i]
  else bb[i]:=aa[i]-(aa[1]*d1[i]+aa[2]*d2[i]);
  d1[i]:=bb[1]/(sqrt(sqr(bb[1]-bb[2])));
  d2[i]:=bb[2]/(sqrt(sqr(bb[1]-bb[2])));
  j:=1;
  y[i]:=x[j];
7: writeln('Min naiden');
for i:=1 to n do
writeln('x(',i,')=',p[i]:2:6);
writeln;
writeln('Min f(x) = ',' ',fb:2:6);
writeln('kolichesvo vyichilenii function',' ',fe);
readln(n);
end.

@sheldon-yura · 13.05.2012, 19:22

скинь прогу

@{Дмитрий} · 13.05.2012, 20:52 **[ТС]**

Pascal
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
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
program Project1;
{$N+,E+}
uses crt;
const
//n=2;
a=3;
q=-0.5;
//b=-0.5;
eps=0.01;
label 0,1,2,3,4,5,6,7,8,9,10;
var k,h,ps,bs,fy1,fb,fi,fl,norm :real;
z:extended;
i,j,n,fe :integer;
x,y,b,p,d1,d2,y1,l,aa,bb :array[1..10] of real;
 
procedure calculate;
begin
z:=x[1]-1.4*x[2]+exp(0.01*x[1]+0.11*x[2]);
fe:=fe+1; (*** chetchik ***)
end;
 
begin
write('Vvedite chislo peremenych:');
readln(n);
writeln;
writeln('Vvedite nachalnuy tochku x1,x2,…,xN');
for i:=1 to n do readln(x[i]);
writeln;
writeln('Vvedite dlinu chaga');
readln(h);
writeln;
k:=h;
fe:=0;
d1[1]:=1;
d1[2]:=0;
d2[1]:=0;
d2[2]:=1;
for i:=1 to n do
    begin
    y[i]:=x[i];
    p[i]:=x[i];
    b[i]:=x[i];
    end;
calculate;
fi:=z;
writeln('Nachalnoe znacenie function', z:2:6);
for i:=1 to n do writeln(x[i]:2:6);
ps:=0;
bs:=1;
(*** Isledovanie vokrug basisnoi tochki ***)
j:=1;
fb:=fi;
fl:=fi;
 
0: x[j]:=y[j]+(k*d1[i]+k*d2[i]);
calculate;
if z<fi then goto 1;
x[j]:=y[j]-(k*d1[i]+k*d2[i]);
calculate;
if z>=fi then goto 4;
1: y[j]:=x[j];
   k:=k*a;
   goto 2;
4:x[j]:=y[j];
     k:=k*q;
     goto 2;
2: calculate;
fi:=z;
if j=n then goto 3
else
j:=j+1;
goto 0;
3: if fi<fl then goto 6;
if fi=fl then goto 5;
5:
if fi<fb then goto 8;
if fi=fb then
  if k<=eps then goto 7
else j:=1;
    y[i]:=x[j];
goto 0;
 
6: for i:=1 to n do
   begin
   y[i]:=x[j];
   end;
j:=1;
goto 0;
8:   x[j]:=y[i];
 norm:=sqrt(sqr(x[fe+1]-x[fe]));
 if norm<=eps then goto 7
 else
 l[1]:=(x[j]-y[j])/d1[i];
 l[2]:=(x[j]-y[j])/d2[i];
 if l[i]=0 then aa[1]:=d1[i];
 aa[2]:=d2[i];
  if l[i]<>0 then aa[1]:=l[1]*d1[i];
  aa[2]:=l[2]*d2[i];
  if j=1 then bb[i]:=aa[i]
  else bb[i]:=aa[i]-(aa[1]*d1[i]+aa[2]*d2[i]);
  d1[i]:=bb[1]/(sqrt(sqr(bb[1]-bb[2])));
  d2[i]:=bb[2]/(sqrt(sqr(bb[1]-bb[2])));
  j:=1;
  y[i]:=x[j];
7: writeln('Min naiden');
for i:=1 to n do
writeln('x(',i,')=',p[i]:2:6);
writeln;
writeln('Min f(x) = ',' ',fb:2:6);
writeln('kolichesvo vyichilenii function',' ',fe);
readln(n);
end.

@{Дмитрий} · 18.05.2012, 23:29 **[ТС]**

я попытался написать прогу по нахождению минимума функции методом розенброка.
не считает, пишет вещественное переполнение. не пойму в чем ошибка.
Помогите плиз!

Pascal
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
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
program Project1;
uses crt;
const
n=2;
a=3;
b=-0.5;
eps=0.01;
label 0,1,2,3,4,5,6,7,8,9,10;
var dx,dy,t,h,lx,ly,norm,mx,my :real;
i,j,fe,k :integer;
x,y,p,d1,d2,y1,l,ax,ay,bx,by :array[1..10] of real;
  xx,xy: array [0..1000] of real;
 
function f(x1,x2: real): real;
begin
 f:=sqr(x1+x2)+sqr(x2+6);
end;
 
begin
 k:=0; d1[1]:=1;d1[2]:=0;d2[1]:=0;d2[2]:=1;
 xx[k]:=4; {задание точки}
 xy[k]:=-8;
 dx:=1;
 dy:=1;
 t:=1;
 i:=1;
 xx[i]:=xx[k];
 xy[i]:=xy[k];
 
 2:
   for j:=1 to n do
    begin
 if f(xx[i]+t*d1[j],xy[i])<f(xx[i],xy[i]) then
 begin
  xx[i+1]:=xx[i]+dx;
  t:=t*a;
  end
 else
  if f(xx[i]+t*d1[j],xy[i])>=f(xx[i],xy[i]) then
   begin
   xx[i+1]:=xx[i];
   t:=t*b;
   end;
 
 if f(xx[i],xy[i]+t*d2[j])<f(xx[i],xy[i]) then
   begin
  xy[i+1]:=xy[i]+dx;
  t:=t*a;
  end
 else
  if f(xx[i],xy[i]+t*d2[j])>=f(xx[i],xy[i]) then
  begin
   xy[i+1]:=xy[i];
     t:=t*b;
  end;   end;
  goto 3;
 
 3:
 if i<n then
 begin
 inc(i);
 goto 2;
 end
 else
 if i=n then
 begin
 if f(xx[n+1],xy[n+1])<f(xx[1],xy[1]) then
 begin
 xx[1]:=xx[n+1];
 xy[1]:=xy[n+1];
  end
  else
  if f(xx[n+1],xy[n+1])=f(xx[1],xy[1])
  then
     if f(xx[n+1],xy[n+1])<f(xx[k],xy[k]) then
     goto 4
     else
        if  f(xx[n+1],xy[n+1])=f(xx[k],xy[k]) then
        begin
         if h<=eps then
            goto 6
                else
                xx[1]:=xx[n+1];
                xy[1]:=xy[n+1];
                goto 2;
     end;
       end;
 
 4:
    xx[k+1]:=xx[n+1];
     norm:=sqrt(sqr(xx[k+1]-xx[k])+sqr(xy[k+1]-xy[k]));
     if norm<=eps then
        goto 7
         else
           l[1]:=(((xx[k+1]-xx[k])*d2[2]-(xy[k+1]-xy[k])*d2[1])/(d1[1]*d2[2]-d1[2]*d2[1]));
           l[2]:=(((xx[k+1]-xx[k])*d1[2]-(xy[k+1]-xy[k])*d1[1])/(d2[1]*d1[2]-d1[1]*d2[2]));
           for j:=1 to n do
           begin
            if l[j]=0 then begin ax[j]:=d1[j];   ay[j]:=d2[j];end
            else if l[j]<>0 then ax[j]:=l[1]*d1[j]+l[2]*d2[j];  ay[j]:=l[2]*d2[j];
            end;
             for j:=1 to n do
           begin
           bx[j]:=ax[j];
            d1[j]:=(bx[j]/sqrt(sqr(bx[1])+sqr(bx[2])));
              by[j]:=ay[j]-(ay[1]*d2[1]+ay[2]*d2[2])*d2[j];
               d2[j]:=(by[j]/sqrt(sqr(by[1])+sqr(by[2])));
              end;
               inc(k);
               x[1]:=x[k+1];
               inc(i);
               goto 2;
 
     6: writeln('Min naiden');
writeln('x(1)=',xx[k]:2:6);
writeln;
writeln('x(2)=',xy[k]:2:6);
writeln;
writeln('kolichesvo vyichilenii function',' ',k);
 
     7: writeln('Min naiden');
writeln('x(1)=',xx[k+1]:2:6);
writeln;
writeln('x(2)=',xy[k+1]:2:6);
writeln;
writeln('kolichesvo vyichilenii function',' ',k);
 end.

@{Дмитрий} · 29.05.2012, 20:20 **[ТС]**

все прога сделана.

@typen2007 · 30.05.2012, 18:28

Исходник можете выложить?
Я просто следил за вашей темой, так как мне проект писать на обобщенную тему (здоровенную прогу с методами одномерных и многомерных оптимизаций).
Заранее благодарен.

@FeHix · 26.11.2012, 20:46

Если твой код еще сохранился, скинь пожалуйста сюда, буду очень благодарен.

29.11.2012, 10:39

Можете дать теорию по методу розенброка? Взял программу из темы Как реализовать метод Розенброка, а теории нет((

Новые блоги и статьи Все статьи Все блоги /
Переходник USB-CAN-GPIO Eddy_Em 20.03.2026 Достаточно давно на работе возникла необходимость в переходнике CAN-USB с гальваноразвязкой, оный и был разработан. Однако, все меня терзала совесть, что аж 48-ногий МК используется так тупо: просто. . .	Оттенки серого Argus19 18.03.2026 Оттенки серого Нашёл в интернете 3 прекрасных модуля: Модуль класса открытия диалога открытия/ сохранения файла на Win32 API; Модуль класса быстрого перекодирования цветного изображения в оттенки. . .	SDL3 для Desktop (MinGW): Рисуем цветные прямоугольники с помощью рисовальщика SDL3 на Си и C++ 8Observer8 17.03.2026 Содержание блога Финальные проекты на Си и на C++: finish-rectangles-sdl3-c. zip finish-rectangles-sdl3-cpp. zip	Символические и жёсткие ссылки в Linux. algri14 15.03.2026 Существует два типа ссылок — символические и жёсткие. Ссылка в Linux — это запись в каталоге, которая может указывать либо на inode «файла-ИСТОЧНИКА», тогда это будет «жёсткая ссылка» (hard link),. . .
[Owen Logic] Поддержание уровня воды в резервуаре количеством включённых насосов: моделирование и выбор регулятора ФедосеевПавел 14.03.2026 Поддержание уровня воды в резервуаре количеством включённых насосов: моделирование и выбор регулятора ВВЕДЕНИЕ Выполняя задание на управление насосной группой заполнения резервуара,. . .	делаю науч статью по влиянию грибов на сукцессию anaschu 13.03.2026 прикрепляю статью	SDL3 для Desktop (MinGW): Создаём пустое окно с нуля для 2D-графики на SDL3, Си и C++ 8Observer8 10.03.2026 Содержание блога Финальные проекты на Си и на C++: hello-sdl3-c. zip hello-sdl3-cpp. zip Результат:	Установка CMake и MinGW 13.1 для сборки С и C++ приложений из консоли и из Qt Creator в EXE 8Observer8 10.03.2026 Содержание блога MinGW - это коллекция инструментов для сборки приложений в EXE. CMake - это система сборки приложений. Здесь описаны базовые шаги для старта программирования с помощью CMake и. . .

@{Дмитрий} 2 / 2 / 2 Регистрация: 20.04.2012 Сообщений: 108

	Оптимизация методом Розенброка 20.04.2012, 19:01. Показов 5535. Ответов 15 Метки нет (Все метки) Помогите пожалуйста написать программу по методам оптимизации найти минимум функции: f(x)=ax1+bx2+e^(cx1+dx2) Методом Розенброка. 0

@{Дмитрий} 2 / 2 / 2 Регистрация: 20.04.2012 Сообщений: 108
	13.05.2012, 14:19 [ТС]
	ABC Pascal ругается на тип extended. Подскажите что делать? 0

@sheldon-yura 31 / 31 / 16 Регистрация: 02.11.2011 Сообщений: 216
	13.05.2012, 14:24
	попробуй его убрать. АВС не знает что это. 0

@Puporev Почетный модератор 64315 / 47611 / 32743 Регистрация: 18.05.2008 Сообщений: 115,167
	13.05.2012, 14:53
	замени на real; 0

@{Дмитрий} 2 / 2 / 2 Регистрация: 20.04.2012 Сообщений: 108
	13.05.2012, 17:11 [ТС]
	когда я пишу тип real, прога выдает ошибку о переполнении. 0

@Puporev Почетный модератор 64315 / 47611 / 32743 Регистрация: 18.05.2008 Сообщений: 115,167
	13.05.2012, 17:14
	Значит выкинь АВС. Добавлено через 1 минуту А вообще что за задача, требующая extended? 0

@{Дмитрий} 2 / 2 / 2 Регистрация: 20.04.2012 Сообщений: 108
	13.05.2012, 17:16 [ТС]
	прога по методу оптимизации. Метод Розеброка. 0

@sheldon-yura 31 / 31 / 16 Регистрация: 02.11.2011 Сообщений: 216
	13.05.2012, 19:22
	скинь прогу 0

@{Дмитрий} 2 / 2 / 2 Регистрация: 20.04.2012 Сообщений: 108
	29.05.2012, 20:20 [ТС]
	все прога сделана. 0

@typen2007 0 / 0 / 0 Регистрация: 25.09.2011 Сообщений: 12
	30.05.2012, 18:28
	Исходник можете выложить? Я просто следил за вашей темой, так как мне проект писать на обобщенную тему (здоровенную прогу с методами одномерных и многомерных оптимизаций). Заранее благодарен. 0

@FeHix 0 / 0 / 0 Регистрация: 26.11.2012 Сообщений: 15
	26.11.2012, 20:46
	Если твой код еще сохранился, скинь пожалуйста сюда, буду очень благодарен. 0

071den
	29.11.2012, 10:39
	Можете дать теорию по методу розенброка? Взял программу из темы Как реализовать метод Розенброка, а теории нет((