www.pudn.com > Genetic Algorithm.zip > GeneticAlgorithm.cls
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "GeneticAlgorithm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'######################################################################################
'# Notice from RG Software Corporation
'# Genetic Algorithm for Visual Basic 4,5 and 6 by Richard Gardner March 8th, 2001
'# WARNING! This code is owned and copyright © 2001 by RG Software Corporation
'# You may use this code free of charge providing that this disclaimer remains
'# intact. Please visit our web site at http://www.rgsoftware.com You will find
'# Neural Network code, Genetic Algorithms and other A.I. source code there.
'######################################################################################
'Thanks for downloading this code and I hope you enjoy using it.
'My name is Richard Gardner and I work for RG Software Corporation.
'Please visit their web site at http://www.rgsoftware.com - there's
'lots of cool A.I. stuff! If you have any questions about this code,
'just send me an email at rgardner@rgsoftware.com
' -------------------------------
'| ---- |
'| | 32¢| |
'| To: Richard Gardner ---- |
'| 6838 W. Cholla St. |
'| Peoria, Arizona 85345 |
'| |
' -------------------------------
'I collect post cards, so if you enjoy using this genetic algorithm,
'please send a post card to the address above - Thanks! :)
'What is a Genetic Algorithm?
'A Genetic Algorithm is solution that is used to estimate various
'mathematical blackbox problems. In this example we use a Visual
'Basic function named "BlackBox" (see frmMain). This function
'accepts multiple parameters and after these numeric arguments
'are added, subtracted, multiplied or divided, the BlackBox
'function outputs a number. The Genetic Algorithm will attempt
'to find out what goes on inside the function using evolutionary
'techniques. Each solution is encoded in a bit string, which we
'refer to as a chromosome. For instance, a chromosome consisting
'of 32-bits (i.e. 11010010110101101010010110101110) can encode
'genetic information about the solution. There are three major
'processes in genetic algorithms:
'
'1) Initialization
'This process builds a few random chromosomes to start the population.
'
'2) Fitness Calculation
'In this process, the entire population of chromosomes are evaluated.
'Each bit string is decoded from binary numbers into integers and then
'these numbers are passed into the user-defined function for evaluation
'(the "BlackBox" function) If the absolute value between the blackbox
'function output and the chromosome is minimal, that chromosome is
'rewarded with a higher chance of being a parent to other child chromosomes.
'
'3) Crossover and mutation
'After all chromosomes have been evaluated, it is time to randomly
'select a mother and father. Crossover is the process in which two
'randomly chosen chromosomes are swapped at a random point. For example:
'
'Randomly chosen father chromosome: 11001010
'Randomly chosen mother chromosome: 00101101
'Randomly chosen point of crossover: 4
'New child chromosome: 11001101
'
'The child may undergo mutation, where a randomly chosen bit in the
'chromosome is swapped with another randomly chosen bit.
'
'In this example we are using a one-point crossover
'(mother and father), however, many genetic algorithms exist that
'have multiple crossovers.
'
'It is important to note that not all chromosomes have an equal
'chance of reproducing. Chromosomes which are more fit than others
'have the highest probability of becoming a parent. (this is called
'"roulette wheel" selection).
'
'I hope you've enjoyed this short little story about genetic algorithms.
'
'References:
'
'The Genetic Algorithm Newsgroup
'news://com.ai.genetic
'
'The Genetic Algorithm F.A.Q.s
'http://www.cs.cmu.edu/afs/cs.cmu.edu/project/ai-repository/ai/html/faqs/ai/genetic/top.html
'
'If you have questions or constructive criticism,
'don't hesitate to email me at rgardner@rgsoftware.com
'
'
' I'll be awaiting the arrival of your postcard in the mail! :0)
Option Explicit
Private Const Selection As Double = 0.45
Private Const Momentum As Double = 0.05
Private Const Bits As Integer = 32 'Bits per chromosome
'Eight 4-bit sections per 32-bit chromosome, using one-point
'Crossover.
Private Const Splices As Integer = 8
Private Const Max_Bits As Integer = Bits / Splices
Private Max_Value As Integer
'For one-point crossover, divide the chromosome
'so the maximum value for 32-bit chromosomes
'(1111|1111|1111|1111|1111|1111|1111|1111) in
'decimal is the Max_Value constant (8 4-bit values).
'Population of parents (population size = Bits / 2)
Private Population(1 To Bits / 2) As Chromosome
Private Sections(1 To Splices, 1 To Bits / 2) As Integer
'To break the Chromosome apart
Private Solution As Integer
Private FittestChromosome As String
Private FittestValue As Double
Private aryFittestValue(1 To Splices) As Double
Private m_Quit As Boolean
Private m_Fitness As Double
Private m_FitnessSet As Boolean
Private Type Chromosome
Value As String * Bits
Fitness As Double
End Type
Public Event Evaluate(Values As Variant) 'Returns a safe array
Public Event Solved(Chromosome As String, Fitness As Double, Values As Variant)
Public Event BestSolution(Chromosome As String, Fitness As Double, Values As Variant)
Public Target As Double 'Target value
Public Sub Quit()
m_Quit = True
End Sub
Private Sub InitializePopulation()
Dim intI As Integer
Dim intParts As Integer
Dim strChromosome As String
For intI = 1 To Bits / 2
'Initialize the population
strChromosome = ""
For intParts = 1 To Splices
strChromosome = strChromosome & EncodeChromosome(Rnd * Max_Value)
Next intParts
Population(intI).Value = strChromosome
Next intI
End Sub
Private Function CalculateFitness()
'Calculate fitness of the chromosome
Dim Deltas(1 To Bits / 2) As Double
Dim dblDelta As Double
Dim intLoop As Integer
Dim intPopulation As Integer
Dim intSplice As Integer
Dim RetArray(1 To Splices) As Double
Dim n As Integer
For intPopulation = 1 To Bits / 2
intSplice = 0
For intLoop = 1 To Bits Step Max_Bits
intSplice = intSplice + 1
Sections(intSplice, intPopulation) = _
DecodeChromosome(Mid(Population(intPopulation).Value, _
intLoop, Max_Bits))
Next intLoop
Next intPopulation
'#############################################################
For intLoop = 1 To Bits / 2
'Decode the current chromosome
For n = 1 To Splices
RetArray(n) = Sections(n, intLoop)
Next n
m_FitnessSet = False
'Get the user-defined fitness value
RaiseEvent Evaluate(RetArray)
'Wait for user response
Do While m_FitnessSet = False
DoEvents
Loop
Deltas(intLoop) = Abs(Target - Fitness)
If Deltas(intLoop) = 0 Then
Solution = intLoop
End If
Next intLoop
'#############################################################
For intLoop = 1 To Bits / 2
If Deltas(intLoop) > dblDelta Then
dblDelta = Deltas(intLoop)
End If
Next intLoop
For intLoop = 1 To Bits / 2
Population(intLoop).Fitness = dblDelta - Deltas(intLoop) + 1
Next intLoop
If Solution <> 0 Then
FittestChromosome = Population(Solution).Value
FittestValue = Population(Solution).Fitness
'Fittest chromosome values
For n = 1 To Splices
aryFittestValue(n) = Sections(n, Solution)
Next n
End If
End Function
Private Function NextGeneration()
Dim dblFittest As Double
Dim dblFittest2 As Double
Dim dblRndFitness As Double
Dim intCrossOver As Integer
Dim intFittest As Integer
Dim intFittest2 As Integer
Dim dblLeastFit As Double
Dim intLeastFit As Integer
Dim intLoop As Integer
Dim intChild As Integer
Dim dblRnd As Double
Dim intRnd As Integer
Dim Father As String
Dim Mother As String
Dim intMutate As Integer
Dim i As Integer
Dim n As Integer
For intLoop = 1 To Bits / 2
If Population(intLoop).Fitness > dblRndFitness Then
dblRndFitness = Population(intLoop).Fitness
End If
Next intLoop
Randomize Format(Time, "ss")
'One-Point Chromosome Crossover
intCrossOver = ((CInt(Rnd * (Splices - 1)) + 1) * Max_Bits) - Max_Bits
'Find fittest chromosome
dblRnd = Rnd * (dblRndFitness * Momentum)
dblFittest = 0
For i = 1 To Bits / 2
If Population(i).Fitness > dblRnd Then
dblRnd = Rnd * 1
If dblRnd > (1 - Selection) Then
If Population(i).Fitness > dblFittest Then
dblFittest2 = dblFittest
dblFittest = Population(i).Fitness
intFittest2 = intFittest
intFittest = i
FittestChromosome = Population(i).Value
FittestValue = Population(i).Fitness
'Fittest chromosome values
For n = 1 To Splices
aryFittestValue(n) = Sections(n, i)
Next n
End If
End If
End If
Next i
'Make sure there are two different parent chromosomes
If intFittest = 0 Then
intRnd = Rnd * ((Bits - 1) / 2) + 1
dblFittest = Population(intRnd).Fitness
intFittest = intRnd
End If
If intFittest2 = 0 Then
intRnd = Rnd * ((Bits - 1) / 2) + 1
dblFittest2 = Population(intRnd).Fitness
intFittest2 = intRnd
End If
'Cross them over
Father = Mid(Population(intFittest).Value, 1, intCrossOver)
Mother = Mid(Population(intFittest2).Value, intCrossOver + 1)
'Find the least fit chromosome and replace it
dblLeastFit = dblFittest
For intLoop = 1 To Bits / 2
If Population(intLoop).Fitness < dblLeastFit Then
dblLeastFit = Population(intLoop).Fitness
intLeastFit = intLoop
End If
Next intLoop
If intLeastFit = 0 Then
intRnd = Rnd * ((Bits - 1) / 2) + 1
dblLeastFit = Population(intRnd).Fitness
intLeastFit = intRnd
End If
'Insert the new hybrid chromosome
Population(intLeastFit).Value = Father & Mother
'Mutate the chromosomes (very important)
For intLoop = 1 To Bits / 2
dblRnd = Rnd * 1
If dblRnd > (1 - Selection) Then
intMutate = CInt(Rnd * 1)
intCrossOver = Rnd * (Bits - 1)
Mid(Population(intLoop).Value, intCrossOver + 1, 1) = intMutate
End If
Next intLoop
End Function
Public Sub Run()
Dim lngWhere As Long
'Get the maximum value for each splice in the chromosome
Max_Value = DecodeChromosome(String(Max_Bits, "1"))
InitializePopulation
Do
CalculateFitness
If Solution <> 0 Then
Solution = 0
RaiseEvent Solved(FittestChromosome, FittestValue, aryFittestValue)
Exit Sub
End If
NextGeneration
RaiseEvent BestSolution(FittestChromosome, FittestValue, aryFittestValue)
DoEvents
If m_Quit = True Then
m_Quit = False
Exit Sub
End If
Loop
End Sub
Private Function EncodeChromosome(lngDecimal As Long) As String
Dim Remainder(1 To Max_Bits) As Double
Dim DecimalNumber As Double
Dim i As Integer
'get value
DecimalNumber = Val(lngDecimal)
'calculate
For i = 1 To Max_Bits
Remainder(i) = DecimalNumber Mod 2
DecimalNumber = DecimalNumber / 2
DecimalNumber = Int(DecimalNumber)
Next i
'build chromosome
For i = Max_Bits To 1 Step -1
EncodeChromosome = EncodeChromosome & Remainder(i)
Next i
Erase Remainder
End Function
Private Function DecodeChromosome(strChromosome As String) As Integer
Dim Binum(1 To Max_Bits) As Double
Dim Power As Double
Dim i As Integer
Dim BinLen As Integer
'Remove leading zeros
Do
If Len(strChromosome) = 0 Then Exit Function
If Mid(strChromosome, 1, 1) = "0" Then
strChromosome = Mid(strChromosome, 2)
Else
Exit Do
End If
Loop
'get the length of the Chromosome
BinLen = Len(strChromosome)
'get the value
Power = 2 ^ (BinLen - 1)
'calculate the decimal value
For i = 1 To Max_Bits
If Mid(strChromosome, i, 1) = "1" Then
Binum(i) = Power
ElseIf Mid(strChromosome, i, 1) = "0" Then
Binum(i) = 0
End If
Power = Power - (Power / 2)
Next i
'sum up the binary numbers
For i = 1 To Max_Bits
DecodeChromosome = DecodeChromosome + Binum(i)
Next i
Erase Binum 'Clear array
End Function
Public Property Let Fitness(Value As Double)
m_Fitness = Value
m_FitnessSet = True
End Property
Public Property Get Fitness() As Double
Fitness = m_Fitness
End Property