form1.frm

用VISUAL BASIC写的遗传算法模板,可以实现一元高次方程的最大值或最小值的求解

VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   3255
   ClientLeft      =   60
   ClientTop       =   450
   ClientWidth     =   5070
   LinkTopic       =   "Form1"
   ScaleHeight     =   3255
   ScaleWidth      =   5070
   StartUpPosition =   3  'Windows Default
   Begin VB.CommandButton Command2 
      Caption         =   "退出"
      Height          =   495
      Left            =   2880
      TabIndex        =   2
      Top             =   1920
      Width           =   1095
   End
   Begin VB.TextBox Text1 
      Height          =   855
      Left            =   360
      TabIndex        =   1
      Text            =   "Text1"
      Top             =   480
      Width           =   4215
   End
   Begin VB.CommandButton Command1 
      Caption         =   "开始"
      Height          =   495
      Left            =   840
      TabIndex        =   0
      Top             =   1920
      Width           =   1095
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

'遗传算法参数
Dim GeneLength As Integer '染色体长度
Dim swarmNum As Integer '种群规模
Dim Pc As Double '杂交概率
Dim Pm As Double '突变概率
Dim maxNum As Integer '遗传算法循环次数
Dim panelBool As Boolean
Dim tournamentBool As Boolean

'种群适应度统计
Dim optGene As Integer '最佳个体的位置
Dim worstGene As Integer '最差个体的位置
Dim sumFitness As Double '适应度总和
Dim meanFitness As Double '平均适应度
Dim maxFitness As Double '最大适应度
Dim minFitness As Double '最小适应度
Dim stdevFitness As Double '适应度标准差
Dim oriPool() As Double    '初始池
Dim MatePool() As Double    '交配池
Dim Fitness() As Double
Dim panelFitness() As Double
Dim FileNum As Integer

'轮盘赌博选择算子
Function panelSelection(Fitness() As Double) As Integer
    
    Dim index, fir, las, i As Integer
    Dim temp, sum, sumFitness As Double
    
    fir = LBound(Fitness)
    las = UBound(Fitness)
    sumFitness = 0
    For i = fir To las
        sumFitness = sumFitness + Fitness(i)
    Next i
    temp = Rnd * sumFitness             '产生随机数
    
    index = fir - 1
    sum = 0
    
    Do While sum < temp
        index = index + 1
        sum = sum + Fitness(index)
    Loop
    If index = fir - 1 Then
        panelSelection = fir
    Else
        panelSelection = index          '轮盘赌博选择算子
    End If

End Function


Function tournamentSele(Fitness() As Double) As Integer               '锦标赛选择算子
Dim i, j As Integer
i = Int(swarmNum * Rnd + 1)
j = Int(swarmNum * Rnd + 1)
If Fitness(i) >= Fitness(j) Then
  tournamentSele = i
Else
  tournamentSele = j
End If
End Function


Private Sub outFitness(oriPool() As Double, swarmNum As Integer)      '计算种群适应度
    
    Dim i, j As Integer
    Dim a, b, e As Double
    
    Fitness(1) = 0
    For i = 1 To swarmNum                          '//***计算适应度语句***//
        Fitness(i) = 5 - ((Sin(oriPool(i, 1) - 3.8)) ^ 2 + (Sin(oriPool(i, 2) - 3.9)) ^ 2 _
        + (Sin(oriPool(i, 3) - 4)) ^ 2 + (Sin(oriPool(i, 4) - 4.1)) ^ 2 + (Sin(oriPool(i, 5) - 4.2)) ^ 2)
    Next i                                        '//***计算适应度语句结束***//
    
    sumFitness = 0
    maxFitness = Fitness(1)                        '最大适应值
    minFitness = Fitness(1)                        '最小适应值
    optGene = 1                                    '最优基因
    worstGene = 1                                  '最差基因
    For i = 1 To swarmNum
        sumFitness = sumFitness + Fitness(i)       '适应度总和
        If Fitness(i) > maxFitness Then
            maxFitness = Fitness(i)
            optGene = i
        End If
        If Fitness(i) < minFitness Then
            minFitness = Fitness(i)
            worstGene = i
        End If
    Next i
    meanFitness = sumFitness / swarmNum            '平均适应度
    stdevFitness = 0
    For i = 1 To swarmNum
        stdevFitness = stdevFitness + (Fitness(i) - meanFitness) ^ 2
    Next i
    stdevFitness = stdevFitness / swarmNum         '适应度标准差
    If maxFitness <> meanFitness Then
        e = 1.5
        a = (e - 1) * meanFitness / (maxFitness - meanFitness)
        b = (1 - a) * meanFitness
        For i = 1 To swarmNum
            panelFitness(i) = a * Fitness(i) + b   '轮盘适应度
            If panelFitness(i) < 0 Then
                panelFitness(i) = 0
            End If
        Next i
    Else
        For i = 1 To swarmNum
            panelFitness(i) = Fitness(i)
        Next i
    End If
End Sub

Private Sub Command1_Click()
                                                   '初始种群的生成
    Dim i, j As Integer
    Dim iterNum As Integer                         '杂交代数
    Dim coupleNum As Integer
    Dim wife, husband As Integer
    Dim mateLocation As Integer
    Dim tempint As Integer
    Dim tempdbl As Double
    Dim mutationLoc As Integer
    Dim copySelection As Integer
    Dim tempRnd As Double
    Dim str As String
    FileNum = FreeFile
    Open "C:\GaResult.txt" For Output As FileNum
    
    swarmNum = 300                   '种群规模，表示一代里面的个体的数目
    Pc = 0.8                       '杂交概率
    Pm = 0.001                     '突变概率
        
    maxNum = 30                     '遗传算法循环次数，即总杂交的代数
    panelBool = True               '转盘算子标志
    tournamentBool = False          '锦标赛算子标志
    
    GeneLength = 5                 '染色体长度
    coupleNum = CInt(swarmNum * Pc / 2)   '杂交位置数
    
    ReDim oriPool(1 To swarmNum, 1 To GeneLength)           '初始池（种群规模，染色体长度）
    ReDim MatePool(1 To swarmNum, 1 To GeneLength)          '交配池（种群规模，染色体长度）
    ReDim Fitness(1 To swarmNum)                            '适应度函数
    ReDim panelFitness(1 To swarmNum)                       '转盘适应度函数
    
    Randomize
    
    For i = 1 To swarmNum                  '//***初始化种群***//
        For j = 1 To GeneLength
            oriPool(i, j) = 2 * Rnd + 3  '由种群数目个染色体长度维的向量组成的矩阵
        Next j
    Next i                                '//***初始化种群***//
    
    For iterNum = 1 To maxNum
        Call outFitness(oriPool, swarmNum)               '调用适应度函数，计算种群适应度
        
        Print #FileNum, "第" + CStr(iterNum) + "代解"            '打印输出计算结果开始
        For i = 1 To swarmNum
            str = ""
            For j = 1 To GeneLength
                If TypeName(oriPool(i, j)) = "Double" Then
                    str = str & Format(oriPool(i, j), "0.00") & ","
                Else
                    str = str & CStr(oriPool(i, j))
                End If
            Next j

            If TypeName(oriPool(i, 1)) = "Double" Then
                str = Left(str, Len(str) - 1)
            End If
            Print #FileNum, str, Format(Fitness(i), "0.00") '输出
        Next i                '输出种群中各个体，个体包括各染色体及该个体的适应度
        str = "最优个体 "
        For j = 1 To GeneLength
            If TypeName(oriPool(optGene, j)) = "Double" Then
                str = str & Format(oriPool(optGene, j), "0.00") & ","
            Else
                str = str & CStr(oriPool(optGene, j))
            End If
        Next j                                                      '输出最优个体及其适应度
        If TypeName(oriPool(optGene, GeneLength)) = "Double" Then
            str = Left(str, Len(str) - 1)
        End If
        Print #FileNum, str, Format(Fitness(optGene), "0.00")

        str = "最差个体 "
        For j = 1 To GeneLength
            If TypeName(oriPool(worstGene, j)) = "Double" Then
                str = str & Format(oriPool(worstGene, j), "0.00") & ","
            Else
                str = str & CStr(oriPool(worstGene, j))
            End If
        Next j
        If TypeName(oriPool(worstGene, GeneLength)) = "Double" Then
            str = Left(str, Len(str) - 1)
        End If                                                       '输出最差个体及其适应度
        Print #FileNum, str, Format(Fitness(worstGene), "0.00")
        str = "平均适应度 = " & Format(meanFitness, "0.00") & " ; "
        str = str & "适应度标准差 = " & Format(stdevFitness, "0.00")
        Print #FileNum, str                                '‘打印输出计算结果结束
        
        For i = 1 To swarmNum                                      '//***复制算子***//
            If panelBool Then
                copySelection = panelSelection(panelFitness)    '轮盘赌博选择算子
            End If
            If tournamentBool Then
                copySelection = tournamentSele(Fitness)         '锦标赛选择算子
            End If
            For j = 1 To GeneLength
            MatePool(i, j) = oriPool(copySelection, j)      '将初始池里的最优个体放入交配池
            Next j
        Next i                                                     '//***复制算子***//
     
        For i = 1 To coupleNum                                            '进行交换
            wife = Int(swarmNum * Rnd + 1)                      '杂交母体
            husband = Int(swarmNum * Rnd + 1)                   '杂交父体
            mateLocation = Int(GeneLength * Rnd + 1)            '杂交位置
            For j = 1 To mateLocation
                If TypeName(MatePool(wife, j)) = "Double" Then
                    tempdbl = MatePool(wife, j)
                    MatePool(wife, j) = MatePool(husband, j)
                    MatePool(husband, j) = tempdbl
                Else
                    tempint = MatePool(wife, j)
                    MatePool(wife, j) = MatePool(husband, j)
                    MatePool(husband, j) = tempint
                End If
            Next j
        Next i                                                           '交换结束
        
'        For i = 1 To swarmNum                            '//***二进制编码变异***//
'            For j = 1 To GeneLength
'                tempRnd = Rnd
'                If tempRnd <= Pm Then
'                    MatePool(i, j) = MatePool(i, j)*(  1+)   '？？？？？？？？？？？？？？？？？？？？？？？？？？？？？？？？？？？？
'                End If
'            Next j
'
'        Next i                                           '//***二进制编码变异结束***//
'
        For i = 1 To swarmNum                            '//***二进制编码变异***//
            j = GeneLength / 2
            tempRnd = Rnd
            If tempRnd <= Pm Then
                MatePool(i, j) = 2 * Rnd + 3          'MatePool(i, j)*(  1+)
            End If
        Next i
        
        For i = 1 To swarmNum                            '//***将交配池的个体复制到原始池***//
            For j = 1 To GeneLength
                oriPool(i, j) = MatePool(i, j)
            Next j
        Next i
    Next iterNum
    Text1.Text = "运算结束，点击退出！"
End Sub

Private Sub Command2_Click()
    End
    Unload Me
    
End Sub

Private Sub Form_Load()
    Text1.Text = "点击开始，运算结果将保存在C:\GaRsult.txt中。"
End Sub