Option Explicit

'遺傳算法參數
Dim GeneLength As Integer '染色體長度
Dim swarmNum As Integer '種群規模
Dim Pc As Double '雜交概率
Dim Pm As Double '突變概率
Dim maxNum As Integer '遺傳算法循環次數
Dim panelBool As Boolean
Dim tournamentBool As Boolean

'種群適應度統計
Dim optGene As Integer '最佳個體的位置
Dim worstGene As Integer '最差個體的位置
Dim sumFitness As Double '適應度總和
Dim meanFitness As Double '平均適應度
Dim maxFitness As Double '最大適應度
Dim minFitness As Double '最小適應度
Dim stdevFitness As Double '適應度標準差

'Dim OriPool() As Byte
Dim OriPool() As Double

'Dim MatePool() As Byte
Dim MatePool() As Double

Dim Fitness() As Double
Dim panelFitness() As Double

Dim FileNum As Integer

'高斯分布隨機數

Function randGauss() As Double
Dim i As Integer
randGauss = 0
For i = 1 To 20
    randGauss = randGauss + Rnd
Next i
randGauss = (randGauss - 10) / (1.667) ^ 0.5
End Function

'輪盤賭博選擇算子
Function panelSelection(Fitness() As Double) As Integer

Dim index, fir, las, i As Integer
Dim temp, sum, sumFitness As Double

fir = LBound(Fitness)
las = UBound(Fitness)
sumFitness = 0
For i = fir To las
    sumFitness = sumFitness + Fitness(i)
Next i
temp = Rnd * sumFitness '產生隨機數

index = fir - 1
sum = 0

Do While sum < temp
    index = index + 1
    sum = sum + Fitness(index)
Loop
If index = fir - 1 Then
    panelSelection = fir
Else
    panelSelection = index
End If

End Function

'錦標賽選擇算子
Function tournamentSele(Fitness() As Double) As Integer
Dim i, j As Integer
i = Int(swarmNum * Rnd + 1)
j = Int(swarmNum * Rnd + 1)
If Fitness(i) >= Fitness(j) Then
  tournamentSele = i
Else
  tournamentSele = j
End If
End Function

'計算種群適應度
Private Sub outFitness(oriPool() As Double, swarmNum As Integer)

Dim i As Integer
Dim a, b, e As Double
For i = 1 To swarmNum

'//***計算適應度語句***//
    Fitness(i) = 0



'//***結束***//

Next i

sumFitness = 0
maxFitness = Fitness(1)
minFitness = Fitness(1)
optGene = 1
worstGene = 1

For i = 1 To swarmNum
    sumFitness = sumFitness + Fitness(i)
    If Fitness(i) > maxFitness Then
        maxFitness = Fitness(i)
        optGene = i
    End If
    If Fitness(i) < minFitness Then
        minFitness = Fitness(i)
        worstGene = i
    End If
Next i

meanFitness = sumFitness / swarmNum

stdevFitness = 0
For i = 1 To swarmNum
    stdevFitness = stdevFitness + (Fitness(i) - meanFitness) ^ 2
Next i
stdevFitness = stdevFitness / swarmNum

If maxFitness <> meanFitness Then
    e = 1.5
    a = (e - 1) * meanFitness / (maxFitness - meanFitness)
    b = (1 - a) * meanFitness
    For i = 1 To swarmNum
        panelFitness(i) = a * Fitness(i) + b
        If panelFitness(i) < 0 Then
            panelFitness(i) = 0
        End If
    Next i
Else
    For i = 1 To swarmNum
        panelFitness(i) = Fitness(i)
    Next i
End If

End Sub

Private Sub Command1_Click()

Dim i, j As Integer
Dim iterNum As Integer
Dim coupleNum As Integer
Dim wife, husband As Integer
Dim mateLocation As Integer
Dim tempint As Integer
Dim tempdbl As Double

Dim mutationLoc As Integer
Dim copySelection As Integer
Dim tempRnd As Double
Dim str As String



FileNum = FreeFile
Open "C:\My Documents\panel data\result.txt" For Output As FileNum


swarmNum = 20
Pc = 0.8
Pm = 0.001

maxNum = 30

panelBool = False
tournamentBool = True

GeneLength = 13
coupleNum = CInt(swarmNum * Pc / 2)

ReDim OriPool(1 To swarmNum, 1 To GeneLength)
ReDim MatePool(1 To swarmNum, 1 To GeneLength)
ReDim Fitness(1 To swarmNum)
ReDim panelFitness(1 To swarmNum)


'initialize originpool'

Randomize

For i = 1 To swarmNum

'//***初始化種群***//
  
    'For j = 1 To GeneLength
        'OriPool(i, j) = Int(2 * Rnd)
    'Next j
  
    For j = 1 To 9
        OriPool(i, j) = Rnd
    Next j
  
    For j = 10 To 12
        OriPool(i, j) = 100 * Rnd
    Next j
  
    OriPool(13) = Rnd

'//***初始化結束***//
  
Next i


For iterNum = 1 To maxNum

    Call outFitness(oriPool, swarmNum)

    Print #FileNum, "第" + CStr(iterNum) + "代解"
    For i = 1 To swarmNum
        str = ""
        For j = 1 To GeneLength
            If TypeName(OriPool(i, j)) = "Double" Then
                str = str & Format(OriPool(i, j), "0.000") & ","
            Else
                str = str & CStr(OriPool(i, j))
            End If
        Next j
        
        If TypeName(OriPool(i, 1)) = "Double" Then
            str = Left(str, Len(str) - 1)
        End If
        
        Print #FileNum, str, Format(Fitness(i), "0.000")
        
    Next i
    
    str = "最優個體 "
    For j = 1 To GeneLength
        If TypeName(OriPool(optGene, j)) = "Double" Then
            str = str & Format(OriPool(optGene, j), "0.000") & ","
        Else
            str = str & CStr(OriPool(optGene, j))
        End If
    Next j
    If TypeName(OriPool(optGene, GeneLength)) = "Double" Then
        str = Left(str, Len(str) - 1)
    End If
    Print #FileNum, str, Format(Fitness(optGene), "0.000")
    
    str = "最差個體 "
    For j = 1 To GeneLength
        If TypeName(OriPool(worstGene, j)) = "Double" Then
            str = str & Format(OriPool(worstGene, j), "0.000") & ","
        Else
            str = str & CStr(OriPool(worstGene, j))
        End If
    Next j
    If TypeName(OriPool(worstGene, GeneLength)) = "Double" Then
        str = Left(str, Len(str) - 1)
    End If
    Print #FileNum, str, Format(Fitness(worstGene), "0.000")
    str = "平均適應度 = " & Format(meanFitness, "0.000") & " ; "
    str = str & "適應度標準差 = " & Format(stdevFitness, "0.000")
    Print #FileNum, str
    
'//***復制算子無需改動***//
'copy operator'

    For i = 1 To swarmNum
  
        If panelBool Then
            copySelection = panelSelection(panelFitness)
        End If
        If tournamentBool Then
            copySelection = tournamentSele(Fitness)
        End If
        For j = 1 To GeneLength
            MatePool(i, j) = OriPool(copySelection, j)
        Next j
    
    Next i
 '//***復制算子無需改動***//
 
'crossover operator'

    For i = 1 To coupleNum
        wife = Int(swarmNum * Rnd + 1)
        husband = Int(swarmNum * Rnd + 1)
        mateLocation = Int(GeneLength * Rnd + 1)
        For j = 1 To mateLocation
            If TypeName(MatePool(wife, j)) = "Double" Then
                tempdbl = MatePool(wife, j)
                MatePool(wife, j) = MatePool(husband, j)
                MatePool(husband, j) = tempdbl
            Else
                tempint = MatePool(wife, j)
                MatePool(wife, j) = MatePool(husband, j)
                MatePool(husband, j) = tempint
            End If
        Next j
    Next i

'mutation operator'
    For i = 1 To swarmNum
    
        '//***二進制編碼變異***//
        For j = 1 To GeneLength
            tempRnd = Rnd
            If tempRnd <= Pm Then
                MatePool(i, j) = (MatePool(i, j) + 1) Mod 2
            End If
        Next j
        '//***二進制編碼變異結束***//
        
    Next i
    
'//***加速器***//



'//***加速器結束***//


'//***將交配池的個體復制到原始池***//
    For i = 1 To swarmNum
        For j = 1 To GeneLength
            OriPool(i, j) = MatePool(i, j)
        Next j
    Next i

 
Next iterNum

Text1.Text = "the end"

End Sub