form1.frm

基于VB语言的微粒群算法

VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   3090
   ClientLeft      =   60
   ClientTop       =   450
   ClientWidth     =   4680
   LinkTopic       =   "Form1"
   ScaleHeight     =   3090
   ScaleWidth      =   4680
   StartUpPosition =   3  '窗口缺省
   Begin VB.CommandButton Command1 
      Caption         =   "Command1"
      Height          =   615
      Left            =   2520
      TabIndex        =   0
      Top             =   1560
      Width           =   1815
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim X0(DataNum, 3) As Double
Dim Y0()
Private Sub Command1_Click()
Dim a() As Double, b() As Double, VaryNum%, Popsize%, MaxGeneration%, ObjectValue As Integer, M As Double
'a()  变量的取值下限 b() 变量的取值上限
'VaryNum 变量数  MaxGeneration 最大迭代数目
'Popsize 微粒群规模
VaryNum = 10              '微粒群算法中变量总数
ReDim a(VaryNum) As Double, b(VaryNum) As Double
For i = 1 To VaryNum
    a(i) = -1.5
    b(i) = 1
Next i
Popsize = 200             '微粒群算法中个体总数
MaxGeneration = 1000      '微粒群算法运行代数
ObjectValue = 0           '判断目标函数取最小值还是最大值;当取最小值时取0,取最大值时取1
M = Pso(a(), b(), VaryNum, Popsize, MaxGeneration, ObjectValue)
End Sub

Private Sub Form_Load()  '数据录入
X1 = Array(0.05, 0.1, 0.15, 0.2, 0.25, 0.3, 0.05, 0.1, 0.15, 0.2, 0.25, 0.3, 0.22, 0.33)
X2 = Array(4, 5.5, 4, 5.5, 3.5, 5, 3.5, 5, 3, 4.5, 3, 4.5, 3, 4.5, 0.46, 5.1)
X3 = Array(2, 1, 3, 1.5, 0.5, 2.5, 1, 3, 2, 0.5, 2.5, 1.5, 0.31, 1.01)
For j = 1 To DataNum
    X0(j, 1) = X1(j - 1)
    X0(j, 2) = X2(j - 1)
    X0(j, 3) = X3(j - 1)
Next j
Y0 = Array(0.112, 0.16, 0.154, 0.206, 0.15, 0.19, 0.08, 0.153, 0.09, 0.173, 0.076, 0.187, 0.15, 0.156)
End Sub

Public Function Pso(amin() As Double, amax() As Double, VaryNum As Integer, Popsize As Integer, MaxGeneration As Integer, ObjectValue As Integer)
'amin  变量的取值下限 amax 变量的取值上限
'VaryNum 变量数  MaxGeneration 最大迭代数目
'Popsize 微粒群规模
Dim RealValue(DataNum) As Double
Dim i%, j%, Generation%, PNum%
Dim c1#, c2#, Rnd1#, Rnd2#, w#
'##########重定义数组变量##############
Dim InBird() As Individual, IndividualBest() As Individual, GlobalBest As Individual
ReDim GlobalBest.v(VaryNum) As Double
ReDim GlobalBest.x(VaryNum) As Double
ReDim InBird(MaxGeneration, Popsize) As Individual, IndividualBest(Popsize) As Individual
For i = 0 To MaxGeneration
    For j = 1 To Popsize
        ReDim InBird(i, j).v(VaryNum) As Double
        ReDim InBird(i, j).x(VaryNum) As Double
    Next j
Next i
For i = 1 To Popsize
    ReDim IndividualBest(i).v(VaryNum) As Double
    ReDim IndividualBest(i).x(VaryNum) As Double
Next i
'##########重定义数组变量##############

Randomize
'##########初始化微粒群##############
For i = 1 To Popsize
    For j = 1 To VaryNum
        InBird(0, i).x(j) = amin(j) + Rnd * (amax(j) - amin(j)) '初始化变量值
    Next j
Next i
For i = 1 To Popsize
    InBird(0, i).Value = FunctionObject(InBird(0, i).x(), 0)      '通过调用函数计算目标函数值
    IndividualBest(i) = InBird(0, i)                            '初始化时将初始值作为最优值
Next i
GlobalBest = IndividualBest(1)
For i = 1 To Popsize
    If ObjectValue = 1 Then        '目标函数取最大值为目的
       If GlobalBest.Value < IndividualBest(i).Value Then
          GlobalBest = IndividualBest(i)                           '寻求初始群体中的最优位置
       End If
    ElseIf ObjectValue = 0 Then     '目标函数取最小值为目的
       If GlobalBest.Value > IndividualBest(i).Value Then
          GlobalBest = IndividualBest(i)                           '寻求初始群体中的最优位置
       End If
    End If
Next i
'##########初始化微粒群##############

For Generation = 1 To MaxGeneration
    w = 0.4 - Generation * (0.8 - 0.4) / 1000      '线性调整权重因子w的值
    c1 = 2: c2 = 2                                '比例参数
    For i = 1 To Popsize
        For j = 1 To VaryNum
Recalculation:                                    '重新计算
            Rnd1 = Rnd: Rnd2 = Rnd                '产生随机数
            '产生下一代微粒移动的距离
            InBird(Generation, i).v(j) = w * InBird(Generation - 1, i).v(j) + c1 * Rnd1 * (IndividualBest(i).x(j) - InBird(Generation - 1, i).x(j)) + c2 * Rnd2 * (GlobalBest.x(j) - InBird(Generation - 1, i).x(j))
            InBird(Generation, i).x(j) = InBird(Generation - 1, i).x(j) + InBird(Generation, i).v(j)
            If InBird(Generation, i).x(j) > amax(j) Or InBird(Generation, i).x(j) < amin(j) Then
               PNum = PNum + 1
               If PNum <= 10 Then
                  GoTo Recalculation
               Else
                  InBird(Generation, i).v(j) = Rnd
                  InBird(Generation, i).x(j) = amin(j) + (amax(j) - amin(j)) * InBird(Generation, i).v(j)
               End If
            End If
            PNum = 0
        Next j
    Next i
    For i = 1 To Popsize
        InBird(Generation, i).Value = FunctionObject(InBird(Generation, i).x(), Generation)
    Next i
    For i = 1 To Popsize   '寻求每一个微粒群个体运行至某一代时发现的最优位置
        If ObjectValue = 1 Then        '目标函数取最大值为目的
           If IndividualBest(i).Value < InBird(Generation, i).Value Then
              IndividualBest(i) = InBird(Generation, i)
           End If
        ElseIf ObjectValue = 0 Then        '目标函数取最小值为目的
           If IndividualBest(i).Value > InBird(Generation, i).Value Then
              IndividualBest(i) = InBird(Generation, i)
           End If
        End If
    Next i
    For i = 1 To Popsize
        If ObjectValue = 1 Then        '目标函数取最大值为目的
           If GlobalBest.Value < IndividualBest(i).Value Then
              GlobalBest = IndividualBest(i) '寻求整个微粒群体运行至某一代时发现的最优位置
           End If
        ElseIf ObjectValue = 0 Then       '目标函数取最小值为目的
           If GlobalBest.Value > IndividualBest(i).Value Then
              GlobalBest = IndividualBest(i) '寻求整个微粒群体运行至某一代时发现的最优位置
           End If
        End If
    Next i
    Debug.Print "当前运算到第"; Generation; " 代    ";
    Debug.Print "GlobalBest.Value="; GlobalBest.Value
Next Generation
    For i = 1 To VaryNum
        Debug.Print "GlobalBest.x("; i; ")="; GlobalBest.x(i)
    Next i
    'Call SubValue(GlobalBest.x(), RealValue())
End Function

Public Function FunctionObject(Vary() As Double, Generation As Integer) As Double
  Dim Dimension As Integer, x() As Double, i%
  Dimension = UBound(Vary)
  ReDim x(Dimension) As Double
  For i = 1 To Dimension
      x(i) = Vary(i)
  Next i
    
   '以下目标函数变时需要修改
  Dim fValue(DataNum) As Double, j%
  For j = 1 To DataNum
      fValue(j) = x(1) + x(2) * X0(j, 1) + x(3) * X0(j, 2) + x(4) * X0(j, 3) + x(5) * X0(j, 1) * X0(j, 2) + x(6) * X0(j, 1) * X0(j, 3) + x(7) * X0(j, 2) * X0(j, 3) + x(8) * X0(j, 1) ^ 2 + x(9) * X0(j, 2) ^ 2 + x(10) * X0(j, 3) ^ 2
  Next j
  FunctionObject = 0  '另初值为零，得注意这里
  For j = 1 To DataNum
        FunctionObject = FunctionObject + (fValue(j) - Y0(j - 1)) ^ 2  '剩余平方和  目标时使得此值最小
  Next j
  '以上目标函数变时需要修改
End Function

Public Sub SubValue(Vary() As Double, fValue() As Double)
  Dim Dimension As Integer, x() As Double, i%
  Dimension = UBound(Vary)
  ReDim x(Dimension) As Double
  For i = 1 To Dimension
      x(i) = Vary(i)
  Next i
    
   '以下目标函数变时需要修改
  Dim j%
  For j = 1 To DataNum
      fValue(j) = x(1) + x(2) * X0(j, 1) + x(3) * X0(j, 2) + x(4) * X0(j, 3) + x(5) * X0(j, 1) * X0(j, 2) + x(6) * X0(j, 1) * X0(j, 3) + x(7) * X0(j, 2) * X0(j, 3) + x(8) * X0(j, 1) ^ 2 + x(9) * X0(j, 2) ^ 2 + x(10) * X0(j, 3) ^ 2
  Next j
  '以上目标函数变时需要修改
    For i = 1 To DataNum
         Debug.Print "fValue("; i; ")="; fValue(i)
    Next i
End Sub