cgabob.vb

来自「一个使用VB.Net开发的演示人工神经网络的程序」· VB 代码 · 共 346 行

Public Class SGenome
    Dim m_vecBits As ArrayList
    Dim m_dFitness As Double
    Public Sub New(ByVal num_bits As Integer)
        Dim i As Integer
        m_vecBits = New ArrayList
        m_dFitness = 0

        For i = 0 To num_bits - 1
            m_vecBits.Add(Utils.RandInt(0, 1))
        Next
    End Sub

    Public Property dFitness() As Double
        Get
            Return m_dFitness
        End Get
        Set(ByVal Value As Double)
            m_dFitness = Value
        End Set
    End Property

    Public ReadOnly Property vecBits() As ArrayList
        Get
            Return m_vecBits
        End Get
    End Property
End Class

Public Class CgaBob
    '//the population of genomes
    Dim m_vecGenomes As New ArrayList

    '//size of population
    Dim m_iPopSize As Integer

    Dim m_dCrossoverRate As Double

    Dim m_dMutationRate As Double

    '//how many bits per chromosome
    Dim m_iChromoLength As Integer

    '//how many bits per gene
    Dim m_iGeneLength As Integer

    Dim m_iFittestGenome As Integer

    Dim m_dBestFitnessScore As Double

    Dim m_dTotalFitnessScore As Double

    Dim m_iGeneration As Integer

    '//create an instance of the map class
    Dim m_BobsMap As New CBobsMap

    '//we use another CBobsMap object to keep a record of 
    '//the best route each generation as an array of visited
    '//cells. This is only used for display purposes.
    Dim m_BobsBrain As New CBobsMap

    '//lets you know if the current run is in progress.
    Dim m_bBusy As Boolean


    '//----------------------------Mutate---------------------------------
    '//	iterates through each genome flipping the bits acording to the
    '//	mutation rate
    '//--------------------------------------------------------------------
    Private Sub Mutate(ByVal vecBits As ArrayList)
        Dim i As Integer
        For i = 0 To vecBits.Count - 1
            '//do we flip this bit?
            If (Utils.RandFloat() < m_dMutationRate) Then
                '//flip the bit
                If vecBits(i) = 0 Then
                    vecBits(i) = 1
                Else
                    vecBits(i) = 0
                End If
            End If
        Next

    End Sub

    '//----------------------------Crossover--------------------------------
    '//	Takes 2 parent vectors, selects a midpoint and then swaps the ends
    '//	of each genome creating 2 new genomes which are stored in baby1 and
    '//	baby2.
    '//---------------------------------------------------------------------
    Private Sub Crossover(ByVal mum As ArrayList, ByVal dad As ArrayList, ByRef baby1 As ArrayList, ByRef baby2 As ArrayList)
        '//just return parents as offspring dependent on the rate
        '//or if parents are the same
        If ((Utils.RandFloat() > m_dCrossoverRate) Or (Me.ArrayEqual(mum, dad))) Then
            baby1 = mum.Clone
            baby2 = dad.Clone
            Return
        End If

        '//determine a crossover point
        Dim cp As Integer = Utils.RandInt(0, m_iChromoLength - 1)

        '//swap the bits
        Dim i As Integer
        For i = 0 To cp - 1
            baby1(i) = mum(i)
            baby2(i) = dad(i)
        Next

        For i = cp To mum.Count - 1
            baby1(i) = dad(i)
            baby2(i) = mum(i)
        Next
    End Sub

    '//--------------------------RouletteWheelSelection-----------------
    '//
    '//	selects a member of the population by using roulette wheel 
    '//	selection as described in the text.
    '//------------------------------------------------------------------
    Private Function RouletteWheelSelection() As SGenome
        Dim fSlice As Double = Utils.RandFloat() * m_dTotalFitnessScore

        Dim cfTotal As Double = 0.0

        Dim SelectedGenome As Integer = 0

        Dim i As Integer

        For i = 0 To m_iPopSize - 1
            cfTotal += CType(m_vecGenomes(i), SGenome).dFitness

            If (cfTotal > fSlice) Then
                SelectedGenome = i
                Exit For
            End If
        Next

        Return m_vecGenomes(SelectedGenome)
    End Function

    Private Function ArrayEqual(ByVal arr1 As ArrayList, ByVal arr2 As ArrayList) As Boolean
        Dim i As Integer
        For i = 0 To arr1.Count - 1
            If arr1(i) <> arr2(i) Then Return False
        Next
        Return True
    End Function
    '//updates the genomes fitness with the new fitness scores and calculates
    '//the highest fitness and the fittest member of the population.
    '//---------------------------UpdateFitnessScores------------------------
    '//	updates the genomes fitness with the new fitness scores and calculates
    '//	the highest fitness and the fittest member of the population.
    '//	Also sets m_pFittestGenome to point to the fittest. If a solution
    '//	has been found (fitness == 1 in this example) then the run is halted
    '//	by setting m_bBusy to false
    '//-----------------------------------------------------------------------
    Private Sub UpdateFitnessScores()
        m_iFittestGenome = 0
        m_dBestFitnessScore = 0
        m_dTotalFitnessScore = 0

        Dim TempMemory As New CBobsMap

        '//update the fitness scores and keep a check on fittest so far
        Dim i As Integer
        For i = 0 To m_iPopSize - 1
            '//decode each genomes chromosome into a vector of directions
            Dim vecDirections As ArrayList = Decode(m_vecGenomes(i).vecBits)
            '//get it's fitness score
            CType(m_vecGenomes(i), SGenome).dFitness = m_BobsMap.TestRoute(vecDirections, TempMemory)

            '//update total
            m_dTotalFitnessScore += CType(m_vecGenomes(i), SGenome).dFitness

            '//if this is the fittest genome found so far, store results
            If (CType(m_vecGenomes(i), SGenome).dFitness > m_dBestFitnessScore) Then
                m_dBestFitnessScore = CType(m_vecGenomes(i), SGenome).dFitness

                m_iFittestGenome = i

                m_BobsBrain = TempMemory
                RaiseEvent Update()
                '//Has Bob found the exit?
                If (CType(m_vecGenomes(i), SGenome).dFitness = 1.0) Then
                    '//is so, stop the run
                    m_bBusy = False
                    Return
                End If
            End If
            TempMemory.ResetMemory()
        Next

    End Sub

    '//---------------------------Decode-------------------------------------
    '//
    '//	decodes a vector of bits into a vector of directions (ints)
    '//
    '//	0=North, 1=South, 2=East, 3=West
    '//-----------------------------------------------------------------------
    '//decodes a vector of bits into a vector of directions (ints)
    Private Function Decode(ByVal bits As ArrayList) As ArrayList
        Dim directions As New ArrayList
        Dim ThisGene As ArrayList

        '//step through the chromosome a gene at a time
        Dim i, j As Integer
        For i = 0 To bits.Count - 3 Step m_iGeneLength
            ThisGene = New ArrayList
            For j = 0 To m_iGeneLength - 1
                ThisGene.Add(bits(i + j))
            Next
            directions.Add(BinToInt(ThisGene))
        Next
        Return directions

    End Function

    '//converts a vector of bits into decimal. Used by Decode.
    Private Function BinToInt(ByVal v As ArrayList) As Integer
        Dim val As Integer = 0
        Dim multiplier As Integer = 1
        Dim i As Integer
        For i = v.Count To 1 Step -1
            val += v(i - 1) * multiplier
            multiplier *= 2
        Next

        Return val
    End Function

    '//creates a start population of random bit strings
    Private Sub CreateStartPopulation()
        '//clear existing population
        m_vecGenomes.Clear()
        Dim i As Integer
        For i = 0 To m_iPopSize - 1
            m_vecGenomes.Add(New SGenome(m_iChromoLength))
        Next

        '//reset all variables
        m_iGeneration = 0
        m_iFittestGenome = 0
        m_dBestFitnessScore = 0
        m_dTotalFitnessScore = 0

    End Sub

    Public Sub New(ByVal cross_rat As Double, ByVal mut_rat As Double, ByVal pop_size As Integer, ByVal num_bits As Integer, ByVal gene_len As Integer)
        m_dCrossoverRate = cross_rat
        m_dMutationRate = mut_rat
        m_iPopSize = pop_size
        m_iChromoLength = num_bits
        m_dTotalFitnessScore = 0.0
        m_iGeneration = 0
        m_iGeneLength = gene_len
        m_bBusy = False
        CreateStartPopulation()
    End Sub

    Public Sub Run()
        '//The first thing we have to do is create a random population
        '//of genomes
        CreateStartPopulation()

        m_bBusy = True
    End Sub

    Public Sub Render(ByVal cxClient As Integer, ByVal cyClient As Integer, ByVal g As Graphics)
        '//render the map
        m_BobsMap.Render(cxClient, cyClient, g)

        '//render the best route
        m_BobsBrain.MemoryRender(cxClient, cyClient, g)

    End Sub

    '//--------------------------------Epoch---------------------------------
    '//
    '//	This is the workhorse of the GA. It first updates the fitness
    '//	scores of the population then creates a new population of
    '//	genomes using the Selection, Croosover and Mutation operators
    '//	we have discussed
    '//----------------------------------------------------------------------
    Public Sub Epoch()
        UpdateFitnessScores()

        '//Now to create a new population
        Dim NewBabies As Integer = 0

        '//create some storage for the baby genomes 
        Dim vecBabyGenomes As New ArrayList
        Dim mum, dad, baby1, baby2 As SGenome

        Do While (NewBabies < m_iPopSize)
            '//select 2 parents
            mum = RouletteWheelSelection()
            dad = RouletteWheelSelection()

            baby1 = New SGenome(dad.vecBits.Count)
            baby2 = New SGenome(dad.vecBits.Count)

            Crossover(mum.vecBits, dad.vecBits, baby1.vecBits, baby2.vecBits)

            '//operator - mutate
            Mutate(baby1.vecBits)
            Mutate(baby2.vecBits)

            '//add to new population
            vecBabyGenomes.Add(baby1)
            vecBabyGenomes.Add(baby2)

            NewBabies += 2
        Loop

        '//copy babies back into starter population
        m_vecGenomes = vecBabyGenomes

        '//increment the generation counter
        m_iGeneration += 1

    End Sub

    '//accessor methods
    Public Function Generation() As Integer
        Return m_iGeneration
    End Function

    Public Function GetFittest() As Integer
        Return m_iFittestGenome
    End Function

    Public Function Started() As Boolean
        Return m_bBusy
    End Function

    Public Sub StopRun()
        m_bBusy = False
    End Sub

    Public Event Update()

End Class