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