📄 费卜优化.frm
字号:
VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form Form1
Caption = "组合数学---费卜算法演示"
ClientHeight = 4545
ClientLeft = 60
ClientTop = 345
ClientWidth = 4605
Icon = "费卜优化.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
ScaleHeight = 4545
ScaleWidth = 4605
StartUpPosition = 3 '窗口缺省
Begin VB.TextBox Text8
Height = 270
Left = 1320
TabIndex = 17
Text = "0.000001"
Top = 1080
Width = 1695
End
Begin VB.CommandButton Command2
Caption = "清空"
Height = 375
Left = 3240
TabIndex = 16
Top = 960
Width = 1215
End
Begin VB.CommandButton Command1
Caption = "开始计算"
Height = 375
Left = 3240
TabIndex = 15
Top = 240
Width = 1215
End
Begin MSComctlLib.StatusBar StatusBar1
Align = 2 'Align Bottom
Height = 375
Left = 0
TabIndex = 14
Top = 4170
Width = 4605
_ExtentX = 8123
_ExtentY = 661
Style = 1
_Version = 393216
BeginProperty Panels {8E3867A5-8586-11D1-B16A-00C0F0283628}
NumPanels = 1
BeginProperty Panel1 {8E3867AB-8586-11D1-B16A-00C0F0283628}
EndProperty
EndProperty
End
Begin VB.TextBox Text7
Height = 270
Left = 1320
TabIndex = 12
Top = 3720
Width = 2895
End
Begin VB.TextBox Text6
Height = 270
Left = 1320
TabIndex = 11
Top = 3240
Width = 2895
End
Begin VB.TextBox Text5
Height = 270
Left = 1320
TabIndex = 9
Top = 2760
Width = 2895
End
Begin VB.TextBox Text4
Height = 270
Left = 1320
TabIndex = 5
Top = 2280
Width = 2895
End
Begin VB.TextBox Text3
Height = 270
Left = 1320
TabIndex = 4
Top = 1800
Width = 2895
End
Begin VB.TextBox Text2
Height = 270
Left = 1320
TabIndex = 3
Top = 720
Width = 1695
End
Begin VB.TextBox Text1
Height = 270
Left = 1320
TabIndex = 0
Top = 240
Width = 1695
End
Begin VB.Label Label8
Caption = "允许误差："
Height = 255
Left = 120
TabIndex = 18
Top = 1080
Width = 975
End
Begin VB.Label Label7
Caption = "分割次数："
Height = 255
Left = 240
TabIndex = 13
Top = 3720
Width = 1335
End
Begin VB.Label Label6
Caption = "极值F(X)："
Height = 255
Left = 240
TabIndex = 10
Top = 3240
Width = 1335
End
Begin VB.Label Label5
Caption = "最优解 X："
Height = 255
Left = 240
TabIndex = 8
Top = 2760
Width = 1215
End
Begin VB.Label Label4
Caption = "最终(a,b)："
Height = 255
Left = 240
TabIndex = 7
Top = 2280
Width = 1215
End
Begin VB.Label Label3
Caption = "初始(a,b)："
Height = 255
Left = 240
TabIndex = 6
Top = 1800
Width = 1215
End
Begin VB.Line Line2
BorderColor = &H80000005&
X1 = 120
X2 = 4200
Y1 = 1455
Y2 = 1455
End
Begin VB.Label Label2
Caption = "区间误差："
Height = 255
Left = 120
TabIndex = 2
Top = 720
Width = 975
End
Begin VB.Line Line1
X1 = 120
X2 = 4200
Y1 = 1440
Y2 = 1440
End
Begin VB.Label Label1
Caption = "请输入Xo："
Height = 255
Left = 240
TabIndex = 1
Top = 360
Width = 975
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim x0 As Single '变量X的初始值
Dim k As Integer '基础变量
Dim h As Single '求初始区间时候的步长
Dim tau As Single '比率0.618
Dim eps As Single '允许误差
Dim alpha As Single '系数a=i/(1-i)
Dim f0 As Single '函数f(x^(l-1))
Dim f1 As Single '函数f(x^l)
Dim f2 As Single '函数f(x^(l+1))
Dim it As Long ' 区间分割次数
Dim x As Single 'x
Dim t As Single '值x
Dim fx As Single 'f(x)
Dim a As Single 'x区间上界a^k
Dim b As Single 'x区间下界b^k
Dim c As Single '尝试计算点c^k
Dim fc As Single '函数值f(c^k)
Dim d As Single '尝试计算点d^k
Dim fd As Single '函数值f(d^k)
Dim fibo(100) As Long
'Dim nof As Integer '计算函数次数
Private Sub Command1_Click()
Dim f, y, z, fy, la, fz, x1, x2, t1, t2 As Single
Dim n As Integer
'初始化
k = 0
it = 0
tau = 0.618
alpha = tau / (1 - tau)
h = 1
'输入 x0
x0 = Val(Text1.Text)
'输入 la
la = Val(Text2.Text)
'输入误差
d = Val(Text8.Text)
eps = d
'计算f(x0)
f0 = fun(x0)
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''试探合围法确定初始区间'''''''''''''''''''''''''''''
it = 1
x1 = x0 + h
f1 = fun(x1)
it = it + 1
If f1 > f0 Then
x = x0
f = f0
x0 = x1
f0 = f1
x1 = x
f1 = f
h = (-alpha) * h
x2 = x1 + h
f2 = fun(x2)
GoTo Line2
Else
Line1: h = alpha * h
x2 = x1 + h
f2 = fun(x2)
it = it + 1
k = 1
End If
Line2: If f2 <= f1 Then
x0 = x1
f0 = f1
x1 = x2
f1 = f2
k = k + 1
GoTo Line1
Else
If h > 0 Then
a = x0
b = x2
y = x1
fy = f1
Else
a = x2
b = x0
z = x1
fz = f1
End If
End If
Text3.Text = "(" & a & " , " & b & ")"
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''费卜法''''''''''''''''''''''''''''''''''''''''
f = (b - a) / eps
k = 0
n = 1
fibo(0) = 1
fibo(1) = 1
line3: n = n + 1
fibo(n) = fibo(n - 2) + fibo(n - 1)
If fibo(n) >= f Then
k = 0
t1 = a + fibo(n - 2) * (b - a) / fibo(n)
t2 = a + fibo(n - 1) * (b - a) / fibo(n)
f1 = fun(t1)
f2 = fun(t2)
Else
GoTo line3
End If
line4: If f1 < f2 Then
a = a
b = t2
t2 = t1
f2 = f1
t1 = a + fibo(n - k - 3) * (b - a) / fibo(n - k - 1)
f1 = fun(t1)
Else
b = b
a = t1
t1 = t2
f1 = f2
t2 = a + fibo(n - k - 2) * (b - a) / fibo(n - k - 1)
f2 = fun(t2)
End If
k = k + 1
If k < n - 3 Then GoTo line4
If k = n - 3 Then
t1 = a + (1 - la) * (b - a) / 2
f1 = fun(t1)
t2 = a + (1 + la) * (b - a) / 2
f2 = fun(t2)
End If
Debug.Print (t1)
If f1 < f2 Then
x = t1
Else
x = t2
End If
'数据输出
Text4.Text = "(" & a & " , " & b & ")"
Text5.Text = x
Text6.Text = fun(x)
Text7.Text = n
'test data
StatusBar1.SimpleText = f0 & " " & a & " " & b
End Sub
Function fun(ByVal x As Single) As Single
'函数声明
fun = x * x * x + 3 * x * x - 9 * x
End Function
Private Sub Command2_Click()
Text1.Text = ""
Text2.Text = ""
Text3.Text = ""
Text4.Text = ""
Text5.Text = ""
Text6.Text = ""
Text7.Text = ""
Text8.Text = ""
StatusBar1.SimpleText = ""
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -