frmswarm.frm

用VB编的微粒群算法程序

VERSION 5.00
Begin VB.Form frmSwarm 
   Caption         =   "Form1"
   ClientHeight    =   7350
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   8520
   LinkTopic       =   "Form1"
   ScaleHeight     =   7350
   ScaleWidth      =   8520
   StartUpPosition =   3  'Windows Default
   Begin VB.CommandButton cmdSwarm 
      Caption         =   "Fly the Swarm"
      Height          =   495
      Left            =   3840
      TabIndex        =   1
      Top             =   6600
      Width           =   1215
   End
   Begin VB.PictureBox picSwarm1 
      DrawWidth       =   3
      Height          =   4695
      Left            =   1080
      ScaleHeight     =   4635
      ScaleWidth      =   4995
      TabIndex        =   0
      Top             =   360
      Width           =   5055
   End
End
Attribute VB_Name = "frmSwarm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
' Particle swarm VB5 software by Russ Eberhart
' Last modified on May 13, 1998 new loops and lbest
Option Explicit
Option Base 1
  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
  
Private Sub cmdSwarm_Click()
  iDIMENSIONS = 2               ' Set number of dimensions for problem
  
  
  Open "psoinput.txt" For Input As #1
    Input #1, iPOPSIZE, fERRCUTOFF, fMAXVEL, fMaxPos, nMAXITER, iUSEBETTER, _
      fINITWT, iLOCAL, sOutfile
     ' Population size, error cutoff value, maximum velocity, maximum position
     ' (range), maximum no. of iterations, use momentum (usebetter), initial
     ' inertia weight, neighborhood (0=global, even no. for local neighborhood),
     ' filename for output
  Close #1

  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)
  
    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)
            'frmSwarm.Print "Init. Pos & Vel ", fPos(iPopindex, iDimindex) _
                , fVel(iPopindex, iDimindex)        ' for diagnostic purpose
        Next iDimindex
    Next iPopindex
       
    ' Main swarm loop here
    For nIter = 1 To nMAXITER
    
        ' 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
            
            Call evalf6(iPopindex)    ' evaluates f6 function error: fErrVal(iPopindex)
            
            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
                
                If iUSEBETTER = 1 Then iBetter(iPopindex) = 1
            End If                                     ' End new Pbest loop
      Next iPopindex            'end MAIN main loop for gold gbest only
      
      Dim iXcoord As Integer, iYcoord As Integer
      picSwarm1.BackColor = vbBlack
      
      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
                    'for iPopindex = 1,goes from 0 to 2 for iHOODSIZE of 2
                    '                       from -1 to 3 for iHOODSIZE of 4
                    ' 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), vbGreen
            
      Next iPopindex                'end velocity, position, graph loop
        
        'Graph 2 dimensions of iGbest
            iXcoord = Int((picSwarm1.ScaleWidth / 2#) * (1 + _
              10 * fPos(iGbest, 1) / fMaxPos))
            iYcoord = Int((picSwarm1.ScaleHeight / 2#) * (1 + _
              10 * fPos(iGbest, 2) / fMaxPos))
            picSwarm1.PSet (iXcoord, iYcoord), vbWhite
        
        'Terminate on sufficiently low error
        If (fPbestVal(iGbest) < fERRCUTOFF) Or nIter >= nMAXITER Then
            MsgBox "Iter: " & nIter & "  Err: " & fPbestVal(iGbest) ', vbYesNo
            Open sOutfile For Append As #2       'psoutfile.txt
            Print #2, "Iter: ", nIter, " Best val: ", fPbestVal(iGbest); Now
            Print #2, "Neighborhood size (0 is global): ", iLOCAL
            For iDimindex = 1 To iDIMENSIONS
                Print #2, "Dim. ", iDimindex, "Pos. ", fPos(iGbest, iDimindex)
            Next iDimindex
            Close #2
            End                     'END PROGRAM
        End If
        
    Next nIter                       '   next nIter, end main loop
End Sub

    Sub evalf6(iPopindex)             ' evaluates f6 function error: fVal(iPopindex)
        Dim fNum As Double, fDenom As Double, fF6val As Double
        
        fNum = (Sin(Sqr((fPos(iPopindex, 1) * fPos(iPopindex, 1) + _
            fPos(iPopindex, 2) * fPos(iPopindex, 2))))) ^ 2 - 0.5
        fDenom = (1# + 0.001 * (fPos(iPopindex, 1) * fPos(iPopindex, 1) + _
            fPos(iPopindex, 2) * fPos(iPopindex, 2))) ^ 2
        fF6val = 0.5 - (fNum / fDenom)
        fErrVal(iPopindex) = 1# - fF6val
    End Sub
    
    'Sub evalsphere(iPopindex)
        'Dim fErrValdim(iPopindex, iDIMENSIONS) as Double
    
        'For iDimindex = 1 to iDIMENSIONS
            'fErrValDim(iPopindex, iDimindex) = (fPos(iPopindex, iDimindex))^2
        'Next iDimindex
    'End Sub
    

Private Sub Form_Load()
frmSwarm.Show
End Sub