frmswarm.frm

粒子群算法的vb源程序

      Left            =   1
      TabIndex        =   7
      Top             =   1
      Width           =   900
   End
End
Attribute VB_Name = "frmSwarm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
' Particle Swarm Optimizer, version 1.0, 01/04/2000
' Visual Basic 6.0
' graph iGbest, iLbest
' Sphere, Rosenbrock, Generalized Rastrigrin, Generalized Griewank functions

Option Explicit
Option Base 1
  Dim finishFlag As Integer
  Dim timerFlag As Integer
  Dim pauseFlag As Integer

  Dim iPOPSIZE As Integer       ' Population size
  Dim iDIMENSIONS As Integer    ' Number of dimensions
  Dim iPopindex As Integer      ' Index for population
  Dim iDimindex As Integer      ' Index for dimensions
  Dim fINITWT As Single         ' Initial inertia weight
  Dim fMAXVEL As Single         ' Maximum velocity allowed
  Dim nMAXITER As Integer       ' Maximum number of iterations
  Dim nIter As Integer          ' Number of iterations
  Dim fPos() As Single          ' Position for each particle
  Dim fTempPos() As Single      ' Temporary updated position for each particle
  Dim fVel() As Single          ' Velocity for each particle
  Dim fDumVel() As Single       ' Dummy velocity vector 1-dim array
  Dim fBestPos() As Single      ' Best previous position for each particle
  Dim fMaxPos As Single         ' Dynamic range
  Dim fInerWt As Single         ' Inertia weight
  Dim fErrVal() As Double       ' Function error value calculated by eval()
  Dim fPbestVal() As Double     ' Best error value over time for each particle
  Dim fERRCUTOFF As Double      ' Error value at which system stops
  'Dim iUSEBETTER As Integer     ' Usebetter is kind of a momentum
  Dim iBetter() As Integer      ' This gets set in program
  Dim iGbest As Integer         ' Index for global best particle
  Dim iLbest As Integer         ' Index for local (neighborhood) best particle
  Dim iLOCAL As Integer         ' Neighborhood size specified in run file
  Dim iHOODSIZE As Integer      ' Neighborhood size used in program
  Dim iHOODINDEX As Integer     ' Neighborhood index (offset from particle)
  Dim iNeighbor() As Integer    ' Popindexes of neighbors resulting from iLOCAL
  Dim sOutfile As String        ' Filename for output
  Dim iXcoord As Integer, iYcoord As Integer    ' x & y coords for plots
  Dim iFNCTNO As Integer        ' Function number to be optimized (1=f1, etc.)
  Dim fErrValDim As Double      ' Error value for a single dimension
  Const conPI = 3.14159265358979    ' Define Pi

Private Sub cmdExit_Click()
    End
End Sub

Private Sub cmdHelp_Click()
    MsgBox "Particle Swarm Optimizer Version 1.0, 01/04/2000", vbExclamation
End Sub

Private Sub cmdPause_Click()
    If pauseFlag = 0 Then
        timerFlag = 0
        Timer1.Enabled = False
        pauseFlag = 1
        cmdPause.Caption = "Continue..."
    Else
        timerFlag = 1
        pauseFlag = 0
        Timer1.Enabled = True
        cmdPause.Caption = "Pause"
        
    End If
    
    cmdStart.Enabled = False
    cmdSwarm.Enabled = False
    cmdPause.Enabled = True
    cmdStop.Enabled = True
    cmdExit.Enabled = False
    cmdHelp.Enabled = True
    
    PopSizeText.Enabled = False
    DimensionText.Enabled = False
    InertiaWText.Enabled = False
    MaxVText.Enabled = False
    MaxIterText.Enabled = False
    MaxPText.Enabled = False
    MinErrorText.Enabled = False
    GloLocText.Enabled = False
    OutFileText.Enabled = False
    List_fun.Enabled = False
    
End Sub

Private Sub cmdStart_Click()
    iPOPSIZE = CInt(PopSizeText.Text)
    iDIMENSIONS = CInt(DimensionText.Text)
    fINITWT = CSng(InertiaWText.Text)
    fMAXVEL = CSng(MaxVText.Text)
    nMAXITER = CInt(MaxIterText.Text)
    fMaxPos = CSng(MaxPText.Text)
    fERRCUTOFF = CDbl(MinErrorText.Text)
    iLOCAL = CInt(GloLocText.Text)
    sOutfile = CStr(OutFileText.Text)
    
    
    If iFNCTNO = -1 Then
        MsgBox "Please select a function!", vbExclamation
    Else
        
    finishFlag = 0
    pauseFlag = 0
    timerFlag = 1
    
    nIter = 1
     cmdSwarm.Enabled = True
     cmdStart.Enabled = False
     cmdStop.Enabled = True
     
     PopSizeText.Enabled = False
    DimensionText.Enabled = False
    InertiaWText.Enabled = False
    MaxVText.Enabled = False
    MaxIterText.Enabled = False
    MaxPText.Enabled = False
    MinErrorText.Enabled = False
    GloLocText.Enabled = False
    OutFileText.Enabled = False
    List_fun.Enabled = False
    End If
End Sub

Private Sub cmdStop_Click()
    finishFlag = 1
    timerFlag = 0
    Timer1.Enabled = False
    
    cmdStart.Enabled = True
    cmdSwarm.Enabled = False
    cmdPause.Enabled = False
    cmdStop.Enabled = True
    cmdExit.Enabled = True
    cmdHelp.Enabled = True
    
    PopSizeText.Enabled = True
    DimensionText.Enabled = True
    InertiaWText.Enabled = True
    MaxVText.Enabled = True
    MaxIterText.Enabled = True
    MaxPText.Enabled = True
    MinErrorText.Enabled = True
    GloLocText.Enabled = True
    OutFileText.Enabled = True
    List_fun.Enabled = True
End Sub

Private Sub cmdSwarm_Click()
  
  cmdStart.Enabled = False
  cmdSwarm.Enabled = False
  cmdPause.Enabled = True
  cmdStop.Enabled = True
  cmdExit.Enabled = False
  cmdHelp.Enabled = False
  
  PopSizeText.Enabled = False
    DimensionText.Enabled = False
    InertiaWText.Enabled = False
    MaxVText.Enabled = False
    MaxIterText.Enabled = False
    MaxPText.Enabled = False
    MinErrorText.Enabled = False
    GloLocText.Enabled = False
    OutFileText.Enabled = False
    List_fun.Enabled = False
    
  If iFNCTNO = 6 Or iFNCTNO = 5 Then iDIMENSIONS = 2  'Set # of dimensions for f5 & f6 fnctns

  ReDim fPos(iPOPSIZE, iDIMENSIONS)
  ReDim fTempPos(iPOPSIZE, iDIMENSIONS)
  ReDim fVel(iPOPSIZE, iDIMENSIONS)
  ReDim fBestPos(iPOPSIZE, iDIMENSIONS)
  ReDim fDumVel(iDIMENSIONS)
  ReDim fErrVal(iPOPSIZE)
  ReDim fPbestVal(iPOPSIZE)
  ReDim iBetter(iPOPSIZE)
  ReDim iNeighbor(-iPOPSIZE To iPOPSIZE)

    picSwarm1.BackColor = vbBlack

    If iLOCAL > 0 Then iHOODSIZE = Int(iLOCAL / 2#) * 2# Else iHOODSIZE = iPOPSIZE
        
    Randomize
    ' Randomize the positions and velocities for entire population
    For iPopindex = 1 To iPOPSIZE
        For iDimindex = 1 To iDIMENSIONS
            fPos(iPopindex, iDimindex) = Rnd * fMaxPos
            fBestPos(iPopindex, iDimindex) = fPos(iPopindex, iDimindex)
            fVel(iPopindex, iDimindex) = Rnd * fMAXVEL
            If Rnd > 0.5 Then fPos(iPopindex, iDimindex) = -fPos(iPopindex, iDimindex)
            If Rnd > 0.5 Then fVel(iPopindex, iDimindex) = -fVel(iPopindex, iDimindex)
            
        Next iDimindex
    Next iPopindex
                            
    Timer1.Enabled = True
    

End Sub

Sub oneg(nIter)
    
      ' Update inertia weight; linear from fINITWT to 0.4
        fInerWt = ((fINITWT - 0.4) * (nMAXITER - nIter) / nMAXITER) + 0.4
        
      For iPopindex = 1 To iPOPSIZE     'MAIN main loop starts here
            'Setup dummy velocity vector for current population member
            For iDimindex = 1 To iDIMENSIONS
                fDumVel(iDimindex) = fVel(iPopindex, iDimindex)
            Next iDimindex
            
            iBetter(iPopindex) = 0          ' Set to 0 unless new Pbest achieved
            
            Select Case iFNCTNO             ' returns fErrVal(iPopindex)
              Case 0
                Call evalf0(iPopindex)      ' evals f0 spherical function error
              Case 1
                Call evalf1(iPopindex)      ' evals f1 Rosenbrock function error
              Case 2
                Call evalf2(iPopindex)      ' evals f2 Rastrigrin function error
              Case 3
                Call evalf3(iPopindex)      ' evals f3 Griewank function error
              Case 5
                Call evalf5(iPopindex)      ' evals f5 He function error
              Case 6
                Call evalf6(iPopindex)      ' evals f6 Schaffer function error
            End Select
            
            
            If nIter = 1 Then
                fPbestVal(iPopindex) = fErrVal(iPopindex)
                iGbest = 1
            End If
            
            If fErrVal(iPopindex) < fPbestVal(iPopindex) Then   'If new Pbest
                fPbestVal(iPopindex) = fErrVal(iPopindex)
                
                For iDimindex = 1 To iDIMENSIONS    ' Reset Pbest location vector
                    fBestPos(iPopindex, iDimindex) = fPos(iPopindex, iDimindex)
                Next iDimindex
                
                If fPbestVal(iPopindex) < fPbestVal(iGbest) Then
                    ' color(iGbest) = DEFAULTCOLOR  need to dim these variables
                    iGbest = iPopindex
                    ' color(iGbest) = GBESTCOLOR
                End If
                
                
            End If                                     ' End new Pbest loop
      Next iPopindex            'end MAIN main loop for gold gbest only
      
      
      For iPopindex = 1 To iPOPSIZE         'update velocity, position, graph position
      
            ' Does neighborhood calculation of iLbest
            If iLOCAL > 0 Then
                For iHOODINDEX = 0 To iHOODSIZE
                    iNeighbor(iHOODINDEX) = iPopindex - (iHOODSIZE / 2#) + iHOODINDEX
                    
                    ' Now wrap the ends of the array
                    If iNeighbor(iHOODINDEX) < 1 Then iNeighbor(iHOODINDEX) = iPOPSIZE + _
                      iNeighbor(iHOODINDEX)
                    If iNeighbor(iHOODINDEX) > iPOPSIZE Then iNeighbor(iHOODINDEX) = _
                      iNeighbor(iHOODINDEX) - iPOPSIZE
                    'Start with iNeighbor(0) as iLbest and try to beat it
                    If iHOODINDEX = 0 Then iLbest = iNeighbor(0)
                    If fPbestVal(iNeighbor(iHOODINDEX)) < fPbestVal(iLbest) Then _
                      iLbest = iNeighbor(iHOODINDEX)
                Next iHOODINDEX
            End If
                        
            If iLOCAL = 0 Then iLbest = iGbest
                        
            ' Update velocity vector for one particle Russ Reduced version
            For iDimindex = 1 To iDIMENSIONS        'fInerWt below
                fVel(iPopindex, iDimindex) = (0.5 + (Rnd / 2)) * fVel(iPopindex, iDimindex) + _
                 2# * Rnd * (fBestPos(iPopindex, iDimindex) - fPos(iPopindex, iDimindex)) + _
                 2# * Rnd * (fBestPos(iLbest, iDimindex) - fPos(iPopindex, iDimindex))
                 
                If fVel(iPopindex, iDimindex) > fMAXVEL Then
                    fVel(iPopindex, iDimindex) = fMAXVEL
                ElseIf fVel(iPopindex, iDimindex) < -fMAXVEL Then
                    fVel(iPopindex, iDimindex) = -fMAXVEL
                End If
            Next iDimindex
            
            'If it's going the right way, keep going
            If iBetter(iPopindex) = 1 Then
                For iDimindex = 1 To iDIMENSIONS
                    fVel(iPopindex, iDimindex) = fDumVel(iDimindex)
                Next iDimindex
            End If
            
          ' Graphics Loop: Graphically plot updated positions
        
            'Erase old position for two dimensions of one particle
            iXcoord = Int((picSwarm1.ScaleWidth / 2#) * (1 + _
              10 * fPos(iPopindex, 1) / fMaxPos))
            iYcoord = Int((picSwarm1.ScaleHeight / 2#) * (1 + _
              10 * fPos(iPopindex, 2) / fMaxPos))
            picSwarm1.PSet (iXcoord, iYcoord), vbBlack
            
            For iDimindex = 1 To iDIMENSIONS  'Define new positions for all dimensions
                fPos(iPopindex, iDimindex) = fPos(iPopindex, iDimindex) + _
                  fVel(iPopindex, iDimindex)
            Next iDimindex
            
            'Graph new position for two dimensions of one particle
            iXcoord = Int((picSwarm1.ScaleWidth / 2#) * (1 + _
              10 * fPos(iPopindex, 1) / fMaxPos))
            iYcoord = Int((picSwarm1.ScaleHeight / 2#) * (1 + _
              10 * fPos(iPopindex, 2) / fMaxPos))
            picSwarm1.PSet (iXcoord, iYcoord), vbRed