VB5, VB6 Construct a Data Web

Listing 1 You need to model the data appropriately before the GA can get its teeth into the
Traveling Salesperson Problem. This code gets the linking process underway.

Public Sub RandomiseWeb(nodeCount As Long,
linkPercent _
        As Long, WorldHeight As Single, WorldWidth _
        As Single, WorldDepth As Single) 
For Index = 1 To nodeCount
        X = RndNum(0, WorldHeight) - WorldHeight / 2
        Y = RndNum(0, WorldWidth) - WorldWidth / 2
        Z = (RndNum(0, WorldDepth) - WorldDepth / 2) * -1
Addnode X, Y, Z
Next
linkCount = linkPercent * (nodeCount *(nodeCount - 1) _ 
        / 2) / 100
Do Until links.Count = linkCount
        Set NdStart = RndObj(nodes)
        Set NdTarget = RndObj(nodes)
        Addlink NdStart, NdTarget
Loop
End Sub

Public Function linkUp(From As GAwebLib.node, Dest _
        As GAwebLib.node)
Set Nd1 = From
Set Nd2 = Dest
Nd1.links.Add Me
Nd2.links.Add Me
a = Nd2.Y - Nd1.Y
b = Nd2.Z - Nd1.Z
c = Nd2.X - Nd1.X
a = a * a
b = b * b
c = c * c
Length = Format(Sqr(a + Sqr(b + c)), "Fixed")
End Function

VB5, VB6 Keep the System Fluid

Listing 2 Mutation, crossover, and replication enable you to create a dynamic
balance that keeps the system teetering on the edge of chaos. 
Private Sub GA_Mutate()
Set MutRt = RndObj(routes)
Set MutSc = RndObj(MutRt.sections)
Set MiniRt = New route
With MiniRt
        Set .nodeStart = MutSc.node
        Set .nodeTarget = NdTarget
        .Join
End With
If MiniRt.Joined Then
        With MutRt.sections
                Do Until .Item(MutRt.sections.Count) Is MutSc
                    .Remove .Count
                Loop
                For Each Sc In MiniRt.sections
                    .Add Sc
                Next
        End With
        If NotifyOK Then Notify.Updateroute MutRt
        GA_Replicate
End If
End Sub

Private Sub GA_CrossOver()
Do
        Set Rt1 = RndObj(routes)
        Set Rt2 = RndObj(routes)
Loop While Rt1 Is Rt2
For Each Nd1 In Rt1.nodesUsed
        For Each Nd2 In Rt2.nodesUsed
                If Nd1 Is Nd2 Then
                    Swapsections Rt1, Rt2, Nd1
                    If NotifyOK Then
                                Notify.Updateroute Rt1
                                Notify.Updateroute Rt2
                    End If
                    GA_Replicate
                    Exit Sub
                End If
        Next
Next
End Sub

Public Sub Swapsections(Rt1 As route, Rt2 As route, _
        NdShared As GAwebLib.node)
With Rt1.sections
        Do Until .Item(.Count).node Is NdShared
                Scs1.Add .Item(.Count)
                .Remove .Count
        Loop
End With
With Rt2.sections
        Do Until .Item(.Count).node Is NdShared
                Scs2.Add .Item(.Count)
                .Remove .Count
        Loop
End With
With Scs2
        Do Until .Count = 0
                Rt1.sections.Add Scs2(.Count)
                .Remove Count
        Loop
End With
With Scs1
        Do Until .Count = 0
                Rt2.sections.Add Scs1(.Count)
                .Remove .Count
        Loop
End With 
End Sub