simplyga.cls

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

'Debug.Print "-"
'For g = 1 To popu.INDI(Individ).NofG
'Debug.Print popu.INDI(Individ).GENE(g)
'Next

End Sub
Private Sub MutateAll()
'''''''''''''''''''''''''''''
Dim I As Long
Dim Mp As Single
'Mp = MutProb * (100 / NofI)
Mp = MutProb

For I = 1 To NofI
    'MUTATION
    '    Stop
    
    If Rnd < Mp Then
        '        Stop
        '        Stop
        
        MutateIndi I, pMutateBestFit
    End If
Next I

End Sub
Private Sub FITNESStest()
Dim I As Long
Dim IndexOverALLBest As Long
Dim IndexGenerationBest As Long
Dim OverALLBest As Boolean
Dim GenerationBest As Boolean

OverALLBest = False
GenerationBest = False
GenerationBestFit = 1E+99

AVGfit = 0
For I = 1 To NofI
    
    
    
    
    INDI(I).FreeForSon = True
    
    '    If inid(I).IsChanged Then
    'FITNESS TEST
    'dont need
    'TEST_INDI i
    'Its done in from with simplyGA.indifitness
    
    If INDI(I).Fitness < BestFit Then
        BestFit = INDI(I).Fitness
        OverALLBest = True
        IndexOverALLBest = I
    End If
    
    If INDI(I).Fitness < GenerationBestFit Then
        GenerationBestFit = INDI(I).Fitness
        GenerationBest = True
        IndexGenerationBest = I
        GenerationINDEXBestFit = I
    End If
    
    
    '    End If
    AVGfit = AVGfit + INDI(I).Fitness
    
    ''''''''''''''''''''''''
    
    
Next I
AVGfit = AVGfit / NofI

EvalFitness IndexOverALLBest, IndexGenerationBest, _
        OverALLBest, GenerationBest, INFO

End Sub

Private Sub TEST_INDI(Individ As Long)

With INDI(Individ)
    .Fitness = .NetOutPut
End With
Stop

End Sub

Private Sub EvalFitness(IndexOverALLBest As Long, IndexGenerationBest As Long, OverALLBest As Boolean, GenerationBest As Boolean, INFOtext As TextBox)


Dim S As String
Dim GG As Long
Dim Gc As Long

If OverALLBest Then
    With INDI(IndexOverALLBest)
        S = "G " & Statistic.NofGEN & " Indi " & IndexOverALLBest & "  f(" & .Fitness & ") " & vbTab & vbTab
        For GG = 1 To .NofG
            S = S & .Gene(GG) & vbTab
            
            
            BestGENE(GG) = .Gene(GG)
            
        Next
        
    End With
    
    INFOtext.Text = INFOtext.Text & S & vbCrLf
    INFOtext.SelLength = 1
    INFOtext.SelStart = Len(INFOtext.Text)
    
    
    DebugPrintPop
    
    '   If frmIMAGE.Visible = True Then
    '       frmIMAGE.Caption = S
    '       frmIMAGE.DisplayBest IndexOverALLBest
    '   End If
    
    
    
    ' If Brain01.Visible = True Then
    '     Brain01.Caption = S
    '     Brain01.PrintWeights
    ' End If
    
    
    '   If TestGA.Visible = True Then
    '       TestGA.Caption = S
    '       TestGA.DisplayBest IndexOverALLBest
    '   End If
    
    '   If frmWORD.Visible = True Then
    '       frmWORD.Caption = S
    '       frmWORD.DisplayBest IndexOverALLBest
    '   End If
    
    
    
    If BestFit = 0 Then DebugPrintPop: MsgBox "Solution FOUND!!! " & vbCrLf & _
            "Generation: " & Statistic.NofGEN & "   Individ: " & IndexOverALLBest: ' Stop
    
End If


End Sub
Public Sub DebugPrintPop()

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

Debug.Print
Debug.Print "POPULATION"

For I = 1 To NofI
    S = "I" & I & " FIT:" & INDI(I).Fitness & vbTab & vbTab
    For G = 1 To INDI(I).NofG
        S = S & vbTab & INDI(I).Gene(G)
    Next
    Debug.Print S
Next


End Sub
Private Sub CreaWheel()
Dim Sum As Double
Dim Sum2 As Double
Dim Sum3 As Double

Dim MinF As Double
Dim MaxF As Double

Dim I As Long

MinF = 1E+99
MaxF = -1E+99
Sum = 0

For I = 1 To NofI
    With INDI(I)
        Sum = Sum + .Fitness
        If .Fitness < MinF Then MinF = .Fitness
        If .Fitness > MaxF Then MaxF = .Fitness
    End With
Next

MaxF = MaxF + 1
Sum2 = 0
For I = 1 To NofI
    Sum2 = Sum2 + (MaxF - INDI(I).Fitness)
Next

Sum3 = 0
'Debug.Print "WHEEL______________"
For I = 1 To NofI
    With INDI(I)
        Sum3 = Sum3 + 100 * (MaxF - .Fitness) / Sum2
        '               Debug.Print "fitness " & i, .Fitness, MaxF - .Fitness, 100 * (MaxF - .Fitness) / Sum2, Sum3
        .Wheel = Sum3
    End With
Next



'Stop

End Sub

Private Sub CreaRankWheel()
Dim Sum As Double
Dim Sum2 As Double
Dim Sum3 As Double

Dim MinF As Double
Dim MaxF As Double

Dim I As Long

MinF = 1E+99
MaxF = -1E+99
Sum = 0

For I = 1 To NofI
    '    With Indi(I)
    Sum = Sum + I '.Fitness
    '        If .Fitness < MinF Then MinF = .Fitness
    '        If .Fitness > MaxF Then MaxF = .Fitness
    '    End With
Next
MinF = 1
MaxF = NofI

MaxF = MaxF + 1
Sum2 = 0
For I = 1 To NofI
    '    Sum2 = Sum2 + (MaxF - Indi(I).Fitness)
    Sum2 = Sum2 + MaxF - I
Next
'Stop

Sum3 = 0
'Debug.Print "WHEEL______By Rank"
For I = 1 To NofI
    With INDI(I)
        ' Sum3 = Sum3 + 100 * (MaxF - .Fitness) / Sum2
        Sum3 = Sum3 + 100 * (MaxF - I) / Sum2
        '                      Debug.Print "fitness " & I, .Fitness, MaxF - I, 100 * (MaxF - I) / Sum2, Sum3
        .Wheel = Sum3
    End With
Next



'Stop

End Sub
Private Function GfnFindParent() As Long

Dim R As Double
Dim Wm As Double

Dim I As Long

R = fnRND(0, 100, False)

For I = 1 To NofI
    
    Wm = IIf(I = 1, 0, INDI(I - 1).Wheel)
    If R >= Wm And R < INDI(I).Wheel Then GfnFindParent = I: Exit For
Next
'Debug.Print "findp " & r, "Parent " & GfnFindParent
'Stop

'Stop

End Function

Private Sub SelectParents(ByRef P1 As Long, ByRef P2 As Long)

Select Case pSelectionMode
        
    Case enWheel
        '        WHEEL
        CreaWheel
        Do
            P1 = GfnFindParent
            P2 = GfnFindParent
        Loop While P1 = P2
        
    Case enRank
        
        QuickSortFitness 1, NofI
        '         RankWheel
        CreaRankWheel
        Do
            P1 = GfnFindParent
            P2 = GfnFindParent
            If P1 = 0 Or P2 = 0 Then Stop
            
        Loop While P1 = P2
        
        
    Case enRandO
        
        Do
            P1 = fnRND(1, NofI, True)
            P2 = fnRND(1, NofI, True)
        Loop While P1 = P2
        
        
        
End Select



End Sub
Public Sub Accoppia(Par1 As Long, Par2 As Long, pSonMode As Enum_ReproductMode, pCrossMode As Enum_CrossMode)
            'MATE
            
Dim NewIndi As tInd
Dim NewIndi2 As tInd

Dim G As Long
Dim G2 As Long
Dim G3 As Long

Dim WORST As Long

Dim Par As Long

Dim I2 As Long

Dim tmpNofG As Long
Dim VV2 As Integer
Dim V1 As Integer
Dim V2 As Integer
Dim oo As Integer
Dim NOG As Long
Dim SON As Long


Statistic.NofACC = Statistic.NofACC + 1

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

ReDim NewIndi.Gene(NewIndi.NofG)

'debug
'Debug.Print
'Debug.Print "ACCOPIA"
'With INDI(Par1)
'Debug.Print "Parent1 " & Par1, .Gene(1), .Gene(2), .Gene(3), .Gene(4), .Gene(5), .Gene(6)
'End With
'With INDI(Par2)
'Debug.Print "Parent2 " & Par2, .Gene(1), .Gene(2), .Gene(3), .Gene(4), .Gene(5), .Gene(6)
'End With
''crossover


Select Case pCrossMode
        
    Case SwapG
        For G = 1 To INDI(Par1).NofG
            If Rnd < 0.5 Then
                NewIndi.Gene(G) = INDI(Par1).Gene(G)
            Else
                NewIndi.Gene(G) = INDI(Par2).Gene(G)
            End If
        Next
        
    Case CrossG
        '''''''''' CROSS
        tmpNofG = INDI(Par1).NofG
        For I2 = 1 To tmpNofG
            NewIndi.Gene(I2) = INDI(Par1).Gene(I2)
        Next
        For VV2 = 1 To 2
            'Stop
            
            G = fnRND(1, tmpNofG - 1, True)
            G2 = fnRND(G, G + tmpNofG * 0.2, True) '''''% of genes max cross
            If G2 > tmpNofG Then G2 = tmpNofG
            'Debug.Print "               G replaced from " & G & " to " & G2 & "  (of " & tmpNofG & ")"
            '''For I2 = 1 To G - 1
            '''    NewIndi.Gene(I2) = Indi(Par1).Gene(I2)
            '''Next
            For I2 = G To G2 '- 1
                NewIndi.Gene(I2) = INDI(Par2).Gene(I2)
            Next
            'For I2 = G2 To tmpNofG
            '   NewIndi.Gene(I2) = Indi(Par1).Gene(I2)
            'Next
            
        Next VV2
        
    Case TSProblem
        
        
        NewIndi = EdgeRecombinationCrossover(Par1, Par2)
        GoTo skip
        
        ''USELESS
        'From Here to SKIP
        
        
        'Stop
        
        ''' travel salesman Crossover
        ''' indirect one-point crossover
        
        'The parents:
        '31|1111 (CABDEF)
        '11|1211 (ABCEFD)
        '
        'The children:
        '11|1111 (ABCDEF)
        '31|1211 (ABEDFC)
        Dim O1() As Integer
        Dim O2() As Integer
        
        ReDim O1(INDI(Par1).NofG)
        ReDim O2(INDI(Par1).NofG)
        
        TSPBuildO O1, Par1
        TSPBuildO O2, Par2
        
        NOG = INDI(Par1).NofG
        
        Do
            V1 = fnRND(1, NOG, True) '2
            V2 = fnRND(1, NOG, True)
        Loop While V2 < V1
        'If V2 = NOG And V1 = 1 Then Stop sometimes son is identical to par1 o par2
        V2 = NOG ''''''''''''*************************************************
        ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        
        If Rnd < 0.5 Then
            For oo = V1 To V2
                O1(oo) = O2(oo)
            Next oo
        Else
            For oo = V1 To V2
                O2(oo) = O1(oo)
            Next oo
            O1 = O2 ''''
        End If
        
        
        
        
        NewIndi = TSPBuildNewIndiFromO(O1)
        NewIndi2 = NewIndi
        
        
       GoTo skip
        ''''''''''''''''''''''''''''''''''''''''''''''
        ' make gene(1) start with 1  'riordinamento
        For G = 1 To NOG
            If NewIndi.Gene(G) = 1 Then Exit For
        Next
        
        G3 = G - 1
        
        For G = 1 To NOG
            G2 = G3 + G: If G2 > NOG Then G2 = G2 - NOG
            NewIndi.Gene(G) = NewIndi2.Gene(G2)
        Next G
        '''''''''''''''''''''''''''''''''''''''''''
skip:
End Select


'Stop

Select Case pSonMode
    Case SonToWorst
        ''' replace Worst
        WORST = GfnGetWORSTindi
        INDI(WORST) = NewIndi
    Case SonToNewINDI
        ''' ADDtoPop
        ADDIndi NewIndi
    Case SonToRndINDI
        ''' Replace rnd
        INDI(fnRND(1, NofI, True)) = NewIndi
    Case SonToParent
        ''' Replace one of 2 parents
        Par = IIf(Rnd < 0.5, Par1, Par2)
        INDI(Par) = NewIndi
End Select



'''''''''''''''''''''''''''
'Debug.Print "P1 " & Par1 & "  P2 " & Par2 & " --> " & WORST
'''''''''''''''''''''''''''

'debug
'With pp.INDI(WORST)
'Debug.Print
'Debug.Print "Son     " & WORST, .GENE(1), .GENE(2), .GENE(3), .GENE(4), .GENE(5), .GENE(6)
'End With


End Sub
Private Sub ADDIndi(ind As tInd)

NofI = NofI + 1
ReDim Preserve INDI(NofI)
INDI(NofI) = ind

End Sub
Public Function GfnGetWORSTindi() As Long
'private
Dim MaxF As Double
Dim I As Long

MaxF = -1E+99

For I = 1 To NofI
    With INDI(I)
        '        If I <> GenerationINDEXBestFit Then'''useless
        '        Stop
        
        If .FreeForSon Then
            If .Fitness > MaxF Then MaxF = .Fitness: GfnGetWORSTindi = I
        End If
        '        End If
        
    End With
Next
INDI(GfnGetWORSTindi).FreeForSon = False


End Function
Public Sub COMPUTEGENES()
Dim II As Long
Dim BF
Dim Parent1 As Long
Dim Parent2 As Long
Dim S As String
Dim Bool As Boolean
'Stop
Dim V As Long


Statistic.NofGEN = Statistic.NofGEN + 1

'Stop

For II = 1 To NofI
    INDI(II).IsChanged = False
Next


'MUTATE
MutateAll
'Stop

'FITNESS TEST
FITNESStest
'Stop
For V = 1 To ReprodXGeneration '* NofI
    'GETPARENTS
    SelectParents Parent1, Parent2