frmswarm.frm

粒子群算法的vb源程序

            
            'If local neighborhood, graph iLbest
            If iLOCAL > 0 Then
             iXcoord = Int((picSwarm1.ScaleWidth / 2#) * (1 + _
              10 * fPos(iLbest, 1) / fMaxPos))
             iYcoord = Int((picSwarm1.ScaleHeight / 2#) * (1 + _
              10 * fPos(iLbest, 2) / fMaxPos))
             picSwarm1.PSet (iXcoord, iYcoord), vbYellow
            End If
            
      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, "Neighd. size (0=global): " & iLOCAL, " Fnctn# " & iFNCTNO, _
              " #Dims " & iDIMENSIONS
            For iDimindex = 1 To iDIMENSIONS
                Print #2, "Dim. " & iDimindex, "Pos. " & fPos(iGbest, iDimindex)
            Next iDimindex
            Close #2
            finishFlag = 1
        '    End                     'END PROGRAM
        End If

    Label_gen.Caption = CStr(nIter)
    Label_bfit.Caption = CStr(fPbestVal(iGbest))
    Label_binx.Caption = CStr(iGbest)
    
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 evalf0(iPopindex)              'Evaluates spherical f0 function error
        fErrVal(iPopindex) = 0#
        
        For iDimindex = 1 To iDIMENSIONS
            fErrValDim = (fPos(iPopindex, iDimindex)) ^ 2
            fErrVal(iPopindex) = fErrVal(iPopindex) + fErrValDim
        Next iDimindex
        
    End Sub
    
    Sub evalf1(iPopindex)               ' Evaluates Rosenbrock f1 function error
        fErrVal(iPopindex) = 0#
        
        For iDimindex = 1 To iDIMENSIONS - 1
            fErrValDim = 100# * (fPos(iPopindex, iDimindex + 1) - (fPos(iPopindex, iDimindex)) ^ 2) ^ 2 + (fPos(iPopindex, iDimindex) - 1) ^ 2
            fErrVal(iPopindex) = fErrVal(iPopindex) + fErrValDim
        Next iDimindex
        
    End Sub

    Sub evalf2(iPopindex)               ' Evaluates Rastrigrin f2 function error
        fErrVal(iPopindex) = 0#
        
        For iDimindex = 1 To iDIMENSIONS
            fErrValDim = (fPos(iPopindex, iDimindex)) ^ 2 + 10# - 10# * Cos(2# * conPI * fPos(iPopindex, iDimindex))
            fErrVal(iPopindex) = fErrVal(iPopindex) + fErrValDim
        Next iDimindex
    End Sub

    Sub evalf3(iPopindex)       ' Evaluates Griewank f3 function error
        Dim fFirstDim As Double, fSecondDim As Double
        Dim fFirstTot As Double, fSecondTot As Double
        fErrVal(iPopindex) = 0#
        fFirstTot = 0#
        fSecondTot = 1#
    
        For iDimindex = 1 To iDIMENSIONS
            fFirstDim = (fPos(iPopindex, iDimindex)) ^ 2
            fFirstTot = fFirstTot + fFirstDim
            fSecondDim = Cos(fPos(iPopindex, iDimindex) / Sqr(iDimindex))
            fSecondTot = fSecondTot * fSecondDim
        Next iDimindex
        
        fErrVal(iPopindex) = (0.00025 * fFirstTot) - fSecondTot + 1#
    End Sub
    
    Sub evalf5(iPopindex)           'Evaluates He f5 function error
        fErrVal(iPopindex) = (fPos(iPopindex, 1)) ^ 2 + 2# * (fPos(iPopindex, 2)) ^ 2 - _
        0.3 * Cos(3# * conPI * fPos(iPopindex, 1)) - 0.4 * Cos(4# * conPI * fPos(iPopindex, 2)) + 0.7
    End Sub



Private Sub DimensionText_KeyPress(KeyAscii As Integer)
    Select Case KeyAscii
        Case Is < 32    'Control keys are OK.
        Case 48 To 57   'This is a digit
        Case Else       'Reject any other key
            KeyAscii = 0
    End Select

End Sub

Private Sub DimensionText_Validate(Cancel As Boolean)
    'Check that field is not empty
    If DimensionText.Text = "" Then
        MsgBox "Please enter positive number here", vbExclamation
        Cancel = True
    End If
End Sub

Private Sub Form_Load()
    Timer1.Interval = 50    ' timer event interval
    iFNCTNO = -1            ' default function
    
    frmSwarm.Show
End Sub


Private Sub GloLocText_KeyDown(KeyCode As Integer, Shift As Integer)
    Select Case KeyCode
        Case vbKeyUp
            GloLocText.Text = 1
        Case vbKeyDown
            GloLocText.Text = 0
        End Select
End Sub

Private Sub GloLocText_KeyPress(KeyAscii As Integer)
    Select Case KeyAscii
        Case Is < 32    'Control keys are OK.
        Case 48 To 57   'This is a digit 0 or 1
        Case Else       'Reject any other key
            KeyAscii = 0
    End Select

End Sub

Private Sub GloLocText_Validate(Cancel As Boolean)
    'Check that field is not empty
    If GloLocText.Text = "" Then
        MsgBox "Please enter either 0(global) or 1(local) here", vbExclamation
        Cancel = True
    End If
End Sub

Private Sub InertiaWText_KeyPress(KeyAscii As Integer)
    Select Case KeyAscii
        Case Is < 32    'Control keys are OK.
        Case Is = 46    ' .
        Case 48 To 57   'This is a digit
        Case Else       'Reject any other key
            KeyAscii = 0
    End Select

End Sub

Private Sub InertiaWText_Validate(Cancel As Boolean)
    'Check that field is not empty
    If InertiaWText.Text = "" Then
        MsgBox "Please enter a numeric value here", vbExclamation
        Cancel = True
    End If
End Sub

Private Sub List_fun_Click()
    iFNCTNO = List_fun.ListIndex
    Select Case iFNCTNO             ' returns fErrVal(iPopindex)
              Case 0
                Label_fun.Caption = "Sphere"
              Case 1
                Label_fun.Caption = "Rosenbrock"
              Case 2
                Label_fun.Caption = "Generalized Rastrigrin"
              Case 3
                Label_fun.Caption = "Generalized Greiwank"
              Case 4
                iFNCTNO = 6
                Label_fun.Caption = "Shaffer F6"
                
    End Select
End Sub

Private Sub MaxIterText_KeyPress(KeyAscii As Integer)
    Select Case KeyAscii
        Case Is < 32    'Control keys are OK.
        Case 48 To 57   'This is a digit
        Case Else       'Reject any other key
            KeyAscii = 0
    End Select

End Sub

Private Sub MaxIterText_Validate(Cancel As Boolean)
    'Check that field is not empty
    If MaxIterText.Text = "" Then
        MsgBox "Please enter positive integer here", vbExclamation
        Cancel = True
    End If
End Sub

Private Sub MaxPText_KeyPress(KeyAscii As Integer)
    Select Case KeyAscii
        Case Is < 32    'Control keys are OK.
        Case Is = 46    ' .
        Case 48 To 57   'This is a digit
        Case Else       'Reject any other key
            KeyAscii = 0
    End Select

End Sub

Private Sub MaxPText_Validate(Cancel As Boolean)
    'Check that field is not empty
    If MaxPText.Text = "" Then
        MsgBox "Please enter positive number here", vbExclamation
        Cancel = True
    End If
End Sub

Private Sub MaxVText_KeyPress(KeyAscii As Integer)
    Select Case KeyAscii
        Case Is < 32    'Control keys are OK.
        Case Is = 46    ' .
        Case 48 To 57   'This is a digit
        Case Else       'Reject any other key
            KeyAscii = 0
    End Select

End Sub

Private Sub MaxVText_Validate(Cancel As Boolean)
    'Check that field is not empty
    If MaxVText.Text = "" Then
        MsgBox "Please enter positive integer here", vbExclamation
        Cancel = True
    End If
End Sub

Private Sub MinErrorText_KeyPress(KeyAscii As Integer)
    Select Case KeyAscii
        Case Is < 32    'Control keys are OK.
        Case Is = 46    ' .
        Case 48 To 57   'This is a digit
        Case Else       'Reject any other key
            KeyAscii = 0
    End Select
End Sub

Private Sub MinErrorText_Validate(Cancel As Boolean)
    'Check that field is not empty
    If MinErrorText.Text = "" Then
        MsgBox "Please enter a numeric value here", vbExclamation
        Cancel = True
    End If
End Sub

Private Sub OutFileText_Validate(Cancel As Boolean)
    'Check that field is not empty
    If OutFileText.Text = "" Then
        MsgBox "Please enter a result file name here", vbExclamation
        Cancel = True
    End If
End Sub

Private Sub PopSizeText_KeyPress(KeyAscii As Integer)
    Select Case KeyAscii
        Case Is < 32    'Control keys are OK.
        Case 48 To 57   'This is a digit
        Case Else       'Reject any other key
            KeyAscii = 0
    End Select

End Sub

Private Sub PopSizeText_Validate(Cancel As Boolean)
    'Check that field is not empty
    If PopSizeText.Text = "" Then
        MsgBox "Please enter a positive integer here", vbExclamation
        Cancel = True
    End If
End Sub

Private Sub Timer1_Timer()
    Timer1.Enabled = False
    oneg (nIter)
    nIter = nIter + 1
    If finishFlag = 1 Then
        cmdStart.Enabled = True
        cmdSwarm.Enabled = False
        cmdPause.Enabled = False
        cmdStop.Enabled = False
        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
            
        timerFlag = 0
    End If
    
    If timerFlag = 1 Then
        Timer1.Enabled = True
            
    End If
End Sub