modga.bas

改进遗传算法程序

Attribute VB_Name = "modGA"
'the sort routine and basic outline from the Author: Troy Williams; contact:[e-mail]
'
'just a test to see if i could do it and i did!!
'by S鋟re of ghostly embers
'[e-mail]

Option Explicit

Public Type Bloobs
    Chrom1 As Single
    Chrom2 As Single
    Chrom3 As Single
    Fitness As Single
    value As Single
    Generation As Long
End Type


Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Pop() As Bloobs, Children() As Bloobs, BestBloob As Bloobs
Public NumGens As Long, LTime As Long, popSize As Long
Public Multiplier As Long


'Load the program
Public Sub Main()

Multiplier = 10000000
Load frmGA

End Sub

'Breed the little buggers
Public Sub Breed_Them()

Dim x As Long

popSize = Val(frmGA.txtPopSize)

ReDim Pop(1 To popSize) As Bloobs
ReDim Children(1 To (2 * popSize)) As Bloobs

NumGens = Val(frmGA.txtGens)
LTime = Val(frmGA.txtLifeTime)

Init_Generation
BestBloob = Pop(1)

For x = 1 To NumGens                    'iterate through each generation
    frmGA.lblCurrgen = "Current Generation:" + Str$(x)
    Show_BestGen                        'show the best
    If LTime > 49 Then Sleep (LTime * 10)   'sleep between life cycles
    Mating_Season                       'mate the bloobs to make children
    Children = Pop_Sort(Children)       'sort the children to find the best
    If frmGA.chkElite = 1 Then          'jump the best adult ahead to the next generation
        Children(popSize) = Pop(1)
        Children(popSize).Generation = Children(1).Generation
    End If
    Child_to_Adult                      'copy children to adults
    Pop = Pop_Sort(Pop)                 'sort the bloobs to find the best
Next

Show_BestGen

End Sub

'copy children to adults
Private Sub Child_to_Adult()

Dim x As Long

For x = 1 To popSize
    Pop(x) = Children(x)
Next

End Sub

'mate the bloobs to make Children
Private Sub Mating_Season()

Dim a As Long, b As Long, c As Long, x As Long, temp As Bloobs, q As Long
 
a = popSize * 2
Randomize Timer

For x = 1 To a
    b = Rnd * popSize
    c = Rnd * popSize
    If b < 1 Then b = 1
    If c < 1 Then c = 1
    If Pop(b).Fitness > Pop(c).Fitness Then
        q = c
        c = b
        b = q
    End If
    temp.Generation = Pop(1).Generation + 1
    temp.Chrom1 = CrossOver(Pop(b).Chrom1, Pop(c).Chrom1)
    temp.Chrom2 = CrossOver(Pop(b).Chrom2, Pop(c).Chrom2)
    temp.Chrom3 = CrossOver(Pop(b).Chrom3, Pop(c).Chrom3)
    temp = ChemicalX(temp)
    temp.value = Eval_Value(temp)
    temp.Fitness = Eval_Fitness(temp)
    Children(x) = temp
Next

End Sub

'mutate the children
Private Function ChemicalX(inbloob As Bloobs) As Bloobs

Dim x As Single, tmp As Bloobs, a As Single, b As Single, c As Single, d As Long
Dim e As Long, f As Long, q As Integer

Randomize Timer
x = Rnd
If x <= frmGA.txtMutProb Then
    tmp = inbloob
    a = inbloob.Chrom1
    b = inbloob.Chrom2
    c = inbloob.Chrom3
    d = CLng(a * Multiplier)
    e = CLng(b * Multiplier)
    f = CLng(c * Multiplier)
    q = Rnd * 31: If q < 1 Then q = 1: If q > 31 Then q = 31
    d = BitToggle(d, q)
    q = Rnd * 31: If q < 1 Then q = 1: If q > 31 Then q = 31
    e = BitToggle(e, q)
    q = Rnd * 31: If q < 1 Then q = 1: If q > 31 Then q = 31
    e = BitToggle(e, q)
    a = CSng(d / Multiplier)
    b = CSng(e / Multiplier)
    c = CSng(f / Multiplier)
    tmp.Chrom1 = a
    tmp.Chrom2 = b
    tmp.Chrom3 = c
Else
    tmp = inbloob
End If

ChemicalX = tmp

End Function

'crossover a set of chromosomes
Private Function CrossOver(a As Single, b As Single) As Single

Dim n As Single, c As Long, d As Long, e As Integer, f As String, g As String, h As Single
Dim j As String, k As Long

Randomize Timer
h = Rnd

If h <= Val(frmGA.txtCrossProb) Then

    c = CLng(a * Multiplier)
    d = CLng(b * Multiplier)
    e = Rnd * 32: If e < 2 Then e = 2: If e > 31 Then e = 31
    f = LongToBit(c)
    g = LongToBit(d)
    j = Left$(f, e) + Right$(g, 32 - e)
    k = BitToLong(j)
    n = CSng(k / Multiplier)
    CrossOver = n
Else
    CrossOver = a
End If

End Function

'show the best of generation
Private Sub Show_BestGen()

With frmGA
    .lblBGVal = Pop(1).value
    .lblBGFit = Pop(1).Fitness
    .lblBGC1 = Pop(1).Chrom1
    .lblBGC2 = Pop(1).Chrom2
    .lblBGC3 = Pop(1).Chrom3
End With

DoEvents
If BestBloob.Fitness > Pop(1).Fitness Then BestBloob = Pop(1)
With frmGA
    .lblBBVal = BestBloob.value
    .lblBBFit = BestBloob.Fitness
    .lblBBC1 = BestBloob.Chrom1
    .lblBBC2 = BestBloob.Chrom2
    .lblBBC3 = BestBloob.Chrom3
    .lblBBGen = BestBloob.Generation
End With
DoEvents

End Sub

'Create the initial population, generation zero
Private Sub Init_Generation()

Dim a As Long, x As Long

a = UBound(Pop)
Randomize Timer

For x = 1 To a
    Pop(x).Chrom1 = Rnd * 100
    Pop(x).Chrom2 = Rnd * 100
    Pop(x).Chrom3 = Rnd * 100
    Pop(x).value = Eval_Value(Pop(x))
    Pop(x).Fitness = Eval_Fitness(Pop(x))
    Pop(x).Generation = 0
Next

Pop = Pop_Sort(Pop)

End Sub

'Evaluate the Value of a particular bloob
Private Function Eval_Value(num As Bloobs) As Single

Dim a As Single, b As Single, c As Single, d As Single

a = num.Chrom1
b = num.Chrom2
c = num.Chrom3
d = (2 * a * a) - (b * c)

Eval_Value = d

End Function

'Evaluate Fitness of a particular bloob
Private Function Eval_Fitness(num As Bloobs) As Single

'fitness is calculated by abs((optimal value - funtion with bloob value)/(optimal value))

Dim a As Single, b As Single, c As Single

a = num.value
b = frmGA.txtOptimum
c = Abs((b - a) / b)

Eval_Fitness = c

End Function

'Sort the Population (bubble sort)
Private Function Pop_Sort(popi() As Bloobs) As Bloobs()

Dim i As Integer, j As Integer, upper As Integer, temp As Bloobs

upper = UBound(popi)

For i = 1 To upper
    For j = i To upper
        If popi(j).Fitness < popi(i).Fitness Then
            temp = popi(j)
            popi(j) = popi(i)
            popi(i) = temp
        End If
    Next j
Next i

Pop_Sort = popi

End Function