tsp.txt

遗传算法解决TSP问题,在vb开发环境中

Private Sub Command1_Click()
Dim code(200, 8) As Integer '编码,种群数为200
Dim code1(200, 8) As Integer
Dim uncode(200, 8) As Integer '解码
Dim lj(200, 8) As Integer '路径
Dim d(200) As Single '每条路径的距离
Dim f(200) As Single '适应度函数值
Dim fm(200) As Single '选择概率
Dim char(8, 2) As Integer
Dim char1(8) As Integer
Dim xy(8, 2) As Integer '点的坐标值(8个点)
Show
Text1 = ""
Randomize
'给xy坐标数组赋值
xy(1, 1) = 2
xy(1, 2) = 3
xy(2, 1) = 4
xy(2, 2) = 4
xy(3, 1) = 2
xy(3, 2) = 7
xy(4, 1) = 6
xy(4, 2) = 6
xy(5, 1) = 8
xy(5, 2) = 7
xy(6, 1) = 9
xy(6, 2) = 4
xy(7, 1) = 9
xy(7, 2) = 2
xy(8, 1) = 6
xy(8, 2) = 2
For i = 1 To 8
char(i, 1) = i
char(i, 2) = 0
Next i
For i = 1 To 200
For m = 1 To 8
char1(m) = char(m, 1)
Next m
k = 1
For j = 8 To 1 Step -1
x = Int(Rnd * j) + 1
lj(i, k) = char1(x)
For m = x To 7
char1(m) = char1(m + 1)
Next m
k = k + 1
Next j
Next i

'编码
For i = 1 To 200
For j = 1 To 8
a = lj(i, j)
k = 1
For m = 1 To 8
If a <> char(m, 1) Then
If char(m, 2) = 0 Then
k = k + 1
End If
Else
code(i, j) = k
char(m, 2) = 1
Exit For
End If
Next m
Next j
For m = 1 To 8
char(m, 2) = 0
Next m
Next i

'叠代次数设为400
For dai = 1 To 400
'解码
For i = 1 To 200
For j = 1 To 8
char1(j) = char(j, 1)
Next j
For j = 1 To 8
a = code(i, j)
uncode(i, j) = char1(a)
If a < 8 Then
For m = a To 7
char1(m) = char1(m + 1)
Next m
End If
Next j
Next i

'计算路径的距离之和以及适应度.选择概率
fcount = 0
For i = 1 To 200
d(i) = 0
For j = 1 To 7
' Text1.Text = Text1.Text & uncode(i, j) & "," & xy(uncode(i, j), 1) & vbCrLf
X1 = xy(uncode(i, j), 1) - xy(uncode(i, j + 1), 1)
Y1 = xy(uncode(i, j), 2) - xy(uncode(i, j + 1), 2)
d(i) = d(i) + Sqr(X1 * X1 + Y1 * Y1)
Next j
X1 = xy(uncode(i, 1), 1) - xy(uncode(i, 7), 1)
Y1 = xy(uncode(i, 1), 2) - xy(uncode(i, 7), 2)
d(i) = d(i) + Sqr(X1 * X1 + Y1 * Y1)
'Text1.Text = Text1.Text & d(i) & vbCrLf
f(i) = 1 / d(i)
fcount = fcount + f(i)
Next i
For i = 1 To 200
fm(i) = f(i) / fcount
Next i

'选择交叉
For i = 1 To 200
For j = 1 To 8
code1(i, j) = code(i, j)
Next j
Next i
For i = 1 To 100
rand1 = Rnd
fb = 0
For j = 1 To 200
fe = fb + fm(j)
If rand1 >= fb And rand1 < fe Then
n1 = j '在200个个体中,选择个体n1
Exit For
Else
fb = fe
End If
Next j
rand2 = Rnd
fb = 0
For j = 1 To 200
fe = fb + fm(j)
If rand2 >= fb And rand2 < fe Then
n2 = j '在200个个体中,选择个体n2
Exit For
Else
fb = fe
End If
Next j
rand3 = Int(Rnd * 7) + 1 '产生交叉位置rand3(1-7)
For m = 1 To rand3 '前面rand3 位不变
code(1 + (i - 1) * 2, m) = code1(n2, m)
code(i * 2, m) = code1(n1, m)
Next m
For m = rand3 + 1 To 8 '交换染色体后面的位
code(1 + (i - 1) * 2, m) = code1(n1, m)
code(i * 2, m) = code1(n2, m)
Next m
Next i
Next dai
'解码
For i = 1 To 200
For j = 1 To 8
char1(j) = char(j, 1)
Next j
For j = 1 To 8
a = code(i, j)
uncode(i, j) = char1(a)
If a < 8 Then
For m = a To 7
char1(m) = char1(m + 1)
Next m
End If
Next j
Next i

'求所有路径的距离d()
fcount = 0
For i = 1 To 200
d(i) = 0
For j = 1 To 7
X1 = xy(uncode(i, j), 1) - xy(uncode(i, j + 1), 1)
Y1 = xy(uncode(i, j), 2) - xy(uncode(i, j + 1), 2)
d(i) = d(i) + Sqr(X1 * X1 + Y1 * Y1)
Next j
X1 = xy(uncode(i, 1), 1) - xy(uncode(i, 7), 1)
Y1 = xy(uncode(i, 1), 2) - xy(uncode(i, 7), 2)
d(i) = d(i) + Sqr(X1 * X1 + Y1 * Y1)
Next i

'求所有路径距离中的最小值
Min = 20000000
For i = 1 To 200
If Min > d(i) Then
Min = d(i)
imin = i
End If
Next i
Text1 = ""

'在文本框中显示路径距离
For i = 1 To 200
Text1 = Text1 & d(i) & vbCrLf
Next i

'显示最短路径的编码
For j = 1 To 8
Text1 = Text1 & code(imin, j) & " "
Next j
Text1 = Text1 & vbCrLf

'显示最短路径的解码
For j = 1 To 8
Text1 = Text1 & uncode(imin, j) & " "
Next j
Text1 = Text1 & vbCrLf
Text1 = Text1 & d(imin) & vbCrLf '显示最短路径的距离
End Sub