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         =   "計(jì)算"
      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

'遺傳算法參數(shù)
Dim Sample(GeneLength) As Double  '產(chǎn)生樣品基因代碼
Dim Generation As Integer             '運(yùn)行代數(shù)
Dim OriPool(Popsize) As Individual    '初始種群
Dim MatePool(Popsize) As Individual   '子代個(gè)體
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    '代求的常數(shù)a
Dim X0(DataNum, XNum) As Double     '應(yīng)變量X
Dim Y0()                            '變量值Y
Dim X1(), X2(), X3()                '初始數(shù)據(jù)
Dim aa(VaryNum)                     '求得最優(yōu)a1至a10參數(shù)輸出

Private Sub Form_Load()  '數(shù)據(jù)錄入
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
    For j = 2 To GeneLength
        OriPool(i).Gene(j) = (OriPool(i).Gene(j) + OriPool(i).Gene(j - 1)) Mod 2  '產(chǎn)生格雷碼
    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()  '計(jì)算種群適應(yīng)度
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) '對(duì)這個(gè)種群解碼
    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()     '尋求每代最優(yōu)和最差個(gè)體
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()  '尋求精英個(gè)體
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 '計(jì)算適應(yīng)度總和
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) '選擇后個(gè)體賦值給原種群
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    '適應(yīng)度總和
Next i
If SumFitness = 0 Then SumFitness = 10 '如果適應(yīng)度和為零，則強(qiáng)迫為某一個(gè)值，防止出錯(cuò)！
For i = 1 To Popsize     '適應(yīng)度由大至小進(jìn)行排列
    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         '第一個(gè)的概率
C = Cfitness(1)
For i = 1 To Popsize
    'Cfitness(i) = CurrentPool(i).Fitness / SumFitness
    Cfitness(i) = C * (1 - C) ^ (i - 1)
Next i
For i = 2 To Popsize
    Cfitness(i) = Cfitness(i) + Cfitness(i - 1)         '累計(jì)概率
Next i
For i = GoodNum + 1 To Popsize
    P = Rnd * Cfitness(Popsize - 40) '產(chǎn)生隨機(jī)數(shù)
    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)  '選擇后個(gè)體賦值給原種群
Next i
End Sub

Public Sub SampleCode(Sample#()) '產(chǎn)生樣本
Randomize
For j = 1 To GeneLength
    Sample(j) = Int(2 * Rnd)
Next j
End Sub

Public Sub CrossoverOperator()  '交叉算法，精英個(gè)體不交叉、變異直接進(jìn)入下一代
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)   '交叉對(duì)數(shù)
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)       '存放臨時(shí)數(shù)據(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()  '變異算法，精英個(gè)體不交叉、變異直接進(jìn)入下一代
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  '突變數(shù)目
End Sub

Private Sub Command1_Click()
Call InitPop    '初始化

For Generation = 1 To MaxNum
    Call CalculateFitness
    Call FindBestandWorstIndividual
    Call FindEexllent
    'Call SelectOperator   '比例選擇
    Call OrderSelection   '排序選擇
    Call CrossoverOperator
    Call MutationOperator
    Debug.Print "當(dāng)前運(yùn)算到第"; Generation; " 代    ";
    Debug.Print "BestIndividual.Fitness="; Cmax - BestIndividual.Fitness
   ' Debug.Print "WorstIndividual.Fitness="; WorstIndividual.Fitness;
    'Debug.Print "CurrentBest.Fitness="; CurrentBest.Fitness
Next Generation

'#######結(jié)果輸出########
    For j = 1 To VaryNum
        aa(j) = Decoding(CurrentBest.Gene, (j - 1) * Length + 1, j * Length) '對(duì)這個(gè)種群解碼
    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         '標(biāo)準(zhǔn)方差
    Next j
    Debug.Print "剩余平方和Erro^2="; erro
'#######結(jié)果輸出########
End Sub