Option Explicit

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

'種群適應(yīng)度統(tǒng)計
Dim optGene As Integer '最佳個體的位置
Dim worstGene As Integer '最差個體的位置
Dim sumFitness As Double '適應(yīng)度總和
Dim meanFitness As Double '平均適應(yīng)度
Dim maxFitness As Double '最大適應(yīng)度
Dim minFitness As Double '最小適應(yīng)度
Dim stdevFitness As Double '適應(yīng)度標(biāo)準(zhǔn)差

'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

'高斯分布隨機(jī)數(shù)

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 '產(chǎn)生隨機(jī)數(shù)

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

'錦標(biāo)賽選擇算子
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

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

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

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



'//***結(jié)束***//

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

'//***初始化結(jié)束***//
  
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 = "最優(yōu)個體 "
    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 = "平均適應(yīng)度 = " & Format(meanFitness, "0.000") & " ; "
    str = str & "適應(yīng)度標(biāo)準(zhǔn)差 = " & Format(stdevFitness, "0.000")
    Print #FileNum, str
    
'//***復(fù)制算子無需改動***//
'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
 '//***復(fù)制算子無需改動***//
 
'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
    
        '//***二進(jìn)制編碼變異***//
        For j = 1 To GeneLength
            tempRnd = Rnd
            If tempRnd <= Pm Then
                MatePool(i, j) = (MatePool(i, j) + 1) Mod 2
            End If
        Next j
        '//***二進(jìn)制編碼變異結(jié)束***//
        
    Next i
    
'//***加速器***//



'//***加速器結(jié)束***//


'//***將交配池的個體復(fù)制到原始池***//
    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