frmmain.frm

遗传算法的实现（转载）

    Else
        Exit Sub
    End If
Exit Sub
End Sub


Public Sub TSPCrossover(ByVal father As GALib.IGenome, ByVal mother As GALib.IGenome, ByVal brother As GALib.IGenome, ByVal sister As GALib.IGenome, var As Variant, result As Long)
    'Greedy crossover for tsp problems
    Dim lSplit As Long, i As Long, j As Long
    Dim aset1 As New AlleleSet
    Dim aset2 As New AlleleSet
    Dim idx As Long
    Dim dis1 As Single, dis2 As Long
    
    
    'create temperary alleleset
    aset1.newEnumerator (24)
    aset2.newEnumerator (24)
    For i = 1 To 24
        aset1(i - 1) = i
        aset2(i - 1) = i
    Next
    brother(0) = father(0)
    sister(0) = mother(0)
    aset1.Remove brother(0)
    aset2.Remove sister(0)
    For i = 1 To 23
        Dim idxPre As Long
        Dim idxNxt1 As Long, idxNxt2 As Long
        idxPre = brother(i - 1)
        idxNxt1 = father(i)
        idxNxt2 = mother(i)
        If aset1.find(idxNxt1) = False And aset1.find(idxNxt2) = False Then 'both cities already exisits in brother
            idx = Rnd * (aset1.Size - 1)
            brother(i) = aset1(idx)
        ElseIf aset1.find(idxNxt1) = True And aset1.find(idxNxt2) = False Then  'since either father(i) or mother(i) already exisits in brother, choose the other one
            brother(i) = idxNxt1
        ElseIf aset1.find(idxNxt1) = False And aset1.find(idxNxt2) = True Then
            brother(i) = idxNxt2
        Else    'choose the shorter one
            dis1 = Sqr((m_pts(idxNxt1).x - m_pts(idxPre).x) ^ 2 + _
                (m_pts(idxNxt1).y - m_pts(idxPre).y) ^ 2)
            dis2 = Sqr((m_pts(idxNxt2).x - m_pts(idxPre).x) ^ 2 + _
                (m_pts(idxNxt2).y - m_pts(idxPre).y) ^ 2)
            If dis1 < dis2 Then
                brother(i) = idxNxt1
            Else
                brother(i) = idxNxt2
            End If
        End If
        aset1.Remove (brother(i))
    
        
        '======same for sister
        idxPre = sister(i - 1)
        idxNxt1 = father(i)
        idxNxt2 = mother(i)
        If aset2.find(idxNxt1) = False And aset2.find(idxNxt2) = False Then 'both cities already exisits in sister
            idx = Rnd * (aset2.Size - 1)
            sister(i) = aset2(idx)
        ElseIf aset2.find(idxNxt1) = True And aset2.find(idxNxt2) = False Then  'since either father(i) or mother(i) already exisits in sister, choose the other one
            sister(i) = idxNxt1
        ElseIf aset2.find(idxNxt1) = False And aset2.find(idxNxt2) = True Then
            sister(i) = idxNxt2
        Else    'choose the shorter one
            dis1 = Sqr((m_pts(idxNxt1).x - m_pts(idxPre).x) ^ 2 + _
                (m_pts(idxNxt1).y - m_pts(idxPre).y) ^ 2)
            dis2 = Sqr((m_pts(idxNxt2).x - m_pts(idxPre).x) ^ 2 + _
                (m_pts(idxNxt2).y - m_pts(idxPre).y) ^ 2)
            If dis1 < dis2 Then
                sister(i) = idxNxt1
            Else
                sister(i) = idxNxt2
            End If
        End If
        aset2.Remove sister(i)
    Next

End Sub
Private Sub g_OnMutate(ByVal genome As GALib.IGenome, ByVal rate As Single, var As Variant, result As Long)
    'custom mutation for TSP problem (Mutation by 2opt)
    If m_lFunID <> cstFUNTSP And m_lFunID <> cstFUNTSP2 Then Exit Sub
    If Rnd > rate Then Exit Sub
    Dim i As Long, j As Long
    Dim idxTmp As Long
    Dim sngMin As Single, sngCur As Single
    sngMin = genome.Evaluate
    For i = 0 To 22
        For j = i + 1 To 23
            idxTmp = genome(i)
            genome(i) = genome(j)
            genome(j) = idxTmp
            sngCur = genome.Evaluate
            If sngCur < sngMin Then
                sngMin = sngCur
            Else
                idxTmp = genome(i)
                genome(i) = genome(j)
                genome(j) = idxTmp
            End If
        Next
    Next
End Sub

Private Sub g_OnTermination(ByVal population As GALib.IPopulation, var As Variant, _
    bEnd As Boolean)
    'custom terminator
    If m_bStop = True Then
        bEnd = True
        Exit Sub
    End If
End Sub
Private Sub menuAbout_Click()

    frmAbout.Show vbModal, Me
Exit Sub


End Sub
Private Sub menuBin_Click()
    menuReal.Checked = False
    menuBin.Checked = True
    Dim i As Long
    For i = 0 To menuFuns.Count - 1
        If menuFuns(i).Checked = True Then
            menuFuns_Click (i)
        End If
    Next
End Sub
Private Sub menuCon_Click()
    'evolve for a number of generations
    Dim i As Long, n As Long
    n = 50
    m_bStop = False
    For i = 1 To n
        If g.generation >= g.maxgeneration Then Exit For
        g.Step
    Next
    Printresult
End Sub
Private Sub menuEvolve2_Click()
    m_bStop = False
    g.evolve (Rnd * 10)
    Printresult
End Sub

Private Sub menuExit_Click()
    Unload Me
    End
End Sub

Private Sub menuFuns_Click(Index As Integer)
    Dim i As Long
    For i = 0 To menuFuns.Count - 1
        If Index <> i Then
            menuFuns(i).Checked = False
        Else
            menuFuns(i).Checked = True
            m_lFunID = i
        End If
    Next
    InitPop Index
    txt = menuFuns(Index).Caption + vbCrLf + txt
End Sub
Private Sub menuGraphic_Click()
    If menuGraphic.Checked = False Then
        menuGraphic.Checked = True
        txt.Visible = False
        p.Visible = True
        p.ZOrder
    Else
        p.Visible = False
        txt.Visible = True
        txt.ZOrder
        menuGraphic.Checked = False
    End If
End Sub
Private Sub menuReal_Click()
    menuReal.Checked = True
    menuBin.Checked = False
    Dim i As Long
    For i = 0 To menuFuns.Count - 1
        If menuFuns(i).Checked = True Then
            menuFuns_Click (i)
        End If
    Next
End Sub
Private Sub menuReset_Click()
    'initialize the population
    m_bStop = False
    g.Initialize (Rnd * 10)
    Printresult
End Sub

Private Sub menuStep_Click()
    'evolve for one generation
    m_bStop = False
    If g.generation >= g.maxgeneration Then Exit Sub
    g.Step
    Printresult
Exit Sub
End Sub
Private Sub menuStop_Click()
    m_bStop = True
End Sub

Private Sub g_OnEvaluateFitnessFunction(ByVal genome As GALib.IGenome, var As Variant, result As Single)
    'get fitness value
    DoEvents
    If m_lFunID = cstFUNRAS Then
        result = objRas(genome)
    ElseIf m_lFunID = cstFUNACKLEY Then
        result = objAckley(genome)
    ElseIf m_lFunID = cstFUNSPHERE Then
        result = objSphere(genome)
    ElseIf m_lFunID = cstFUNTSP Or m_lFunID = cstFUNTSP2 Then
        result = objTSP(genome)
    ElseIf m_lFunID = cstKNAPSACK Then
        result = objKnapSack(genome)
    ElseIf m_lFunID = cstBIN Then
        result = objBin(genome)
    ElseIf m_lFunID = cstSTEINER Or m_lFunID = cstSTEINER2 Then
        result = objSteiner(genome)
    End If
End Sub
Public Function objSteiner(ByVal genome As GALib.IGenome) As Single
    Dim x As Single, y As Single
    Dim dis As Single
    Dim i As Long
    
    x = genome(0)
    y = genome(1)
    dis = 0
    For i = 1 To 24
        If m_lFunID = cstSTEINER Then
            dis = dis + Sqr((x - m_pts(i).x) ^ 2 + (y - m_pts(i).y) ^ 2)
        Else
            dis = dis + i * Sqr((x - m_pts(i).x) ^ 2 + (y - m_pts(i).y) ^ 2)
        End If
    Next
    objSteiner = dis
End Function
Public Function objBin(ByVal genome As GALib.IGenome) As Single
    Dim n As Long
    Dim i As Long
    Dim idx As Long
    Dim SumWeight As Single
    Dim SumWaste As Single
    SumWaste = 0
    SumWeight = 0
    n = 1
    For i = 0 To 59
        idx = genome(i)
        If SumWeight + m_w(idx) > 100 Then
            n = n + 1
            SumWaste = SumWaste + 100 - SumWeight
            SumWeight = m_w(idx)
        Else
            SumWeight = SumWeight + m_w(idx)
        End If
    Next
    objBin = 10000 * n + SumWaste
End Function

Public Function objKnapSack(ByVal genome As GALib.IGenome) As Single
    Dim x As Long, i As Long
    Dim sumP As Single, sumC As Single
    sumP = 0
    sumC = 0
    For i = 1 To 50
        x = genome(i - 1)
        sumP = sumP + x * m_knap(i).p
        sumC = sumC + x * m_knap(i).w
    Next
    If sumC > 625 Then sumP = 0 'penalty
    objKnapSack = sumP

End Function

Public Function objTSP(ByVal genome As GALib.IGenome) As Single
    Dim x1 As Single, y1 As Single, x2 As Single, y2 As Single
    Dim idx As Long
    Dim i As Long, j As Long, k As Long
    Dim sngObj As Single
    sngObj = 0
    idx = genome(0)
    x1 = m_pts(idx).x
    y1 = m_pts(idx).y
    For i = 2 To 24
        idx = genome(i - 1)
        x2 = m_pts(idx).x
        y2 = m_pts(idx).y
        sngObj = sngObj + Sqr((x1 - x2) ^ 2 + (y1 - y2) ^ 2)
        x1 = x2: y1 = y2
    Next
    objTSP = sngObj
    
    
End Function

Public Function objSphere(ByVal genome As GALib.IGenome) As Single
    Dim x(10) As Single
    Dim i As Long, idx As Long, lInc As Long
    If genome.Type = GA_REALGENOME Then 'decoding read genome
        For i = 1 To 10
            x(i) = genome(i - 1)
        Next
    Else
        idx = 0
        For i = 1 To m_allelesetarr(0).Size / 10
            lInc = genome.getbitslong(idx, idx + 9)
            x(i) = -5.12 + 0.01 * lInc
            idx = idx + 10
        Next
    End If
    'get fitness value
    Dim sngObj As Single
    sngObj = 0
    For i = 1 To 10
        Dim xx
        xx = x(i)
        sngObj = sngObj + (xx - 5 + i) ^ 2
    Next
    objSphere = sngObj
End Function
Public Function objAckley(ByVal genome As GALib.IGenome) As Single
    Dim x(10) As Single
    Dim i As Long, idx As Long, lInc As Long
    If genome.Type = GA_REALGENOME Then  'decoding read genome
        For i = 1 To 10
            x(i) = genome(i - 1)
        Next
    Else
        idx = 0
        For i = 1 To m_allelesetarr(0).Size / 10
            lInc = genome.getbitslong(idx, idx + 9)
            x(i) = -5.12 + 0.01 * lInc
            idx = idx + 10
        Next
    End If
    'get fitness value
    Dim sngObj As Single
    Dim Sum1 As Single, Sum2 As Single
    sngObj = 20 + 2.718281828
    Sum1 = 0: Sum2 = 0
    For i = 1 To 10
        Dim xx
        xx = x(i)
        Sum1 = Sum1 + xx * xx
        Sum2 = Sum2 + cos(2 * 3.14159265 * xx)
    Next
    sngObj = sngObj - 20 * Exp(-0.2 * (Sqr((1 / 10) * Sum1))) - Exp((1 / 10) * Sum2)

    objAckley = sngObj

End Function
Public Function objRas(ByVal genome As GALib.IGenome) As Single
    Dim x(10) As Single
    Dim i As Long, idx As Long, lInc As Long
    If genome.Type = GA_REALGENOME Then 'decoding read genome
        For i = 1 To 10
            x(i) = genome(i - 1)
        Next
    Else
        idx = 0
        For i = 1 To m_allelesetarr(0).Size / 10
            lInc = genome.getbitslong(idx, idx + 9)
            x(i) = -5.12 + 0.01 * lInc
            idx = idx + 10
        Next
    End If
    'get fitness value
    Dim sngObj As Single
    sngObj = 10 * 10
    For i = 1 To 10
        Dim xx
        xx = x(i)
        sngObj = sngObj + xx * xx - 10 * cos(2 * 3.14159265 * xx)
    Next
    objRas = sngObj
End Function

Private Sub p_Paint()
    'graphic representation of solutions for TSP problems
    Dim genome As genome
    Dim sngScale As Single
    
    p.Cls
    If g.population.Size <= 0 Then Exit Sub
    If p.ScaleHeight < p.ScaleWidth Then
        sngScale = p.ScaleHeight / 200
    Else
        sngScale = p.ScaleWidth / 200
    End If
    
    Dim x0 As Single, y0 As Single
    x0 = p.ScaleWidth / 2
    y0 = p.ScaleHeight / 2
    
    Dim x1 As Single, y1 As Single, x2 As Single, y2 As Single
    Dim x3 As Single, y3 As Single, x4 As Single, y4 As Single
    
    Set genome = g.population.best(0)
    
    If m_lFunID = cstFUNTSP Or m_lFunID = cstFUNTSP2 Then
        Dim idx As Long
        Dim i As Long
        idx = genome(0)
        x1 = m_pts(idx).x
        y1 = m_pts(idx).y
        For i = 2 To 24
            idx = genome(i - 1)
            x2 = m_pts(idx).x
            y2 = m_pts(idx).y
            x3 = x0 + x1 * sngScale
            y3 = y0 - y1 * sngScale
            x4 = x0 + x2 * sngScale
            y4 = y0 - y2 * sngScale
            p.Line (x3, y3)-(x4, y4)
            x1 = x2:  y1 = y2
        Next
    ElseIf m_lFunID = cstSTEINER Or m_lFunID = cstSTEINER2 Then
        Dim lR As Long
        lR = 100 * sngScale
        x1 = genome(0): y1 = genome(1)
        x3 = x0 + x1 * sngScale
        y3 = y0 - y1 * sngScale
        
        p.Circle (x0, y0), lR
        For i = 1 To 24
            x2 = m_pts(i).x