frmtabujsp.frm

采用面向负荷控制技术

    '得到设备最后加工的顶点vt
    '生成一条新边
    Edge(EdgeNumber).nextArc = -1
    Edge(EdgeNumber).VertexNo = DeviceCount * PartCount + 1 '最后一个任务指向结束顶点
    Edge(EdgeNumber).weight = ProcessTime(Vertex(vt).PartNo, Vertex(vt).ProcessNo)
    nta = Vertex(vt).FirstArc
    Edge(nta).nextArc = EdgeNumber
    EdgeNumber = EdgeNumber + 1
Next I
'结束顶点的开始时间为最后工件的完工时间；
Call GetLongest(j, pstime)
Vertex(DeviceCount * PartCount + 1).StartTime = pstime
'检查设备任务情况,调试用
txtResult.Text = ""
For I = 0 To DeviceCount - 1
    DisplayTaskInDevice (I)
Next I
'检查工件加工情况，调试用
For I = 0 To PartCount - 1
    DisplayPart (I)
Next I
'ReportResult
End Sub
Sub DisplayPart(I As Integer)
Dim j As Integer, vt As Integer, nta As Integer, we As Double, dn As Integer
'txtdata.Text = txtdata.Text & vbCrLf & "part(" & I & "): "
txtData.Text = "" & "part(" & I & "): "

vt = Part(I).FirstProcess
j = 0
dn = Process(I, j) - 1
we = ProcessTime(I, j)
txtData.Text = txtData.Text & vt & "(" & dn & "," & we & ")"
nta = Vertex(vt).FirstArc
While nta <> -1
    vt = Edge(nta).VertexNo
    j = j + 1
    dn = Process(I, j) - 1
    we = ProcessTime(I, j)
    txtData.Text = txtData.Text & vt & "(" & dn & "," & we & ")"
    nta = Vertex(vt).FirstArc

Wend

End Sub
Sub DisplayTaskInDevice(dn As Integer)
'检查设备任务情况
Dim tt() As Integer, k As Integer, m As Integer, l As Integer
txtResult.Text = txtResult.Text & vbCrLf & "device " & dn & ": "
m = TaskInDevice(dn, tt)
If m = -1 Then
    txtResult.Text = txtResult.Text & "No Task"
Else
    'm = UBound(tt)
    For l = 0 To m - 1
    txtResult.Text = txtResult.Text & " <" & Vertex(tt(l)).PartNo & "," & Vertex(tt(l)).ProcessNo & "  " & Vertex(tt(l)).StartTime & ">"
    Next l
End If
End Sub
Sub InsertTaskInDevice(I As Integer, j As Integer)
'插空式插入任务，即若设备的任务之间有空闲则插入空闲时间，否则只能插入队尾
Dim h As Integer, PrevV As Integer, vt As Integer, CurTask As Integer
Dim dstime As Double, pstime As Double, etime As Double
Dim nta As Integer, TempD As Integer
Dim flag As Boolean, dn As Integer
'获得任务的加工设备号
'????问题：零号顶点的nextarc未生成！！！不能通过顶点0进行任务的遍历！！！
dn = Process(I, j) - 1
h = GetVertexNo(I, j)
CurTask = h
If j = 0 Then
    pstime = 0 '第一道工序,开始时间可以为0,还要看其所在设备的任务情况
Else
    '不是第一道工序，找上道工序的情况
    PrevV = GetPreviousProcess(I, j)
    'PrevV = vt - 1
    '本道工序开始时间最早为上道工序完成时间,即上道工序开始时间+上道工序加工时间
    pstime = Vertex(PrevV).StartTime + Edge(Vertex(PrevV).FirstArc).weight
End If
If Task(dn) = -1 Then
    '设备上尚无任务
    Task(dn) = h   'vt——即（i,j）是第一个任务,不需生成新边
    Vertex(h).StartTime = pstime
Else
    '设备上已有任务，应计算各任务之间的空闲时间，同时生成一条新边，并对设备的单链表进行(排序)插入
    '生成一条新边
    Edge(EdgeNumber).EdgeNo = EdgeNumber
    Edge(EdgeNumber).nextArc = -1
    Edge(EdgeNumber).VertexNo = h
    Edge(EdgeNumber).weight = ProcessTime(I, j)
    vt = h
    h = Task(dn)    '设备的第一个任务,首先与第一个任务比较，判断是否应插入队首，
    If Vertex(h).StartTime >= pstime + Edge(EdgeNumber).weight Then
        '插入队首
        Task(dn) = vt   '新结点成为队首
        Vertex(vt).StartTime = pstime '+ Edge(EdgeNumber).weight
        Edge(EdgeNumber).VertexNo = h   '新生成的边指向原队首结点
        nta = Vertex(vt).FirstArc
        Edge(nta).nextArc = EdgeNumber '新队首的nextarc域指向新边
        'Edge(Vertex(vt).firstarc).nextArc = nta
    Else
        nta = Vertex(h).FirstArc    '不应插入队首，则找下一任务，通过队首的第一条边，通过它找下一条边
        nta = Edge(nta).nextArc     '找到与设备任务相联系的边
        flag = True
        vt = h
        While nta <> -1 And flag = True
            h = Edge(nta).VertexNo  '找下一任务
            If Vertex(h).StartTime < pstime + ProcessTime(I, j) Then
                '本任务的最早开始时间加上加工时间大于设备上当前任务的开始时间，则找下一任务
                '即本任务的完成时间在设备当前任务开始时间之前，则进行下一步判断设备上前一个任务完成时间的条件是否满足
                nta = Vertex(h).FirstArc
                nta = Edge(nta).nextArc
            Else
                '设备上当前任务h开始时间大于本任务curtask可以开始的时间，考虑是否可以插入当前任务之前
                '为此需计算上个任务vt结束时间与当前任务h开始时间之间的空闲时间，若大于本任务时间则可以插入
                '否则不可以
                etime = Vertex(vt).StartTime + ProcessTime(Vertex(vt).PartNo, Vertex(vt).ProcessNo)
                If etime + ProcessTime(I, j) <= Vertex(h).StartTime Then
                    '可以插入当前任务之前,完成设备任务单链表的插入
                    nta = Vertex(vt).FirstArc
                    TempD = Edge(nta).nextArc   '记下原指向边的编号
                    Edge(nta).nextArc = EdgeNumber  '上一任务的nextarc域指向新边
                    nta = Vertex(CurTask).FirstArc
                    Edge(nta).nextArc = TempD    '新边的nextarc域指向原边
                    If etime < pstime Then
                        '置本任务CurTask开始时间为上一任务结束时间与CurTask上道工序完成时间之较大者
                        Vertex(CurTask).StartTime = pstime
                    Else
                        Vertex(CurTask).StartTime = etime
                    End If
                    flag = False '插入完成,退出循环
                Else
                    '不可插入当前任务之前,继续找下一任务
                    nta = Vertex(h).FirstArc
                    nta = Edge(nta).nextArc
                End If
            End If
            vt = h  '记上一任务的顶点编号
        Wend
        If nta = -1 And flag = True Then
            '不能插入设备任务之间，只能插在设备任务的队尾
            'vt是最后一个任务的顶点编号
            nta = Vertex(vt).FirstArc
            Edge(nta).nextArc = EdgeNumber
            '任务的开始时间是上道工序完成时间与上个任务结束时间之较大者
            etime = Vertex(vt).StartTime + ProcessTime(Vertex(vt).PartNo, Vertex(vt).ProcessNo)
            If etime < pstime Then
                '置本任务CurTask开始时间为上一任务结束时间与CurTask上道工序完成时间之较大者
                Vertex(CurTask).StartTime = pstime
            Else
                Vertex(CurTask).StartTime = etime
            End If
        End If
    End If
    EdgeNumber = EdgeNumber + 1
    Dim m As Integer, tt() As Integer, l As Integer
        m = TaskInDevice(dn, tt)
    If m = -1 Then
        Debug.Print "No Task"
    Else
        'm = UBound(tt)
        For l = 0 To m - 1
        Debug.Print tt(l)
        Next l
    End If

End If
End Sub
Function GetVertexNo(I As Integer, j As Integer)
Dim hh As Integer, k As Integer, nta As Integer
k = 0
hh = Part(I).FirstProcess
While k < j
    nta = Vertex(hh).FirstArc
    hh = Edge(nta).VertexNo
    k = k + 1
Wend
GetVertexNo = hh
End Function

Function GetPreviousProcess(I As Integer, j As Integer) As Integer
'获得工件i的第j道工序的上道工序的顶点编号，应从part(i).firstprocess得到其第一道工序的顶点编号，再按firstarc
'遍历图得到所有工序，从而得到其前道工序，本JSP的析取图较特殊，第一道工序的前道工序顶点编号均为0，
'其余均为当前顶点编号减1
Dim hh As Integer, nta As Integer, vt As Integer
hh = Part(I).FirstProcess
'If hh = I * DeviceCount + j + 1 Then    'j 为第一道工序，返回-1
'    GetPreviousProcess = -1
'    Exit Sub
'End If
nta = Vertex(hh).FirstArc
While nta <> -1 And Vertex(hh).ProcessNo <> j
    vt = hh
    hh = Edge(nta).VertexNo
    nta = Vertex(hh).FirstArc
Wend
GetPreviousProcess = vt

End Function
Function GetNextProcess(I As Integer, j As Integer) As Integer
'获得工件i的第j道工序的下道工序的顶点编号，应从part(i).firstprocess得到其第一道工序的顶点编号，再按firstarc
'遍历图得到所有工序，从而得到其下道工序，本JSP的析取图较特殊，最后一道工序的下道工序编号为devicecount*partcount+1，
'第一道工序的前道工序顶点编号均为0，0的下道工序有partcount 个
'其余均为当前顶点编号加1
Dim hh As Integer, nta As Integer
hh = Part(I).FirstProcess
nta = Vertex(hh).FirstArc
While nta <> -1 And Vertex(hh).ProcessNo <> j
    hh = Edge(nta).VertexNo
    nta = Vertex(hh).FirstArc
Wend
hh = Edge(nta).VertexNo
GetNextProcess = hh

End Function

Private Sub Application()
Dim cnt As Integer, j As Integer
Dim fs, wfile, TheBest As String
Dim fname As String, rr As String
Dim I As Integer, ForWriting As Integer

ForWriting = 2
TheBest = "1"   '已知最优值时
Set fs = CreateObject("scripting.filesystemobject")
fname = App.Path & "\mediate.txt"
Set wfile = fs.OpenTextFile(fname, ForWriting, False)
Me.MousePointer = vbHourglass

loopcnt = 0
While (loopcnt < MAXLOOP And TheBest <> "")
'求当前解的所有邻域解
cnt = GetAllNeighbour(Result)
rr = "第" & loopcnt & "代中间结果：所有邻域："
wfile.writeline (rr)

'计算各邻域解的适配值并排序
GetAllNb_ObjFunc (cnt)
'输出中间结果
'For i = 0 To cnt - 1
'    For j = 0 To CityCount - 1
'        rr = valobj(i).neighbour(j) & ","
'    Next j
'    rr = rr & "," & valobj(i).val & "," & vbCrLf
'    wfile.writeline (rr)
'Next i
'求新的当前解
GetCurrent cnt, Result
'rr = "当前解为："
'For i = 0 To CityCount - 1
'    rr = rr & Result(i) & ","
'    If i + 1 Mod 10 = 0 Then
'
'    End If
'Next i
'wfile.writeline (rr)
loopcnt = loopcnt + 1
'ReportResult

Wend
wfile.Close
Me.MousePointer = vbDefault
'ReportFinal
End Sub

Function TopOrder(hh As Integer)
'拓朴排序
Dim stack(100) As Integer, tp As Integer, VCnt As Integer
Dim nextV As Integer, nextA As Integer, h As Integer

Call CaculateInDegree
txtResult.Text = txtResult.Text & vbCrLf
tp = 1: VCnt = 0
stack(tp) = hh
'r_tp=0
While tp > 0
    h = stack(tp)
    txtResult.Text = txtResult.Text & h & "   "
    '此处按拓朴排序顺序压入另一堆栈，以备逆拓朴排序用
    'reversestack=h
    'r_tp=r_tp+1
    tp = tp - 1
    VCnt = VCnt + 1
    nextA = Vertex(h).FirstArc
    While nextA <> -1
        nextV = Edge(nextA).VertexNo
        InDegree(nextV) = InDegree(nextV) - 1
        If (InDegree(nextV) = 0) Then
            tp = tp + 1
            stack(tp) = nextV
            
        End If
        nextA = Edge(nextA).nextArc
    Wend
Wend
If VCnt - 2 <> DeviceCount * PartCount Then
   MsgBox "有环存在！", vbOKOnly + vbCritical
   TopOrder = 1
   Exit Function
End If
TopOrder = 0
End Function

Function TaskInDevice(dn As Integer, tt() As Integer) As Integer
'遍历设备上的所有任务，参数为设备编号
Dim nta As Integer, vt As Integer
Dim h As Integer, k As Integer
On Error GoTo err
h = Task(dn) '设备的第一个任务
If h = -1 Then
    TaskInDevice = -1
    Exit Function
End If

ReDim tt(1)
k = 0
tt(k) = h
k = 1
nta = Vertex(h).FirstArc
nta = Edge(nta).nextArc
'    ReDim Preserve tt(k + 1) '边的信息，调试用
'    tt(k) = nta
'    k = k + 1
While nta <> -1
    ReDim Preserve tt(k + 1)
    vt = Edge(nta).VertexNo
    '访问/输出vt顶点
    
    tt(k) = vt
    k = k + 1
    nta = Vertex(vt).FirstArc
    If nta <> -1 Then
    nta = Edge(nta).nextArc
'        ReDim Preserve tt(k + 1) '边的信息，调试用
'        tt(k) = nta
'        k = k + 1
    End If
Wend
TaskInDevice = k
Exit Function
err:
MsgBox err.Description, vbOKOnly
End Function

Sub CaculateInDegree()
'须遍历整个图,采用广度优先进行遍历
'结点0先进入队列，成为队首元素，
'取出队首元素,遍历队首元素的firstarc及nextarc，过程中涉及到的顶点依次进入队列，
'各边都遍历完后，再取队首元素
Dim head As Integer, nta As Integer, vt As Integer, k As Integer
Dim TraverseQueue(2000) As Integer, QHead As Integer, QTail As Integer
Dim destring As String 'debugging

'QHead 为队首指针,QTail 为队尾
'indegree()中各元素初始化为0
On Error GoTo err
For head = 0 To DeviceCount * PartCount + 1
    InDegree(head) = 0
Next head
head = 0
QHead = 0
'QTail = 0
TraverseQueue(QHead) = head
QTail = 1
'InDegree(head) = 0
While QHead < QTail
    vt = TraverseQueue(QHead)
    QHead = QHead + 1
    nta = Vertex(vt).FirstArc
    If nta <> -1 Then
        vt = Edge(nta).VertexNo
        '该结点是否已加入队列，不要重复加入
        For k = 0 To QTail - 1
            If TraverseQueue(k) = vt Then
                Exit For
            End If
        Next k
        If k > QTail - 1 Then
            TraverseQueue(QTail) = vt
            QTail = QTail + 1
        End If
        InDegree(vt) = InDegree(vt) + 1
        nta = Edge(nta).nextArc
        While (nta <> -1)
            vt = Edge(nta).VertexNo
            '该结点是否已加入队列，不要重复加入
            For k = 0 To QTail - 1
                If TraverseQueue(k) = vt Then
                    Exit For
                End If
            Next k
            If k > QTail - 1 Then
                TraverseQueue(QTail) = vt
                QTail = QTail + 1
            End If
            InDegree(vt) = InDegree(vt) + 1
            nta = Edge(nta).nextArc
        Wend

    End If
    
    'for debuging
    destring = ""
    For head = QHead To QTail - 1
        destring = destring & " " & TraverseQueue(head)
    Next head