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 =   2  '屏幕中心
   Begin VB.CommandButton Command1 
      Caption         =   "计算"
      Height          =   375
      Left            =   2640
      TabIndex        =   0
      Top             =   2400
      Width           =   1935
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Base 1

'遗传算法参数
Dim Sample(GeneLength) As Double  '产生样品基因代码
Dim Generation As Integer             '运行代数
Dim OriPool(Popsize) As Individual    '初始种群
Dim MatePool(Popsize) As Individual   '子代个体
Dim Best_Index As Integer
Dim Worst_Index As Integer
Dim BestIndividual As Individual
Dim WorstIndividual As Individual
Dim CurrentBest As Individual
Dim a(Popsize, VaryNum) As Double    '代求的常数a
Dim X0(DataNum, XNum) As Double     '应变量X
Dim Y0()                            '变量值Y
Dim X1(), X2(), X3()                '初始数据
Dim aa(VaryNum)                     '求得最优a1至a10参数输出

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)
    X0(j, 2) = X2(j)
    X0(j, 3) = X3(j)
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 Sub InitPop()  '初始化种群
Dim i%, j%, k%
Randomize
For i = 1 To Popsize
    For k = 1 To VaryNum
        For j = 1 To GeneLength
             OriPool(i).Gene(k, j) = Int(2 * Rnd)
        Next j
    Next k
    For k = 1 To VaryNum
        For j = 2 To GeneLength
            OriPool(i).Gene(k, j) = (OriPool(i).Gene(k, j) + OriPool(i).Gene(k, j - 1)) Mod 2 '产生格雷码
        Next j
    Next k
Next i
End Sub

Public Function Decoding(Pool#(), L%) As Double    '解码
Dim j%, N#
    N = (Max_Var - Min_Var) / (2 ^ GeneLength - 1)
    Decoding = Min_Var
    For j = 1 To GeneLength
        Decoding = Decoding + Pool(L, j) * 2 ^ (j - 1) * N '解码
    Next j
End Function

Public Sub CalculateFitness()  '计算种群适应度
Dim i%, j%, f(Popsize) As Double
For i = 1 To Popsize
    For j = 1 To VaryNum
        a(i, j) = Decoding(OriPool(i).Gene, j) '对这个种群解码
    Next j
Next i
For i = 1 To Popsize
    For j = 1 To DataNum
        OriPool(i).Value(j) = a(i, 1) + a(i, 2) * X0(j, 1) + a(i, 3) * X0(j, 2) + a(i, 4) * X0(j, 3) + a(i, 5) * X0(j, 1) * X0(j, 2) + a(i, 6) * X0(j, 1) * X0(j, 3) + a(i, 7) * X0(j, 2) * X0(j, 3) + a(i, 8) * X0(j, 1) ^ 2 + a(i, 9) * X0(j, 2) ^ 2 + a(i, 10) * X0(j, 3) ^ 2
    Next j
Next i
For i = 1 To Popsize
    f(i) = 0    '另初值为零，得注意这里
    For j = 1 To DataNum
        f(i) = f(i) + (OriPool(i).Value(j) - Y0(j)) ^ 2    '剩余平方和
    Next j
Next i
For i = 1 To Popsize
    If FunctonMode = "MinImization" Then        '形式F(X)=Cmax-f(x)
       If Cmax > f(i) Then
          OriPool(i).Fitness = Cmax - f(i)
       Else
          OriPool(i).Fitness = 0
       End If
    ElseIf FunctonMode = "MaxImization" Then    '形式F(X)=f(x)-Cmin
       If Cmin < f(i) Then
          OriPool(i).Fitness = f(i) - Cmin
       Else
          OriPool(i).Fitness = 0
       End If
    End If
Next i
End Sub

Public Sub FindBestandWorstIndividual()     '寻求每代最优和最差个体
Dim i%
BestIndividual = OriPool(1)
WorstIndividual = OriPool(1)
For i = 1 To Popsize
    If OriPool(i).Fitness > BestIndividual.Fitness Then
       BestIndividual = OriPool(i)
       Best_Index = i
    ElseIf OriPool(i).Fitness < BestIndividual.Fitness Then
       WorstIndividual = OriPool(i)
       Worst_Index = i
    End If
Next i
If Generation = 0 Then
   CurrentBest = BestIndividual
Else
   If BestIndividual.Fitness > CurrentBest.Fitness Then CurrentBest = BestIndividual
End If
End Sub

Public Sub FindEexllent()  '寻求精英个体
Dim i%, j%, CurrentPool(Popsize) As Individual, Temp As Individual
For i = 1 To Popsize
    CurrentPool(i) = OriPool(i)
Next i
For i = 1 To Popsize
    For j = i + 1 To Popsize
        If CurrentPool(i).Fitness <= CurrentPool(j).Fitness Then
           Temp = CurrentPool(i)
           CurrentPool(i) = CurrentPool(j)
           CurrentPool(j) = Temp
        End If
    Next j
Next i
For i = 1 To GoodNum
    MatePool(i) = CurrentPool(i)
Next i
End Sub

Public Sub SelectOperator()  '比例选择法
Dim i%, Cfitness(Popsize) As Double, Sum As Double, P As Double
Randomize
Sum = 0
For i = 1 To Popsize
    Sum = Sum + OriPool(i).Fitness '计算适应度总和
Next i
For i = 1 To Popsize
   Cfitness(i) = OriPool(i).Fitness / Sum  '选择概率
Next i
For i = 2 To Popsize
    Cfitness(i) = Cfitness(i) + Cfitness(i - 1)
Next i
For i = GoodNum + 1 To Popsize
    P = Rnd * Cfitness(Popsize)
    Index = 1
    Do While P > Cfitness(Index)
       Index = Index + 1
    Loop
    MatePool(i) = OriPool(i)
Next i
For i = 1 To Popsize
    OriPool(i) = MatePool(i) '选择后个体赋值给原种群
Next i
End Sub


Public Sub OrderSelection()          '排序选择
Dim i%, j%, SumFitness#, Cfitness(Popsize) As Double, C#, P#
Dim CurrentPool(Popsize) As Individual, Temp As Individual
Dim Index As Integer
Randomize
For i = 1 To Popsize
    CurrentPool(i) = OriPool(i)
Next
SumFitness = 0
For i = 1 To Popsize
    SumFitness = SumFitness + CurrentPool(i).Fitness    '适应度总和
Next i
If SumFitness = 0 Then SumFitness = 10 '如果适应度和为零，则强迫为某一个值，防止出错！
For i = 1 To Popsize     '适应度由大至小进行排列
    For j = i + 1 To Popsize
        If CurrentPool(i).Fitness < CurrentPool(j).Fitness Then
           Temp = CurrentPool(i)
           CurrentPool(i) = CurrentPool(j)
           CurrentPool(j) = Temp
        End If
    Next j
Next i
Cfitness(1) = CurrentPool(1).Fitness / SumFitness         '第一个的概率
C = Cfitness(1)
For i = 1 To Popsize
    Cfitness(i) = C * (1 - C) ^ (i - 1)
Next i
For i = 2 To Popsize
    Cfitness(i) = Cfitness(i) + Cfitness(i - 1)         '累计概率
Next i
For i = GoodNum + 1 To Popsize
    P = Rnd * Cfitness(Popsize - 40) '产生随机数
    Index = 1
    Do While P > Cfitness(Index)
       Index = Index + 1
    Loop
    MatePool(i) = CurrentPool(Index)
Next i
For i = 1 To Popsize
    OriPool(i) = MatePool(i)  '选择后个体赋值给原种群
Next i
End Sub

Public Sub SampleCode(Sample#()) '产生样本
Randomize
For j = 1 To GeneLength
    Sample(j) = Int(2 * Rnd)
Next j
End Sub

Public Sub CrossoverOperator()  '交叉算法，精英个体不交叉、变异直接进入下一代
Dim i%, j%
Dim CoupleNum%, Wife%, Husband%
Dim TempW(GeneLength) As Double, TempH(GeneLength) As Double
Dim SampleW(GeneLength) As Double, SampleH(GeneLength) As Double

CoupleNum = CInt(Popsize * Pc / 2)   '交叉对数
Randomize
For i = 1 To CoupleNum
    Wife = Int((Popsize - GoodNum) * Rnd + GoodNum + 1)
    Husband = Int((Popsize - GoodNum) * Rnd + GoodNum + 1)
    Do While Husband = Wife
       Husband = Int((Popsize - GoodNum) * Rnd + GoodNum + 1)
    Loop
    For k = 1 To VaryNum
        Call SampleCode(SampleW())    '均匀交叉样本代码1
        Call SampleCode(SampleH())    '均匀交叉样本代码2
        For j = 1 To GeneLength
            TempW(j) = OriPool(Wife).Gene(k, j)      '存放临时数据
            TempH(j) = OriPool(Husband).Gene(k, j)
        Next j
        For j = 1 To GeneLength
            If SampleW(j) = 1 Then
               OriPool(Wife).Gene(k, j) = TempH(j)     '样本1中为1的表示由父提供代码,0表示母提供代码
            End If
            If SampleH(j) = 0 Then
               OriPool(Husband).Gene(k, j) = TempW(j) '样本1中为1的表示由父提供代码,0表示母提供代码
            End If
        Next j
    Next k
Next i
End Sub

Public Sub MutationOperator()  '变异算法，精英个体不交叉、变异直接进入下一代
Dim i%, j%, TemRnd#, mm%
For i = GoodNum + 1 To Popsize
    For k = 1 To VaryNum
        For j = 1 To GeneLength
            TemRnd = Rnd
            If TemRnd <= Pm Then
               OriPool(i).Gene(k, j) = (OriPool(i).Gene(k, j) + 1) Mod 2
               mm = mm + 1
            End If
        Next j
    Next k
Next i
'Debug.Print mm  '突变数目
End Sub


Private Sub Command1_Click()
Dim i%, j%
Call InitPop    '初始化

For Generation = 1 To MaxNum
    Call CalculateFitness
    Call FindBestandWorstIndividual
    Call FindEexllent
    'Call SelectOperator   '比例选择
    Call OrderSelection   '排序选择
    Call CrossoverOperator
    Call MutationOperator
    Debug.Print "当前运算到第"; Generation; " 代    ";
    Debug.Print "BestIndividual.Fitness="; Cmax - BestIndividual.Fitness
   ' Debug.Print "WorstIndividual.Fitness="; WorstIndividual.Fitness;
    'Debug.Print "CurrentBest.Fitness="; CurrentBest.Fitness
Next Generation

'#######结果输出########
    For j = 1 To VaryNum
        aa(j) = Decoding(CurrentBest.Gene, j) '对这个种群解码
    Next j
    For i = 1 To VaryNum
        Debug.Print "a("; i; ")="; aa(i)
    Next i
    For i = 1 To DataNum
        Debug.Print "CurrentBest.Value("; i; ")="; CurrentBest.Value(i)
    Next i
    erro = 0
    For j = 1 To DataNum
        erro = erro + (CurrentBest.Value(j) - Y0(j)) ^ 2         '标准方差
    Next j
    Debug.Print "剩余平方和Erro^2="; erro
'#######结果输出########
End Sub