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 =   3  '窗口缺省
   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 X() As Double      '应变量X
Dim p() As Double      '选择概率
Dim SumP() 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%
Randomize
For i = 1 To Popsize
    For j = 1 To GeneLength
        OriPool(i).Gene(j) = Int(2 * Rnd)
    Next j
Next i
End Sub

Public Function Decoding(Pool#(), Start1%, Length1%) As Double    '解码
Dim j%, TempCode() As Double, LL%, N#
    LL = Length1 - Start1 + 1
    ReDim TempCode(LL) As Double
    N = (Max_Var - Min_Var) / (2 ^ LL - 1)
    k = 0
    For j = Start1 To Length1
         k = k + 1
         TempCode(k) = Pool(j)                            '解码
    Next j
    Decoding = Min_Var
    For j = 1 To LL
        Decoding = Decoding + TempCode(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 - 1) * Length + 1, j * Length) '对这个种群解码
    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
    f(i) = Sqr(f(i) / DataNum)
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 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
    Call SampleCode(SampleW())    '均匀交叉样本代码1
    Call SampleCode(SampleH())    '均匀交叉样本代码2
    For j = 1 To GeneLength
        TempW(j) = OriPool(Wife).Gene(j)       '存放临时数据
        TempH(j) = OriPool(Husband).Gene(j)
    Next j
    For j = 1 To GeneLength
        If SampleW(j) = 1 Then
           OriPool(Wife).Gene(j) = TempH(j)      '样本1中为1的表示由父提供代码,0表示母提供代码
        End If
        If SampleH(j) = 0 Then
           OriPool(Husband).Gene(j) = TempW(j)  '样本1中为1的表示由父提供代码,0表示母提供代码
        End If
    Next j
Next i
End Sub

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


Private Sub Command1_Click()
Call InitPop    '初始化

For Generation = 1 To MaxNum
    Call CalculateFitness
    Call FindBestandWorstIndividual
    Call FindEexllent
    Call SelectOperator
    Call CrossoverOperator
    Call MutationOperator
    Debug.Print "当前运算到第"; Generation; " 代    ";
    Debug.Print "BestIndividual.Fitness="; 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 - 1) * Length + 1, j * Length) '对这个种群解码
    Next j
    For i = 1 To VaryNum
        Debug.Print "a("; i; ")="; aa(i)
    Next i
    For i = 1 To VaryNum
        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="; erro
    erro1 = Sqr(erro / DataNum)
    Debug.Print "标准方差erro1="; erro1
'#######结果输出########
End Sub