visual basic||нахождение минимума функции методом покоординатного градиентного спуска

Компьютерный форум OSzone.net (http://forum.oszone.net/index.php)

- Программирование и базы данных (http://forum.oszone.net/forumdisplay.php?f=21)

visual basic||нахождение минимума функции методом покоординатного градиентного спуска

Здравствуйте. Посмотрите пожалуйста правильно ли я решил задачу нахождения минимума функции методом покоординатного (градиентного спуска).
Почему-то у меня при градиентном спуске при любых значениях одна итерация итерируется.
Количество итераций при покоординатном спуске то же подозрительно мало.

Исходные данные:
Функция- a*x*x+b*y*y-c*x*y-d*y
где a,b,c,d коофициенты х,у координаты начальной точки (все вводятся с клавиатуры)также есть е(погрешность>=10^-5

Код:

Rem покоординатный спуск

Private Sub Command1_Click()

Dim a As Double

Dim b As Double

Dim c As Double

Dim d As Double

Dim x As Double

Dim y As Double

Dim e As Double



a = Text1.Text

b = Text2.Text

c = Text3.Text

d = Text4.Text

x = Text5.Text

y = Text6.Text

e = 0.000001

Dim f(2) As Double

Dim schet As Integer

schet = 0

f(0) = 1

f(1) = 0

Dim x1 As Double

Dim x2 As Double

x1 = 1

x2 = 0

While x1 - x2 > e

Rem Получаю значение функции начальное

Call fun(a, b, c, d, x, y, f(0))

x1 = x

schet = schet + 1

Rem нахожу новую точку минимума по х и по у

Call funx(a, b, c, d, x, y)

Call funy(a, b, c, d, x, y)

x2 = x

Rem значение функции с новой точкой

Call fun(a, b, c, d, x, y, f(1))

Wend

Text7.Text = f(1)

Text8.Text = schet

End Sub



Private Sub fun(a, b, c, d, x, y, f)

f = a * x * x + b * y * y - c * x * y - d * y

End Sub



Private Sub funx(a, b, c, d, x, y)

Rem y=const

Rem производная f = 2 * a * x - cy

Rem f''=2a

Dim extremum As Double

Dim toch_min As Double

extremum = (c * y) / (2 * a)

If (2 * a > 0) Then

toch_min = extremum

Rem Call fun(a, b, c, d, toch_min, y, f)

x = toch_min

End If

End Sub



Private Sub funy(a, b, c, d, x, y)

Rem x=const

Rem производная f = 1 + 2 * b * y - c * x - d

Rem f''=2*b

Dim extremum As Double

Dim toch_min As Double

extremum = (d + c * x - 1) / (2 * b)

Rem Call fun(a, b, c, d, x, toch_min, f)

If (2 * b > 0) Then

toch_min = extremum

y = toch_min

End If

End Sub





Rem градиентный спуск

Private Sub Command2_Click()

Dim a As Double

Dim b As Double

Dim c As Double

Dim d As Double

Dim x As Double

Dim y As Double

Dim e As Double



a = Text1.Text

b = Text2.Text

c = Text3.Text

d = Text4.Text

x = Text5.Text

y = Text6.Text

e = 0.000001

Dim f(3) As Double

Dim schet As Integer

f(0) = 1

f(1) = 0

f(2) = 0

f(3) = 0

Rem уменьшение функции >погрешности

While f(0) - f(1) > e

schet = schet + 1

Rem x1 = x

Rem y1 = y

Rem Получаю значение функции начальное

Call fun(a, b, c, d, x, y, f(0))

Rem нахожу новую точку минимума по х и по у

Call prox(a, b, c, d, x, y, f(2))

Call proy(a, b, c, d, x, y, f(3))

Rem значение функции с новой точкой

x = x - f(2)

y = y - f(3)

Call fun(a, b, c, d, x, y, f(1))

Wend

Text7.Text = f(1)

Text8.Text = schet

End Sub



Private Sub prox(a, b, c, d, x, y, f)

f = 2 * a * x - cy

End Sub



Private Sub proy(a, b, c, d, x, y, f)

f = 1 + 2 * b * y - c * x - d

End Sub

З.Ы. Еще надобно нарисовать график это функции, но как я рисуется такой график я не понимаю.

bezumes

Цитата:

З.Ы. Еще надобно нарисовать график это функции, но как я рисуется такой график я не понимаю.

Линиями уровня. Карты когда-нибудь видел? x-y - координаты точки, z=f(x,y) - высота. Выбираешь себе какой-нибудь базовый уровень и рисуешь на экране все точки, где f(x,y) = A +- k*B, где A - безовый уровень, B-шаг, k - от 0 до бесконечности.

Как это делать правильно я не помню. Но помню как это делал я.
0. очищаем экран
1. Цикл по всем y от 0 до Ymax
2. Цикл по всем x от 0 до Xmax
3. Если floor((f(x,y)-A)/B) <> floor((f(x+1,y)-A)/B) значит через (x, y) проходит линия уровня. рисуем точку
4. Аналогично 3, но для (x, y) и (x, y+1)

Здесь floor - окгругление вниз

Ещё можно линии раскрасить разными цветами. Или вообще применить цветовое кодирование (как на картах морей) - выбрать градиент какого-нибудь цвета. Тогда минимому функции будет соответствовать самый тёмный цвет, максимому - самый светлый.

P.S. программу не читал. Но может посмотрю потом.

А что делать если у меня при нахождении минимума покоординатным спуском при некоторых значениях прога в бесконечный цикл вываливается. В частности при значениях a=1;b=2;c=3;d=4;x=5;y=6;
я обошел эту проблему проверкой количества итераций. Причем вычисления первых итераций производится довольно шустро, а потом
при кол итераций>50 Происходит резкое замедления вычисления.
вот этим я пользовался при написании данного кода

Код:

Private Sub Command1_Click()

Dim a As Double

Dim b As Double

Dim c As Double

Dim d As Double

Dim x As Double

Dim y As Double

Dim e As Double



a = Text1.Text

b = Text2.Text

c = Text3.Text

d = Text4.Text

x = Text5.Text

y = Text6.Text

e = 0.000001

Dim f(2) As Double

Dim schet As Integer

schet = 0

f(0) = 1

f(1) = 0

Dim ex As Boolean

ex = False



While f(0) - f(1) > e And ex = False

Rem Получаю значение функции начальное

Call fun(a, b, c, d, x, y, f(0))

schet = schet + 1

Rem нахожу новую точку минимума по х и по у

Call pokminx(a, b, c, d, x, y)

Call pokminy(a, b, c, d, x, y)

Rem значение функции с новой точкой

Call fun(a, b, c, d, x, y, f(1))

If (schet >= 70) Then

ex = True

End If

Wend

Text7.Text = f(1)

Text8.Text = schet + 1

End Sub







Private Sub fun(a, b, c, d, x, y, f)

f = a * x * x + b * y * y - c * x * y - d * y

End Sub





Private Sub pokminx(a, b, c, d, x, y)

Dim f As Double

Dim f1 As Double

Rem нахожу начальное значение ф-и

Call fun(a, b, c, d, x, y, f)

x = x + 0.1

Rem увеличиваем х и снова нахожу ф-ю

Call fun(a, b, c, d, x, y, f1)

Rem Если При увеличении х ф-я уменьшаемся увеличиваем далее

If (f - f1 > 0) Then

While (f - f1 > 0)

Call fun(a, b, c, d, x, y, f)

x = x + 0.1

Call fun(a, b, c, d, x, y, f1)

Wend

Else

Rem иначе уменьшаем  до того зчто передалось и находим значение начальное

x = x - 0.1

Call fun(a, b, c, d, x, y, f)

x = x - 0.1

Call fun(a, b, c, d, x, y, f1)

While (f - f1 > 0)

Call fun(a, b, c, d, x, y, f)

x = x - 0.1

Call fun(a, b, c, d, x, y, f1)

Wend

End If

End Sub





Private Sub pokminy(a, b, c, d, x, y)

Rem аналогично предыдущей функции только вместо изменения х меняем у

Dim f As Double

Dim f1 As Double

Call fun(a, b, c, d, x, y, f)

y = y + 0.1

Call fun(a, b, c, d, x, y, f1)

If (f - f1 > 0) Then

While (f - f1 > 0)

Call fun(a, b, c, d, x, y, f)

y = y + 0.1

Call fun(a, b, c, d, x, y, f1)

Wend

Else

y = y - 0.1

Call fun(a, b, c, d, x, y, f)

y = y - 0.1

Call fun(a, b, c, d, x, y, f1)

While (f - f1 > 0)

Call fun(a, b, c, d, x, y, f)

y = y - 0.1

Call fun(a, b, c, d, x, y, f1)

Wend

End If

End Sub

покоординатный спуск:
При фиксакции константой х, получаю уравнение линии.Как у линии может быть минимум.Получается что,при f(y)->min
y->+бесконечности или - бесконечности.И что теперь, придется расматривать её на каком-то отрезке(его че, с головы брать).Есле на отрезке, то что придется искать методами дихотомии или золотого сечения(через производные то не получится, вторая производная всегда будет равна нулю а первая всегда одного знака)