📄 form1.frm
字号:
VERSION 5.00
Begin VB.Form Form1
BackColor = &H0080C0FF&
Caption = "Form1"
ClientHeight = 5775
ClientLeft = 60
ClientTop = 345
ClientWidth = 8745
LinkTopic = "Form1"
ScaleHeight = 5775
ScaleWidth = 8745
StartUpPosition = 3 'Windows Default
Begin VB.Data Data1
Caption = "Data1"
Connect = "Access"
DatabaseName = ""
DefaultCursorType= 0 'DefaultCursor
DefaultType = 2 'UseODBC
Exclusive = 0 'False
Height = 285
Left = 3600
Options = 0
ReadOnly = 0 'False
RecordsetType = 1 'Dynaset
RecordSource = ""
Top = 4440
Visible = 0 'False
Width = 1140
End
Begin VB.TextBox Text3
Height = 615
Left = 4680
TabIndex = 6
Top = 360
Width = 1335
End
Begin VB.CommandButton Command1
BackColor = &H00FF80FF&
Caption = "开始计算"
Height = 855
Left = 5400
MaskColor = &H008080FF&
Style = 1 'Graphical
TabIndex = 4
Top = 3720
Width = 1815
End
Begin VB.TextBox Text2
Height = 615
Left = 4680
TabIndex = 3
Top = 2280
Width = 1335
End
Begin VB.TextBox Text1
Height = 615
Left = 4680
TabIndex = 2
Top = 1320
Width = 1335
End
Begin VB.Label Label3
BackColor = &H0080C0FF&
Caption = "请输入叠代的次数"
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 495
Left = 480
TabIndex = 5
Top = 480
Width = 2895
End
Begin VB.Label Label2
BackColor = &H0080C0FF&
Caption = "请输入车载货辆的数量"
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 495
Left = 480
TabIndex = 1
Top = 2400
Width = 3015
End
Begin VB.Label Label1
BackColor = &H0080C0FF&
Caption = "请输入车载货辆的载货量"
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 495
Left = 480
TabIndex = 0
Top = 1440
Width = 2895
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim d(100) As Single '每个客户的需求
Dim Tablist(100) As Integer '禁忌表
Dim TabNum As Integer '禁忌数
Dim C(100, 100) As Single '客户间的距离
Dim dNum As Integer '客户的个数，修改数据库
Dim NC As Integer '叠代的次数
Dim Q As Single '车上的重量
Dim Ca(100) As Single '车上剩下的重量
Dim CaNum As Integer '车数
Dim dLeave(100) As Single '每个客户的剩余需求
Dim Tao(100, 100) As Single
Dim DetaTao As Single
Dim P(100, 100) As Single
Dim ChooseNUM As Integer
Dim Give(100) As Single
Dim Cost(100) As Single
Dim CostBest As Single
Dim j As Integer
Dim DotNum As Integer
Private Sub Command1_Click()
Q = Val(Text1.Text)
CaNum = Val(Text2.Text)
NC = Val(Text3.Text)
For i = 1 To 100
For j = 1 To 100
Tao(i, j) = 1
Next j
Next i
rou = 0.3
Alfa = 2
Beta = 3
Data1.DatabaseName = App.Path + "/db3.mdb" '定义数据库文件读取路径
Data1.RecordSource = "select * from sample" '定义数据库读取语句
Data1.Refresh '刷新数据库Data控件
Data1.Recordset.MoveLast '移动到表尾以计算行数
s = Data1.Recordset.RecordCount '行数
t = Data1.Recordset.Fields.Count '列数
Data1.Recordset.MoveFirst '移动到表头开始读取数据
dNum = s - 1 '客户数
For i = 0 To dNum
For j = i + 1 To dNum
C(i, j) = Data1.Recordset.Fields(j) '读取第i行第j字段数据库内容
C(j, i) = Data1.Recordset.Fields(j)
Next j
Data1.Recordset.MoveNext '数据指针移动到下一行
Next i
Data1.Recordset.MoveFirst '移动到表头开始读取数据
For i = 0 To dNum
d(i) = Data1.Recordset.Fields(t - 1)
Data1.Recordset.MoveNext
Next i
'得到惩罚
For ii = 1 To dNum
Give(ii) = Int(Rnd * 20) + 1
Next ii
Call save1
For i = 1 To NC
TabNum = 0
For m = 1 To 100
Tablist(m) = 0
Cost(m) = 0
Next m
DetaTao = 0
For ii = 1 To dNum
dLeave(ii) = d(ii)
Next ii
For k = 1 To CaNum
Dim ChooseFlag As Boolean
ChooseFlag = False
Ca(k) = Q
DotNum = 0
Dim Pnum As Integer
Pnum = 0
B = 2
For ii = 1 To TabNum
If Tablist(ii) <> 0 Then
DotNum = DotNum + 1
End If
Next ii
If DotNum >= dNum Then
Exit For
End If
Do While ChooseFlag = False
Dim SearchFlag As Boolean
SearchFlag = False
j = Int(Rnd * dNum + 1) '产生一个1-客户数之间的随机数
'检查产生的随机数是否在禁忌区
For ii = 1 To TabNum
If j = Tablist(ii) Then
SearchFlag = True
Exit For
End If
Next ii
ChooseNUM = j
If dLeave(ChooseNUM) <= Ca(k) And SearchFlag = False Then
ChooseFlag = True
dLeave(ChooseNUM) = 0
Ca(k) = Ca(k) - d(ChooseNUM)
TabNum = TabNum + 1
Pnum = Pnum + 1
Tablist(TabNum) = ChooseNUM
End If
Loop
DotNum = 0
For ii = 1 To TabNum
If Tablist(ii) <> 0 Then
DotNum = DotNum + 1
End If
Next ii
Do While ((DotNum < dNum) And (Ca(k) >= 0))
Dim MaxP As Single
Dim MaxPnum As Integer
Sum = 0
For m = 1 To dNum
For n = 1 To dNum
If m <> n Then
P(m, n) = 0
End If
Next n
Next m
Dim Pflag As Boolean
For m = 1 To dNum
Pflag = False
For n = 1 To TabNum
If m = Tablist(n) Then
Pflag = True
Exit For
End If
Next n
If Pflag = False Then
Sum = Sum + (Tao(j, m)) ^ Alfa / (C(j, m) ^ Beta)
End If
Next m
For m = 1 To dNum
Pflag = False
For n = 1 To TabNum
If m = Tablist(n) Then
Pflag = True
Exit For
End If
Next n
If Pflag = False Then
P(j, m) = ((Tao(j, m)) ^ Alfa) / (C(j, m) ^ Beta) / Sum
End If
Next m
MaxP = P(j, 1)
MaxPnum = 1
For m = 2 To dNum
If MaxP < P(j, m) Then
MaxP = P(j, m)
MaxPnum = m
End If
Next m
ChooseNUM = MaxPnum
If dLeave(ChooseNUM) <= Ca(k) Then
dLeave(ChooseNUM) = 0
Ca(k) = Ca(k) - d(ChooseNUM)
TabNum = TabNum + 1
Pnum = Pnum + 1
Tablist(TabNum) = ChooseNUM
j = ChooseNUM
Else
Exit Do
End If
DotNum = 0
For ii = 1 To TabNum
If Tablist(ii) <> 0 Then
DotNum = DotNum + 1
End If
Next ii
Loop
TabNum = TabNum + 1
Tablist(TabNum) = 0
If Pnum < B Then
TabNum = TabNum - 1
For ii = TabNum To 1 Step -1
If Tablist(ii) <> 0 Then
TabNum = TabNum - 1
Tablist(ii) = 0
Else
Exit For
End If
Next ii
If TabNum = 1 Then
TabNum = 0
End If
End If
' Call save2
Next k
'计算代价
k = 0
ii = 0
Do While ii <= TabNum
If Tablist(ii) = 0 And ii < TabNum Then
k = k + 1
Cost(k) = C(Tablist(ii), Tablist(ii + 1)) + Cost(k) - Give(Tablist(ii))
Else
Cost(k) = C(Tablist(ii), Tablist(ii + 1)) + Cost(k) - Give(Tablist(ii))
End If
ii = ii + 1
Loop
For m = 1 To k
For n = 1 To dNum
Cost(m) = Cost(m) + Give(n)
Next n
Next m
'Compute min cost
If Cost(1) <> 0 Then
CostBest = Cost(1)
Else
Exit For
End If
For ii = 2 To k
If CostBest >= Cost(ii) Then
CostBest = Cost(ii)
End If
Next ii
Dim W As Single
W = 100
DetaTao = W / CostBest
'更新Tao
For ii = 0 To TabNum
Tao(Tablist(ii), Tablist(ii + 1)) = (1 - rou) * (Tao(Tablist(ii), Tablist(ii + 1))) + DetaTao
Next ii
Next i
Call save2
End Sub
'显示并存在文本11中
Private Sub save1()
Open App.Path + "/11.txt" For Output As #1
For j = 0 To dNum
For i = j + 1 To dNum
Print #1, C(j, i);
Next i
Print #1,
Next j
Print #1,
For j = 0 To dNum
Print #1, d(j);
Print #1,
Next j
Print #1,
For ii = 1 To dNum
Print #1, Give(ii);
Next ii
Print #1,
Close #1
End Sub
'显示并存在文本22中
Private Sub save2()
Open App.Path + "/22.txt" For Output As #1
For j = 0 To TabNum
Print #1, Tablist(j);
Print #1,
Next j
Print #1,
Print #1, TabNum;
Print #1,
For k = 1 To CaNum
Print #1, Cost(k);
Print #1,
Next k
Close #1
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -