simplyga.cls

利用遗传算法来改进神经网络程序,神经网络与遗传算法

    'REPRODUCTION
    Accoppia Parent1, Parent2, SonMode, CrossMode
Next V



'MutateAll

'Stop

If Statistic.NofGEN / LookForDisaster = Statistic.NofGEN \ LookForDisaster Then
    '       Stop
    
    ReplaceIdenticalINDI INFO
End If

'If GeneratBestFit / GenerationAvgFit > 0.9995 Then ReplaceIdenticalINDI INFO
'> 0.997
'If GenerationBestFit = GenerationAvgFit Then ReplaceIdenticalINDI INFO
'Debug.Print GeneratBestFit / GenerationAvgFit
If MutProbProp Then
    MutProb = (GenerationBestFit / GenerationAvgFit) / 10 '5
End If
'Stop

End Sub

Public Function getGENE(Individ As Long, Gene As Long) As Long
getGENE = INDI(Individ).Gene(Gene)


End Function
Public Sub SetGENE(Individ As Long, Gene, Valu As Long)
INDI(Individ).Gene(Gene) = Valu

End Sub


Public Sub KillIndi(Individ As Long)
Dim II As Long

For II = Individ To NofI - 1
    INDI(II) = INDI(II + 1)
Next II

NofI = NofI - 1
ReDim Preserve INDI(NofI)
End Sub



Public Sub Save_POP(Optional Filename = "POP.txt")
Dim II  As Long
Dim GG As Long

Open App.Path & "\" & Filename For Output As 1

Print #1, "Num of INDIs"
Print #1, NofI
Print #1, "Num of GENEs (x indi)"
Print #1, INDI(1).NofG
Print #1, "Min Max Gene Value"
Print #1, gValueMin
Print #1, gValueMax
Print #1, "Mutation Prob"
Print #1, Replace(MutProb, ",", ".")
Print #1, "Mutation Rate"
Print #1, Replace(MutRate, ",", ".")
Print #1, "Selection Mode"
Print #1, pSelectionMode
Print #1, "ReprodXGeneration"
Print #1, ReprodXGeneration
Print #1, "Son       Mode"
Print #1, SonMode
Print #1, "Cross      Mode"
Print #1, CrossMode
Print #1, "Mutate Best"
Print #1, CInt(pMutateBestFit)
Print #1, "INDEX BEST INDI"
Print #1, GenerationINDEXBestFit
Print #1, "LookForDisasterEvery"
Print #1, LookForDisaster

For II = 1 To NofI
    Print #1, "---------------INDI " & II
    For GG = 1 To INDI(II).NofG
        Print #1, INDI(II).Gene(GG)
    Next GG
Next II
Close 1

End Sub
Public Sub Load_POP(Optional Filename = "POP.txt")

Dim II  As Long
Dim GG As Long
Dim S As String

Open App.Path & "\" & Filename For Input As 1

Input #1, S
Input #1, NofI

ReDim INDI(0 To NofI)

Input #1, S
Input #1, INDI(1).NofG

ReDim BestGENE(1 To INDI(1).NofG)
'Stop

Input #1, S
Input #1, gValueMin
Input #1, gValueMax
Input #1, S
Input #1, MutProb
Input #1, S
Input #1, MutRate
Input #1, S
Input #1, pSelectionMode
Input #1, S
Input #1, ReprodXGeneration
Input #1, S
Input #1, SonMode
Input #1, S
Input #1, CrossMode
Input #1, S
Input #1, S
If S = "-1" Then pMutateBestFit = True Else: pMutateBestFit = False
Input #1, S
Input #1, GenerationINDEXBestFit
Input #1, S
Input #1, LookForDisaster

For II = 1 To NofI
    
    Input #1, S
    ReDim INDI(II).Gene(1 To INDI(1).NofG)
    INDI(II).NofG = INDI(1).NofG
    
    For GG = 1 To INDI(II).NofG
        
        Input #1, INDI(II).Gene(GG)
        
        INDI(II).Fitness = 1E+16
        
    Next GG
    
Next II

Close 1



INFO = ""

End Sub
Public Sub RandomALLIndi()
Dim I As Long

For I = 1 To NofI
    
    INDI(I) = GfnCreateRandomIndi(INDI(I).NofG, gValueMin, gValueMax)
    MutateIndi I, True
    MutateIndi I, True
    
Next
BestFit = 1E+99
GenerationBestFit = 1E+99
GenerationINDEXBestFit = 1

End Sub


Private Sub TSPBuildO(ByRef O, ind As Long) 'USELESS
Dim busy() As Boolean
Dim G As Long
Dim NOG As Long
Dim NB As Integer
Dim POS As Integer


NOG = INDI(ind).NofG
ReDim busy(NOG)

With INDI(ind)
    O(1) = .Gene(1)
    busy(.Gene(1)) = True
    'Debug.Print O(1) & "   Gval=" & .Gene(1)
    For G = 2 To NOG
        NB = 0
        For POS = 1 To .Gene(G)
            If busy(POS) = False Then NB = NB + 1
        Next
        O(G) = NB
        '   Debug.Print NB & "   Gval=" & .Gene(G)
        busy(.Gene(G)) = True
        
        If NB = 0 Or .Gene(G) = 0 Then Stop
        
    Next
    'Debug.Print
    
End With

End Sub

Private Function TSPBuildNewIndiFromO(ByRef O) As tInd 'USELESS
Dim tINDI As tInd

Dim busy() As Boolean
Dim G As Long
Dim NOG As Long
Dim NB As Integer
Dim POS As Integer

NOG = INDI(1).NofG
ReDim busy(NOG)
With tINDI
    ReDim .Gene(NOG)
    .NofG = NOG
    .Fitness = 1E+99
    .Wheel = 0 'da calcolare
    
    .Gene(1) = O(1)
    'Debug.Print O(1) & "   g" & .Gene(1)
    busy(.Gene(1)) = True
    
    For G = 2 To NOG
        NB = 0
        POS = 0
        Do
            POS = POS + 1
            If POS > NOG Then POS = 1
            If busy(POS) = False Then NB = NB + 1
        Loop While NB <> O(G)
        
        .Gene(G) = POS
        '   Debug.Print O(G) & "   g" & POS
        busy(.Gene(G)) = True
        
        If O(G) = 0 Or POS = 0 Then Stop
        
    Next
    'Debug.Print "---"
End With

TSPBuildNewIndiFromO = tINDI

End Function


Sub SortByFitness()
Dim I1 As Long
Dim I2 As Long
Dim SW As Long
Dim tmpINDI As tInd

'''' after this best fit is indi(1)
Again:
SW = 0
For I1 = 1 To NofI - 1
    For I2 = I1 + 1 To NofI
        If INDI(I1).Fitness > INDI(I2).Fitness Then
            tmpINDI = INDI(I1)
            INDI(I1) = INDI(I2)
            INDI(I2) = tmpINDI
            SW = SW + 1
        End If
    Next I2
Next I1
'Stop

If SW <> 0 Then GoTo Again


End Sub



Private Sub QuickSortFitness(ByVal lngFirst As Long, ByVal lngLast As Long)
'
' This is the unique part of code taken from PSC BigGenetic Proplem
'
'
' Quicksort in order to sort the chromosomes by their fitness.
'
'            I got this version of quicksort years ago from
'            a website (I believe from www.gamedev.net but
'            I'm not sure). Original code was in C and Quickbasic.
'            The quickbasic version was rewritten by me
'            several times over the past years until
'            the version you see here. I use it in
'            several of my projects.
'

Dim lngLow                  As Long
Dim lngHigh                 As Long

Dim dblMidValue             As Double

'    Dim HelpChromo              As ChromosomeindividualType
Dim tmpINDI         As tInd


lngLow = lngFirst
lngHigh = lngLast

' take the absolute value of fitness
'    dblMidValue = Abs(Chromosome((lngFirst + lngLast) \ 2).Fitness)
dblMidValue = Abs(INDI((lngFirst + lngLast) \ 2).Fitness)
Do
    'While Abs(Chromosome(lngLow).Fitness) < dblMidValue
    While INDI(lngLow).Fitness < dblMidValue
        lngLow = lngLow + 1
    Wend
    'While Abs(Chromosome(lngHigh).Fitness) > dblMidValue
    While INDI(lngHigh).Fitness > dblMidValue
        lngHigh = lngHigh - 1
    Wend
    If lngLow <= lngHigh Then
        GoSub swap
        lngLow = lngLow + 1
        lngHigh = lngHigh - 1
    End If
Loop While lngLow <= lngHigh
If lngFirst < lngHigh Then QuickSortFitness lngFirst, lngHigh
If lngLow < lngLast Then QuickSortFitness lngLow, lngLast

' the chromosome-array is sorted
'mblnSorted = True

Exit Sub

swap:
'HelpChromo = Chromosome(lngLow)
'Chromosome(lngLow) = Chromosome(lngHigh)
'Chromosome(lngHigh) = HelpChromo
tmpINDI = INDI(lngLow)
INDI(lngLow) = INDI(lngHigh)
INDI(lngHigh) = tmpINDI
Return

End Sub


'Public Sub CREATEWHEEL()
'Stop
'
'Select Case pSelectionMode
'
'    Case enWheel
'        CreaWheel
'
'    Case enRank
'        QuickSortFitness 1, NofI
'        CreaRankWheel
'
'End Select
'
'End Sub


Private Function EdgeRecombinationCrossover(P1 As Long, P2 As Long) As tInd

'Translated for my pourpose from here
'http://www.rubicite.com/genetic/tutorial/crossover4.php

Dim NI As tInd
Dim NeiList() As New Collection
Dim CHILD As New Collection
Dim getCHILD As New Collection
Dim NOG As Long
Dim G As Long
Dim G1 As Long
Dim G2 As Long
Dim V1 As Long
Dim V2 As Long
Dim p1G1 As Long
Dim p1G2 As Long
Dim p2G1 As Long
Dim p2G2 As Long
Dim x As Long
Dim Z As Long
Dim GG As Long
Dim E As Integer
Dim S As String



NI.Fitness = 1E+99
NI.NofG = INDI(P1).NofG
NI.Wheel = 0 'da calcolare
NI.IsChanged = True

ReDim NI.Gene(NI.NofG)

ReDim NeiList(NI.NofG)

NOG = NI.NofG

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Generate Neighbor List
For G = 1 To NOG
    G1 = G - 1
    G2 = G + 1
    If G1 < 1 Then G1 = NOG
    If G2 > NOG Then G2 = 1
    
    V1 = INDI(P1).Gene(G)
    V2 = INDI(P2).Gene(G)
    p1G1 = INDI(P1).Gene(G1)
    p1G2 = INDI(P1).Gene(G2)
    p2G1 = INDI(P2).Gene(G1)
    p2G2 = INDI(P2).Gene(G2)
    
    
    If collNotInColl(NeiList(V1), p1G1) Then NeiList(V1).Add p1G1
    If collNotInColl(NeiList(V1), p1G2) Then NeiList(V1).Add p1G2
    If collNotInColl(NeiList(V2), p2G1) Then NeiList(V2).Add p2G1
    If collNotInColl(NeiList(V2), p2G2) Then NeiList(V2).Add p2G2
    
    'collRemoveItem CHILD, G
    getCHILD.Add G
Next
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Debug.Print "-----------------------------------------------------"

'Stop

x = INDI(P1).Gene(1)

GG = 0
Do
    '   GoSub debugNeilist
    
    GG = GG + 1: If GG > NOG - 1 Then Exit Do
    '   Append X to CHILD
    '   Remove X from Neighbor Lists
    CHILD.Add x
    collRemoveItem getCHILD, x
    
    
    For G = 1 To NOG
        collRemoveItem NeiList(G), x
    Next
    
    'if X's neighbor list is empty:
    If NeiList(x).Count = 0 Then
        'Z = random node not already in CHILD
        
        
        Z = collPickFrom(getCHILD)
        
        'If Not (collNotInColl(CHILD, Z)) Then Stop
    Else
        
        '- Determine neighbor of X that has fewest neighbors
        '- If there is a tie, randomly choose 1
        '- Z = chosen node
        Dim Min
        Min = 99999999
        
        For E = 1 To NeiList(x).Count
            If NeiList(NeiList(x).Item(E)).Count < Min Then
                Min = NeiList(NeiList(x).Item(E)).Count
                Z = NeiList(x).Item(E) 'E
                
            End If
        Next
        '        Stop
        
        '   collRemoveItem getCHILD, Z
        
    End If
    
    x = Z
    
Loop While True

Z = collPickFrom(getCHILD)
CHILD.Add Z


'Debug.Print "Child"
For G = 1 To NOG
    'Debug.Print CHILD.Item(G);
    NI.Gene(G) = CHILD.Item(G)
    
    'If collNotInColl(CHILD, G) Then
    '    'error
    '    Stop
    'End If
    
Next
'Debug.Print
'''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set CHILD = Nothing
Set getCHILD = Nothing
For G = 1 To NOG
    Set NeiList(G) = Nothing
Next

EdgeRecombinationCrossover = NI
Exit Function



'''''''''''''''''''''''''''''''''''''''''''''''''''''''
'debug
debugNeilist:

S = ""
For G = 1 To NOG
    S = S + CStr(INDI(P1).Gene(G)) & vbTab
Next: S = S & vbCrLf
For G = 1 To NOG
    S = S + CStr(INDI(P2).Gene(G)) & vbTab
Next: S = S & vbCrLf
Debug.Print S
S = ""
For G1 = 1 To NOG
    S = S & G1 & " |" & vbTab
    For G2 = 1 To NeiList(G1).Count
        S = S & NeiList(G1).Item(G2) & vbTab
    Next: S = S & vbCrLf
Next
Debug.Print S
Return
'''''''''''''''''''''''''''''''''''''''''''''''''''''''


End Function
Private Function collNotInColl(C As Collection, Val) As Boolean
Dim E As Integer

collNotInColl = True
'If C.Count = 0 Then Stop

For E = 1 To C.Count
    If C.Item(E) = Val Then collNotInColl = False: Exit For
Next

End Function

Private Sub collRemoveItem(ByRef C As Collection, Val)
Dim E As Integer
If C.Count = 0 Then Exit Sub

E = 0
Do
    E = E + 1
    If C.Item(E) = Val Then C.Remove E: Exit Do
Loop While E < C.Count

End Sub

Private Function collPickFrom(ByRef C As Collection) As Integer
Dim E As Integer
'Stop
'If C.Count = 0 Then Stop

E = Int(Rnd * C.Count) + 1

collPickFrom = C.Item(E)

'C.Remove E

End Function