📄 form1.frm
字号:
VERSION 5.00
Object = "{5E9E78A0-531B-11CF-91F6-C2863C385E30}#1.0#0"; "MSFLXGRD.OCX"
Begin VB.Form Form1
Caption = "Form1"
ClientHeight = 8610
ClientLeft = 60
ClientTop = 450
ClientWidth = 10950
ForeColor = &H00FF0000&
LinkTopic = "Form1"
ScaleHeight = 8610
ScaleWidth = 10950
StartUpPosition = 3 '窗口缺省
Begin VB.OptionButton Option3
Caption = "六峰值驼背函数"
Height = 375
Left = 720
TabIndex = 14
Top = 7680
Width = 1575
End
Begin VB.Frame Frame1
Caption = "运行结果"
Height = 1935
Left = 3360
TabIndex = 6
Top = 6480
Width = 4455
Begin VB.Label Label7
Appearance = 0 'Flat
BackColor = &H80000005&
ForeColor = &H80000008&
Height = 375
Left = 720
TabIndex = 12
Top = 1440
Width = 3615
End
Begin VB.Label Label6
Caption = "f(x)="
Height = 255
Left = 120
TabIndex = 11
Top = 1560
Width = 615
End
Begin VB.Label Label5
Appearance = 0 'Flat
BackColor = &H80000005&
ForeColor = &H80000008&
Height = 375
Left = 720
TabIndex = 10
Top = 840
Width = 3615
End
Begin VB.Label Label4
Caption = "X2="
Height = 255
Left = 240
TabIndex = 9
Top = 960
Width = 375
End
Begin VB.Label Label3
Appearance = 0 'Flat
BackColor = &H80000005&
ForeColor = &H80000008&
Height = 375
Left = 720
TabIndex = 8
Top = 240
Width = 3615
End
Begin VB.Label Label2
Caption = "X1="
Height = 255
Left = 240
TabIndex = 7
Top = 360
Width = 375
End
End
Begin VB.OptionButton Option2
Caption = "Shaffer"
Height = 255
Left = 720
TabIndex = 5
Top = 7200
Width = 975
End
Begin VB.OptionButton Option1
Caption = "Rosenbrock"
Height = 255
Left = 720
TabIndex = 4
Top = 6720
Width = 1215
End
Begin VB.CommandButton Command2
Caption = "退出"
Height = 495
Left = 9120
TabIndex = 3
Top = 7680
Width = 1335
End
Begin VB.CommandButton Command1
Caption = "计算"
Height = 495
Left = 9120
TabIndex = 2
Top = 6600
Width = 1335
End
Begin MSFlexGridLib.MSFlexGrid MSFlexGrid1
Height = 4935
Left = 120
TabIndex = 1
Top = 1440
Width = 10695
_ExtentX = 18865
_ExtentY = 8705
_Version = 393216
End
Begin VB.Label Label8
Caption = "各代最优粒子数据"
BeginProperty Font
Name = "黑体"
Size = 15
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FF0000&
Height = 375
Left = 4200
TabIndex = 13
Top = 1080
Width = 2535
End
Begin VB.Label Label1
Caption = "粒子群优化算法"
BeginProperty Font
Name = "宋体"
Size = 15
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H000000FF&
Height = 375
Left = 4560
TabIndex = 0
Top = 480
Width = 2295
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Type particle
Vpart As Double
PartPos(1 To 2) As Double
PartFit As Double
pBestPos(1 To 2) As Double
pBestFit As Double
End Type
Private Type zuiyou
gBestPos(1 To 2) As Double
gBestFit As Double
End Type
Dim PartPop(1 To 50) As particle
Dim gBest As zuiyou
Private Sub Command1_Click()
Dim a As Double, b As Double, Vm As Double, sGen As Integer, sV As Double
Dim Fitness(1 To 50) As Double, Num As Double, Sum As Double, gSum As Double
a = -10: b = 20 '区间
If Option1.Value = False And Option2.Value = False And Option3.Value = False Then
MsgBox ("请先选择一个函数！")
Exit Sub
End If
'''''''''''''''''''''''''''''''''''粒子群初始化'''''''''''''''''''''''''''''''''
For i = 1 To 50
PartPop(i).Vpart = suiji(a, b) '粒子速度
For j = 1 To 2
PartPop(i).PartPos(j) = suiji(a, b) '粒子位置
PartPop(i).pBestPos(j) = PartPop(i).PartPos(j)
Next
PartPop(i).PartFit = FunValue(PartPop(i).PartPos)
PartPop(i).pBestFit = PartPop(i).PartFit
Fitness(i) = PartPop(i).PartFit
Next
Call PaiXu(Fitness)
For i = 1 To 50
If Fitness(1) = PartPop(i).PartFit Then
gBest.gBestFit = PartPop(i).PartFit
sV = PartPop(i).Vpart
For j = 1 To 2
gBest.gBestPos(j) = PartPop(i).PartPos(j) '选出全局最优的粒子
Next
End If
Next
sGen = 0
MSFlexGrid1.Clear
Call Form_Load
'''''''''''''''''''''''''''''''''粒子群优化''''''''''''''''''''''''''''''''''''''''
Do While sGen < 300
sGen = sGen + 1
For i = 1 To 50
Num = (PartPop(i).PartPos(1) + PartPop(i).PartPos(2)) / 2
Sum = (PartPop(i).pBestPos(1) + PartPop(i).pBestPos(2)) / 2
gSum = (gBest.gBestPos(1) + gBest.gBestPos(2)) / 2
Randomize
Vm = 0.729 * PartPop(i).Vpart + 2 * Rnd * (Sum - Num) + 2 * Rnd * (gSum - Num)
If Vm < a Then
PartPop(i).Vpart = a
ElseIf Vm > b Then
PartPop(i).Vpart = b
Else
PartPop(i).Vpart = Vm
End If
For j = 1 To 2
Vm = PartPop(i).PartPos(j) + PartPop(i).Vpart
If Vm < a Then
PartPop(i).PartPos(j) = a
ElseIf Vm > b Then
PartPop(i).PartPos(j) = b
Else
PartPop(i).PartPos(j) = Vm
End If
Next
PartPop(i).PartFit = FunValue(PartPop(i).PartPos)
If PartPop(i).PartFit > PartPop(i).pBestFit Then
PartPop(i).pBestFit = PartPop(i).PartFit
For j = 1 To 2
PartPop(i).pBestPos(j) = PartPop(i).PartPos(j)
Next
End If
Fitness(i) = PartPop(i).PartFit
Next
Call PaiXu(Fitness)
If Fitness(1) > gBest.gBestFit Then
For i = 1 To 50
If Fitness(1) = PartPop(i).PartFit Then
gBest.gBestFit = PartPop(i).PartFit
sV = PartPop(i).Vpart
For j = 1 To 2
gBest.gBestPos(j) = PartPop(i).PartPos(j) '选出全局最优的粒子
Next
End If
Next
End If
With MSFlexGrid1
.Rows = sGen + 1
.Row = sGen
.Col = 0
.Text = sGen
.CellAlignment = flexAlignCenterCenter
.Col = 1
.Text = sV
.CellAlignment = flexAlignCenterCenter
.Col = 2
.Text = gBest.gBestPos(1)
.CellAlignment = flexAlignCenterCenter
.Col = 3
.Text = gBest.gBestPos(2)
.CellAlignment = flexAlignCenterCenter
.Col = 4
.Text = gBest.gBestFit
.CellAlignment = flexAlignCenterCenter
End With
Loop
Label3.Caption = gBest.gBestPos(1)
Label5.Caption = gBest.gBestPos(2)
Label7.Caption = gBest.gBestFit
End Sub
Private Sub Command2_Click()
Unload Me
End Sub
Private Sub Form_Load()
With MSFlexGrid1
.FixedCols = 0
.FixedRows = 1
.AllowUserResizing = flexResizeColumns
.Rows = 2
.Cols = 5
.Row = 0
For i = 1 To 4
.ColWidth(i) = 2400
Next
.Col = 0
.Text = "进化次数"
.CellAlignment = flexAlignCenterCenter
.Col = 1
.Text = "粒子速度"
.CellAlignment = flexAlignCenterCenter
.Col = 2
.Text = "位置1"
.CellAlignment = flexAlignCenterCenter
.Col = 3
.Text = "位置2"
.CellAlignment = flexAlignCenterCenter
.Col = 4
.Text = "粒子适应度"
.CellAlignment = flexAlignCenterCenter
End With
End Sub
Private Sub PaiXu(aR() As Double) '从大到小排序
Dim t As Double, n As Integer
n = UBound(aR)
For i = 1 To n - 1
For j = i + 1 To n
If aR(i) < aR(j) Then
t = aR(i)
aR(i) = aR(j)
aR(j) = t
End If
Next j
Next i
End Sub
Private Function suiji(a As Double, b As Double) '产生[a,b]之间的随机数
Randomize
suiji = (b - a + 1) * Rnd + a
End Function
Private Function FunValue(x() As Double)
Dim Rr As Double, Xa As Double
If Option1.Value = True Then
FunValue = -(100 * (x(2) - x(1) ^ 2) ^ 2 + (1 - x(1)) ^ 2)
End If
If Option2.Value = True Then
Rr = x(1) ^ 2 + x(2) ^ 2
Xa = ((Sin(Rr ^ 0.5)) ^ 2 - 0.5) / (1 + 0.001 * Rr) ^ 2
FunValue = 0.5 - Xa
End If
If Option3.Value = True Then
FunValue = -((4 - 2.1 * x(1) ^ 2 + (x(1) ^ 4) / 3) * x(1) ^ 2 + x(1) * x(2) + (-4 + 4 * x(2) ^ 2) * x(2) ^ 2)
End If
End Function
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -