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