frmtabujsp.frm

采用面向负荷控制技术

For I = 0 To TblLength
    If TabuList(I).tblist(0) = tob(0) And TabuList(I).tblist(1) = tob(1) Then
        TabuList(I).tbcnt = TblLength
        flag = False
    Else
        If TabuList(I).tbcnt > 0 Then
            TabuList(I).tbcnt = TabuList(I).tbcnt - 1
            If TabuList(I).tbcnt = 0 Then
                TabuList(I).tblist(0) = -1
                TabuList(I).tblist(1) = -1
            End If
        End If
    End If
Next I
If flag Then
    For I = 0 To TblLength
        If TabuList(I).tbcnt = 0 Then
            TabuList(I).tblist(0) = tob(0)
            TabuList(I).tblist(1) = tob(1)
            TabuList(I).tbcnt = TblLength
            I = TblLength
        End If
        
    Next I
End If
End Function

Function GetCurrent(cnt As Integer, ByRef curr() As Integer)
Dim I As Integer, flag As Boolean, j As Integer
I = 0
If SetBestSoFar(valobj(I)) = 1 Then '是bestsofar值
    For j = 0 To CityCount - 1
        curr(j) = valobj(I).neighbour(j)
    Next j
    SetTabuList valobj(I).exchg
    Exit Function
End If

flag = True
While (flag And I < cnt)
    If InTblist(valobj(I).exchg) = 0 Then '未在禁忌表中
        For j = 0 To CityCount - 1
            curr(j) = valobj(I).neighbour(j)
        Next j
        flag = False
    Else
        I = I + 1
    End If
Wend
If flag Then
    MsgBox "未找到当前可行解", vbOKOnly
Else
    SetTabuList valobj(I).exchg
End If
End Function

Sub SortValObj(cnt As Integer)
'起泡法升序排序
Dim I As Integer, j As Integer, tt As ValobjType, k As Integer
For I = 0 To cnt - 2
For j = 0 To cnt - 2 - I
    If valobj(j).Val > valobj(j + 1).Val Then
        tt = valobj(j)
        valobj(j) = valobj(j + 1)
        valobj(j + 1) = tt
       'tt.exchg = ValObj(j).exchg
       'tt.neighbour = ValObj(j).neighbour
       'tt.val = ValObj(j).val
    End If
Next j
txtResult.Text = ""
'For k = 0 To cnt - 1
'    txtresult.Text = txtresult.Text & vbCrLf & valobj(k).val
'Next k
'k = 0
Next I
End Sub

Function InTblist(tob() As Integer)
Dim I As Integer

For I = 0 To TblLength
    If (tob(0) = TabuList(I).tblist(0) And tob(1) = TabuList(I).tblist(1)) _
        Or (tob(0) = TabuList(I).tblist(1) And tob(1) = TabuList(I).tblist(0)) Then
        InTblist = 1
        Exit Function
    End If
Next I
InTblist = 0
End Function
Sub ReportFinal()
Dim I As Integer
txtResult.Text = "解："
For I = 0 To CityCount - 1
    txtResult.Text = txtResult.Text & BestSoFar.neighbour(I) & ","
Next I
txtResult.Text = txtResult.Text
txtResult.Text = txtResult.Text & vbCrLf & "目标函数值：" & BestSoFar.Val & vbCrLf
txtResult.Text = txtResult.Text & "第 " & BestLoop & " 代得到."

End Sub
Sub GenerateInputMatrix()
Dim fs, txtfile, StrLine, str0
Dim ForReading As Integer, I As Integer, j As Integer
Dim commend1 As String, commend2 As String

ForReading = 1
On Error GoTo err00
CommonDialog1.CancelError = True
CommonDialog1.DialogTitle = "查找输入文件"
CommonDialog1.Filter = "Text Files" & "(*.txt)|*.txt|All Files (*.*)|*.*"
CommonDialog1.ShowOpen
Set fs = CreateObject("scripting.filesystemobject")
Set txtfile = fs.OpenTextFile(CommonDialog1.FileName, ForReading, False)
Me.MousePointer = vbHourglass 'vbDefault
Dim DeviceNumber As Integer, PartNumber As Integer
Dim LineNum As Integer, gx As Integer

'第一行为机器数目，工件数目
StrLine = txtfile.readline
If InStr(1, StrLine, ",") = 0 Then
    MsgBox "input parameter error", vbOKOnly
    Me.MousePointer = vbDefault
Exit Sub
End If
str0 = Split(StrLine, ",")
DeviceCount = str0(0)
PartCount = str0(1)
'略过注释行
commend1 = txtfile.readline
PartNumber = 0
DeviceNumber = 0
'读工艺约束阵
Do While PartNumber < PartCount
   StrLine = txtfile.readline
   If InStr(1, StrLine, ",") = 0 Then
        MsgBox "input error:Line  " & PartNumber, vbOKOnly + vbCritical
        Me.MousePointer = vbDefault
    Exit Sub
   End If
   str0 = Split(StrLine, ",")
   gx = 0
   For I = 0 To UBound(str0)
        Process(PartNumber, gx) = str0(I)
        gx = gx + 1
   Next I
   PartNumber = PartNumber + 1
Loop
PartNumber = 0
DeviceNumber = 0
'读加工时间阵,略过注释行
commend2 = txtfile.readline
'开始读
Do While Not txtfile.AtEndOfStream
   StrLine = txtfile.readline
   If InStr(1, StrLine, ",") = 0 Then
        MsgBox "input error:Line  " & PartNumber, vbOKOnly + vbCritical
        Me.MousePointer = vbDefault
    Exit Sub
   End If
   str0 = Split(StrLine, ",")
   gx = 0
   For I = 0 To UBound(str0)
        ProcessTime(PartNumber, gx) = str0(I)
        gx = gx + 1
   Next I
   PartNumber = PartNumber + 1
Loop
txtfile.Close
Me.MousePointer = vbDefault
'测试是否正确读入输入数组

txtData.Text = commend1 & vbCrLf
For I = 0 To PartCount - 1
For j = 0 To DeviceCount - 1
    txtData.Text = txtData.Text & Process(I, j) & ","
Next j
    txtData.Text = txtData.Text & vbCrLf
Next I
txtData.Text = txtData.Text & commend2 & vbCrLf
For I = 0 To PartCount - 1
For j = 0 To DeviceCount - 1
    txtData.Text = txtData.Text & ProcessTime(I, j) & ","
Next j
    txtData.Text = txtData.Text & vbCrLf
Next I

cmdStart.Enabled = True
'初始人设备任务队列
For I = 0 To DeviceCount - 1
    Task(I) = -1
Next I
Exit Sub
err00:
MsgBox err.Description, vbOKOnly
End Sub
Sub GenerateInputMatrix00()
Dim fs, txtfile, StrLine, str0
Dim ForReading As Integer, I As Integer, j As Integer
Dim commend1 As String, commend2 As String

ForReading = 1
On Error GoTo err00
'CommonDialog1.CancelError = True
'CommonDialog1.DialogTitle = "查找输入文件"
'CommonDialog1.Filter = "Text Files" & "(*.txt)|*.txt|All Files (*.*)|*.*"
'CommonDialog1.ShowOpen
Set fs = CreateObject("scripting.filesystemobject")
Set txtfile = fs.OpenTextFile("MT10^10.txt", ForReading, False)
Me.MousePointer = vbHourglass 'vbDefault
Dim DeviceNumber As Integer, PartNumber As Integer
Dim LineNum As Integer, gx As Integer

'第一行为机器数目，工件数目
StrLine = txtfile.readline
If InStr(1, StrLine, ",") = 0 Then
    MsgBox "input parameter error", vbOKOnly
    Me.MousePointer = vbDefault
Exit Sub
End If
str0 = Split(StrLine, ",")
DeviceCount = str0(0)
PartCount = str0(1)
'略过注释行
commend1 = txtfile.readline
PartNumber = 0
DeviceNumber = 0
'读工艺约束阵
Do While PartNumber < PartCount
   StrLine = txtfile.readline
   If InStr(1, StrLine, ",") = 0 Then
        MsgBox "input error:Line  " & PartNumber, vbOKOnly + vbCritical
        Me.MousePointer = vbDefault
    Exit Sub
   End If
   str0 = Split(StrLine, ",")
   gx = 0
   For I = 0 To UBound(str0)
        Process(PartNumber, gx) = str0(I)
        gx = gx + 1
   Next I
   PartNumber = PartNumber + 1
Loop
PartNumber = 0
DeviceNumber = 0
'读加工时间阵,略过注释行
commend2 = txtfile.readline
'开始读
Do While Not txtfile.AtEndOfStream
   StrLine = txtfile.readline
   If InStr(1, StrLine, ",") = 0 Then
        MsgBox "input error:Line  " & PartNumber, vbOKOnly + vbCritical
        Me.MousePointer = vbDefault
    Exit Sub
   End If
   str0 = Split(StrLine, ",")
   gx = 0
   For I = 0 To UBound(str0)
        ProcessTime(PartNumber, gx) = str0(I)
        gx = gx + 1
   Next I
   PartNumber = PartNumber + 1
Loop
txtfile.Close
Me.MousePointer = vbDefault
'测试是否正确读入输入数组

txtData.Text = commend1 & vbCrLf
For I = 0 To PartCount - 1
For j = 0 To DeviceCount - 1
    txtData.Text = txtData.Text & Process(I, j) & ","
Next j
    txtData.Text = txtData.Text & vbCrLf
Next I
txtData.Text = txtData.Text & commend2 & vbCrLf
For I = 0 To PartCount - 1
For j = 0 To DeviceCount - 1
    txtData.Text = txtData.Text & ProcessTime(I, j) & ","
Next j
    txtData.Text = txtData.Text & vbCrLf
Next I

cmdStart.Enabled = True
'初始人设备任务队列
For I = 0 To DeviceCount - 1
    Task(I) = -1
Next I
Exit Sub
err00:
MsgBox err.Description, vbOKOnly
End Sub

Sub GenerateGraph()
Dim head As Integer

'先生成顶点，加入工艺约束的边
Call GenerateProcess
'下一步应初始化一个解，即生成设备上的任务序列
Call GenerateTask
Call CaculateInDegree
head = 0
If TopOrder(head) <> 0 Then
    MsgBox "有环存在！！！", vbOKOnly + vbCritical
End If
End Sub

Sub GenerateProcess()
'将工艺约束加入图中
Dim I As Integer, j As Integer, PrevVertex As Integer, nextA As Integer
Dim head As Integer, tail As Integer, PrevA As Integer

VertexNumber = 1
EdgeNumber = 0
PrevVertex = 0
head = 0: tail = DeviceCount * PartCount + 1
Vertex(head).PartNo = 0: Vertex(head).ProcessNo = 0
Vertex(head).FirstArc = -1
Vertex(tail).PartNo = 0: Vertex(tail).ProcessNo = 0
Vertex(tail).FirstArc = -1
For I = 0 To PartCount - 1
    For j = 0 To DeviceCount - 1
        '生成新顶点
        Vertex(VertexNumber).PartNo = I
        Vertex(VertexNumber).ProcessNo = j
        Vertex(VertexNumber).FirstArc = -1
        If j = 0 Then
            InDegree(VertexNumber) = 1
        Else
            InDegree(VertexNumber) = 2
        End If
        OutDegree(VertexNumber) = 2
        '生成新边
        Edge(EdgeNumber).VertexNo = VertexNumber
        Edge(EdgeNumber).nextArc = -1
        'j=0,各工件的第一道工序
        If j = 0 Then
            Part(I).FirstProcess = VertexNumber
            Edge(EdgeNumber).weight = 0
            nextA = Vertex(head).FirstArc
            OutDegree(0) = OutDegree(0) + 1
            If nextA = -1 Then
                Vertex(head).FirstArc = EdgeNumber
            Else
                While nextA <> -1
                    PrevA = nextA
                    nextA = Edge(PrevA).nextArc
                Wend
                Edge(PrevA).nextArc = EdgeNumber
            End If
            
        Else
            'j<>0,非第一道工序
            'If j <> DeviceCount - 1 Then
                Vertex(PrevVertex).FirstArc = EdgeNumber
                Edge(EdgeNumber).weight = ProcessTime(I, j - 1)
            'Else
            '    Vertex(PrevVertex).firstarc = tail
            'End If
            
            
        End If
        PrevVertex = VertexNumber
        VertexNumber = VertexNumber + 1
        EdgeNumber = EdgeNumber + 1
    Next j
    Vertex(PrevVertex).FirstArc = EdgeNumber
    Edge(EdgeNumber).VertexNo = tail
    Edge(EdgeNumber).weight = ProcessTime(I, j - 1)
    Edge(EdgeNumber).nextArc = -1
    EdgeNumber = EdgeNumber + 1
    InDegree(tail) = InDegree(tail) + 1
Next I
'OK,至此处图的建立成功，所有工序进入图中
'For i = 0 To 37
'    Dim ed As Integer
'    ed = Vertex(i).firstarc
'    Debug.Print ed
'    Debug.Print Edge(ed).VertexNo
'    nextA = Edge(ed).nextArc
'    While nextA <> -1
'        Debug.Print Edge(nextA).VertexNo
'        nextA = Edge(nextA).nextArc
'    Wend
'Next i
End Sub

Sub GenerateTask()
Dim I As Integer, j As Integer, h As Integer, vt As Integer, nta As Integer
Dim pstime As Double
For I = 0 To PartCount - 1
    For j = 0 To DeviceCount - 1
        Call InsertTaskInDevice(I, j)
    Next j
Next I
'以下加结束边语句应放入函数InsertTaskInDevice中???
'对各设备加一条结束边，表示最后一个任务的加工，其终点指向最后一个顶点
For I = 0 To DeviceCount - 1
    h = Task(I) '设备的第一个任务
    nta = Vertex(h).FirstArc
    nta = Edge(nta).nextArc
    While nta <> -1
        vt = Edge(nta).VertexNo
        nta = Vertex(vt).FirstArc
        nta = Edge(nta).nextArc
        
    Wend