123.txt

遗传算法实例 只有代码无界面 基于VB环境开发的

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