simplyga.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 = "SimplyGA"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'Author : Creator Roberto Mior
'     [e-mail]
'
'If you use source code or part of it please cite the author
'You can use this code however you like providing the above credits remain intact
'
'
'
'------------------------------------------------------------------------
'
'   Dim GA As SimplyGA
'
'   Set GA = New SimplyGA
'
'   GA.INIT
'
'   start cicle
'
'       if GA.IsIndiChanged(Individual)  then 'update fitness of  individual
'
'               Perform function fitness Based on Genes Values
'               GA.getGENE (Individual, WhichGene)
'               GA.IndiFitness(Individual)=  ....
'
'                   eg:     F=GA.getGENE(n,1)+GA.getGENE(n,2)  'Some function that evaluate population
'                           GA.IndiFitness(n)=F
'
'       End If
'
'       GA.COMPUTEGENES
'
'   end cicle
'----------------------------------
'
' Look [INIT] for parameters description
'

Option Explicit

#If False Then 'if you type the Enum value in the wrong case, Visual Basic corrects it so it matches the hidden variable declarations.
Dim enRandO
Dim enWheel
Dim enRank
Dim SonToWorst
Dim SonToNewINDI
Dim SonToRndINDI
Dim SonToParent
Dim SwapG
Dim CrossG

#End If

Public Enum Enum_SelMode
    enRandO = 0
    enWheel = 1
    enRank = 2
End Enum

Public Enum Enum_ReproductMode
    SonToRndINDI = 0
    SonToWorst = 1
    SonToParent = 2
    SonToNewINDI = 3
End Enum

Public Enum Enum_CrossMode
    SwapG = 0
    CrossG = 1
    TSProblem = 2
End Enum


Private Type tStat
    NofACC As Long
    NofMUT As Long
    NofNEW As Long
    NofGEN As Long
End Type




Private Type tInd
    
    NofG As Long
    Gene() As Long
    Fitness As Double
    Wheel As Double
    NetOutPut As Double
    
    FreeForSon As Boolean
    
    IsChanged As Boolean
    
    
End Type


Event TESTINDIevent(Individ As Long)

Private SonMode As Enum_ReproductMode
Private CrossMode As Enum_CrossMode

Private NofI As Integer
Private INDI() As tInd
Private gValueMax As Long
Private gValueMin As Long

Private MutProbProp As Boolean
Private MutProb As Single
Private MutRate As Single

Private BestFit As Double
Private GenerationBestFit As Double
Private GenerationINDEXBestFit As Long

Private Statistic As tStat

Private pSelectionMode As Enum_SelMode
Private pMutateBestFit As Boolean

Private ReprodXGeneration As Long


Private BestGENE()       As Long

Private LookForDisaster As Long

Private AVGfit As Double
Private INFO As TextBox



Public Property Let INDINetOutPut(indiv, Val As Double)
INDI(indiv).NetOutPut = Val
End Property


Public Property Get pLookForDisaster() As Long
pLookForDisaster = LookForDisaster
End Property

Public Property Get IsIndiChanged(ind As Long) As Boolean 'since perv generation
IsIndiChanged = INDI(ind).IsChanged
End Property


Public Property Get Son_Mode() As Enum_ReproductMode
Son_Mode = SonMode
End Property
Public Property Get Cross_Mode() As Enum_CrossMode
Cross_Mode = CrossMode
End Property
Public Property Let Son_Mode(sMode As Enum_ReproductMode)
SonMode = sMode
End Property
Public Property Let Cross_Mode(cMode As Enum_CrossMode)
CrossMode = cMode
End Property

Public Property Get pSelection_Mode() As Enum_SelMode
pSelection_Mode = pSelectionMode
End Property
Public Property Let pSelection_Mode(sMode As Enum_SelMode)
pSelectionMode = sMode
End Property

Public Property Get pMutateBestToo() As Single
pMutateBestToo = pMutateBestFit
End Property
Public Property Get pMutationProb() As Single
pMutationProb = MutProb
End Property
Public Property Get pMutationRate() As Single
pMutationRate = MutRate
End Property
Public Property Get StatAccop() As Long
StatAccop = Statistic.NofACC
End Property
Public Property Get StatGeneration() As Long
StatGeneration = Statistic.NofGEN
End Property
Public Property Get StatMutations() As Long
StatMutations = Statistic.NofMUT
End Property
Public Property Get StatNEWs() As Long
StatNEWs = Statistic.NofNEW
End Property
Public Property Get Get_gValueMin() As Double
Get_gValueMin = gValueMin
End Property
Public Property Get Get_gValueMax() As Double
Get_gValueMax = gValueMax
End Property
Public Property Get GeneratBestFit() As Double
GeneratBestFit = GenerationBestFit
End Property

Public Property Get GeneratINDEXBestFit() As Double
GeneratINDEXBestFit = GenerationINDEXBestFit
End Property


Public Property Get GenerationAvgFit() As Double
GenerationAvgFit = AVGfit
End Property
Public Property Let IndiFitness(Individ, FitnessValue As Double)
INDI(Individ).Fitness = FitnessValue
End Property

Public Property Get IndiFitness(Individ) As Double
IndiFitness = INDI(Individ).Fitness
End Property

Public Property Get NumberOfIndivid() As Long
NumberOfIndivid = NofI
End Property
Public Property Get NumberOfGenes(indiv) As Long
NumberOfGenes = INDI(indiv).NofG
End Property
Private Function GfnCreateRandomIndi(NofGene, gvMIN, gvMAX) As tInd

Dim G As Long
Dim Gpos As Long

GfnCreateRandomIndi.NofG = NofGene
GfnCreateRandomIndi.Fitness = 1E+99
ReDim GfnCreateRandomIndi.Gene(NofGene)


If CrossMode <> TSProblem Then
    
    
    For G = 1 To NofGene
        GfnCreateRandomIndi.Gene(G) = fnRND(gvMIN, gvMAX, True)
    Next
    
Else 'TSP
    
    
    For G = 1 To NofGene
        GfnCreateRandomIndi.Gene(G) = 0
    Next
    '
    For G = 1 To NofGene
        Do
            Gpos = fnRND(1, NofGene, True)
        Loop While GfnCreateRandomIndi.Gene(Gpos) <> 0
        GfnCreateRandomIndi.Gene(Gpos) = G
    Next
    
    
    
End If
GfnCreateRandomIndi.IsChanged = True


End Function
Private Function fnRND(Min, Max, DoRound As Boolean)

fnRND = Rnd * (Max - Min) + Min
If DoRound Then fnRND = Round(fnRND)
'Debug.Print "fnRND___ ", min, max, fnRND

End Function




Public Sub INIT(NofIndi, NofGene, gvMIN, gvMAX, _
        Mutate_Prob, Mutate_Rate, _
        SelMode As Enum_SelMode, PercNewSonXGeneration, _
        MutBest As Boolean, _
        ReproductMode As Enum_ReproductMode, _
        aCrossMode As Enum_CrossMode, TextINFO As TextBox, _
        Optional LookForDisasterEvery As Long)


'NofIndi        Number of Individuals
'
'NofGene        Number of Genes ( x individ )
'
'gvMin          Genes Values range from this
'gvMax          to this
'
'Mutate_Prob    Each individ at each generation have this
'               Mutation Probability
'
'Mutate_Rate    How Much Individ Gene Mutate (0-1)
'               [Only One Gene Mutates] if CrossMode<>TSP
'
'SelMode        Parent Selection Mode
'               enRandO = 0     2 Random Individs
'               enWheel = 1     By Roulette Wheel (Probability of Individ
'                                  to be a parent is inverse proportional
'                                  to fitness Value)
'               enRank = 2      By Rank
'
'PercNewSonXGeneration  Each Generation makes a number of Reproductions
'                       equal to this value multiplied by Number of Individs
'                       e.g.    PNSXG=0.01 , NumberOfIndivid = 200
'                               Number of Reproductions per Generation =
'                               PNSXG*NumberOfIndivid = 0.01*200 = 2
'                       0 means 1 Reproduction per Generation
'
'MutBest        Mutate Best Individ too?
'
'ReproductMode  Where to place the Childs
'               SonToRndINDI = 0    New Child Substitute a Random Individ
'               SonToWorst = 1      New Child Substitute the Worst Individ
'               SonToParent = 2     New Child Substitute one of two Parent
'               SonToNewINDI = 3    New Child is an added New Individ
'
'aCrossMode     Crossover Mode (how child genes are created)
'               SwapG = 0       Each Child Gene have 50% of prob to be of
'                               one of the 2 parents
'               CrossG = 1      Random Sequences of Genes from Both Parents
'                               (to better develop)
'               TSProblem = 2   Edge Recombination (for TravelSalesmanProblem)
'                               Genes change only their Order Position
'
'textINFO       a TextBox 'REMENBER!
'               TextINFO.MultiLine = True
'               TextINFO.ScrollBars = 2 - vertical
'
'LookForDisasterEvery   Generations Interval to Check for Social Disaster.
'                       Social Disaster means Many Equal Individs
'                       After this Check, all Genes of Equal Individs
'                       are Randomized

Dim I As Long
Dim S As String
Dim NOG As Long
Dim G As Long

ReprodXGeneration = Round(PercNewSonXGeneration * NofIndi)
If ReprodXGeneration < 1 Then ReprodXGeneration = 1
'Stop


' Mutation Prob=0 means proportional
MutProbProp = IIf(Mutate_Prob = 0, True, False)


Set INFO = TextINFO


NofI = NofIndi
MutProb = Mutate_Prob
MutRate = Mutate_Rate
gValueMax = gvMAX
gValueMin = gvMIN
pSelectionMode = SelMode
pMutateBestFit = MutBest
SonMode = ReproductMode
CrossMode = aCrossMode


BestFit = 1E+99

ReDim BestGENE(NofGene)
ReDim INDI(NofIndi)

For I = 1 To NofIndi
    
    INDI(I) = GfnCreateRandomIndi(NofGene, gvMIN, gvMAX)
    
    MutateIndi I, True
    MutateIndi I, True
    
Next

If LookForDisasterEvery = 0 Then LookForDisasterEvery = 2 ^ 30 '1000000000

LookForDisaster = LookForDisasterEvery



Statistic.NofACC = 0
Statistic.NofMUT = 0
Statistic.NofNEW = 0
Statistic.NofGEN = 0



S = "Genetic Algorithm Initialized! " & vbCrLf & vbCrLf
S = S + "Current Parameters:" & vbCrLf
S = S + "Number of Individuals " & vbTab & NofI & vbCrLf
S = S + "Number of Gene x Indiv" & vbTab & NofGene & vbCrLf
S = S + "Mutation Probability  " & vbTab & MutProb * 100 & "%" & vbCrLf
S = S + "Mutation Rate (gene)  " & vbTab & MutRate * 100 & "%" & vbCrLf
S = S + "Minim Gene Value      " & vbTab & gValueMin & vbCrLf
S = S + "Max   Gene Value      " & vbTab & gValueMax & vbCrLf
S = S + "Parent Selection Mode " & vbTab & pSelectionMode & vbCrLf
S = S + "Can even Mutate Best I" & vbTab & MutBest & vbCrLf
S = S + "Placement of Son      " & vbTab & SonMode & vbCrLf
S = S + "Cross Mode            " & vbTab & CrossMode & vbCrLf
S = S + "Test Disaster Every   " & vbTab & LookForDisaster & vbCrLf


'MsgBox S, vbInformation, "GA created!"

End Sub

Public Sub ReplaceIdenticalINDI(INFOtext As TextBox)

Dim I As Long
Dim j As Long
Dim NOG As Long
Dim G As Long
Dim T As Integer



Dim iden() As Long
Dim S As String
Dim PervNumOfNew
'DebugPrintPop PP
PervNumOfNew = Statistic.NofNEW

NOG = INDI(1).NofG

For I = 1 To NofI - 1
    For j = I + 1 To NofI
        G = 1
        
Q1:
        If G <= NOG Then If INDI(I).Gene(G) = INDI(j).Gene(G) Then G = G + 1: GoTo Q1
        If G > NOG Then
            Statistic.NofNEW = Statistic.NofNEW + 1
            INDI(I) = GfnCreateRandomIndi(NOG, gValueMin, gValueMax)
            
            
        End If
        
    Next j
Next I

If Len(INFOtext) > 10000 Then INFOtext.Text = ""

S = "Generation " & Statistic.NofGEN '& Statistic.NofACC
S = S & "   Look for Disaster. New Random Individ Generated = " & _
        Statistic.NofNEW - PervNumOfNew & " of " & NofI & vbTab & " (Total =" & Statistic.NofNEW & ") " & vbCrLf



INFOtext.Text = INFOtext.Text & S
INFOtext.SelStart = Len(INFOtext.Text)
'DebugPrintPop pp
End Sub
Private Sub MutateIndi(Individ, MutateBest As Boolean)
Dim OLD
Dim MR
Dim G As Long
Dim G2 As Long
Dim T As Integer
Dim Times As Integer
Dim NOG As Long

Dim POS As Long



INDI(Individ).IsChanged = True



If CrossMode <> TSProblem Then
    
    
    'Not MUTATE Best Indi
    'goes only if Mutate is call after FitnessTest
    '    If Not (MutateBest) Then If GenerationBestFit = Indi(Individ).Fitness Then Exit Sub 'DebugPrintPop popu: Stop
    '    Stop
    
    If Not (MutateBest) Then If GenerationINDEXBestFit = Individ Then Exit Sub
    
    
    
    Statistic.NofMUT = Statistic.NofMUT + 1
    'Debug.Print "-"
    'For g = 1 To popu.INDI(Individ).NofG
    'Debug.Print popu.INDI(Individ).GENE(g)
    'Next
    MR = MutRate
    
    With INDI(Individ)
        ''''''cambia '''''
        G = fnRND(1, INDI(Individ).NofG, True)
        
        OLD = .Gene(G)
        
        MR = fnRND(-MutRate / 2, MutRate / 2, False)
        
        OLD = OLD + MR * (gValueMax - gValueMin)
        
        If OLD < gValueMin Then OLD = gValueMin
        If OLD > gValueMax Then OLD = gValueMax
        
        .Gene(G) = OLD
        
        '.Fitness = 1E+99
        '.Wheel = 0
    End With
    
    
Else 'TSP
    
    'Not MUTATE Best Indi
    'goes only if Mutate is call after FitnessTest
    'If Not (MutateBest) Then If GenerationBestFit = Indi(Individ).Fitness Then Exit Sub 'DebugPrintPop popu: Stop
    If Not (MutateBest) Then If GenerationINDEXBestFit = Individ Then Exit Sub
    
    
    
    Statistic.NofMUT = Statistic.NofMUT + 1
    
    
    '    Stop
    'NOG = Indi(Individ).NofG
    '    ''' travel salesman mutation 'TSP
    ''    Times = 1 + Indi(Individ).NofG * MutRate
    ''    For T = 1 To Times
    '        With Indi(Individ)'''
    '
    '            G = fnRND(1, NOG, True)  '
    '            G2 = G + 1                                 'this is corret
    '            If G2 > NOG Then G2 = 1
    ''            G = fnRND(1, NOG, True)
    ''            Do
    ''                G2 = fnRND(1, NOG, True)
    ''            Loop While G = G2
    '
    '            OLD = .Gene(G)
    '            .Gene(G) = .Gene(G2)
    '            .Gene(G2) = CLng(OLD)
    '        End With
    ''    Next T
    '
    'Stop
    NOG = INDI(Individ).NofG
    With INDI(Individ)
        
        POS = fnRND(1, NOG, True)
        G2 = .Gene(POS)
        
        For T = POS To NOG - 1
            .Gene(T) = .Gene(T + 1)
        Next
        POS = fnRND(1, NOG, True)
        For T = NOG To POS + 1 Step -1
            .Gene(T) = .Gene(T - 1)
        Next
        .Gene(POS) = G2
    End With
    
    
End If