frmtabujsp.frm

采用面向负荷控制技术

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form frmTabuJSP 
   Caption         =   "车间调度禁忌搜索"
   ClientHeight    =   7785
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   11880
   LinkTopic       =   "Form1"
   ScaleHeight     =   7785
   ScaleWidth      =   11880
   StartUpPosition =   3  '窗口缺省
   Begin VB.Frame Frame4 
      Caption         =   "GANTT图"
      Height          =   4095
      Left            =   0
      TabIndex        =   7
      Top             =   3600
      Width           =   11655
      Begin VB.PictureBox PicGantt 
         AutoRedraw      =   -1  'True
         Height          =   3135
         Left            =   840
         ScaleHeight     =   3075
         ScaleWidth      =   10635
         TabIndex        =   8
         Top             =   600
         Width           =   10695
      End
      Begin VB.Label lblScale 
         AutoSize        =   -1  'True
         Caption         =   "0"
         BeginProperty Font 
            Name            =   "宋体"
            Size            =   7.5
            Charset         =   134
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   150
         Index           =   0
         Left            =   240
         TabIndex        =   11
         Top             =   3720
         Width           =   75
      End
      Begin VB.Label lblDev 
         AutoSize        =   -1  'True
         Caption         =   "设备0"
         Height          =   180
         Index           =   0
         Left            =   240
         TabIndex        =   10
         Top             =   600
         Width           =   450
      End
      Begin VB.Label lblColor 
         AutoSize        =   -1  'True
         Caption         =   "零件0："
         ForeColor       =   &H80000007&
         Height          =   180
         Index           =   0
         Left            =   840
         TabIndex        =   9
         Top             =   240
         Width           =   630
      End
   End
   Begin MSComDlg.CommonDialog CommonDialog1 
      Left            =   240
      Top             =   480
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.CommandButton Command1 
      Caption         =   "Command1"
      Height          =   375
      Left            =   5640
      TabIndex        =   6
      Top             =   2640
      Width           =   855
   End
   Begin VB.CommandButton cmdStart 
      Caption         =   "开始"
      Height          =   495
      Left            =   5520
      TabIndex        =   5
      Top             =   1080
      Width           =   1095
   End
   Begin VB.Frame Frame3 
      Caption         =   "最优排序阵"
      Height          =   3375
      Left            =   6840
      TabIndex        =   2
      Top             =   120
      Width           =   4815
      Begin VB.TextBox txtResult 
         Height          =   3015
         Left            =   120
         MultiLine       =   -1  'True
         ScrollBars      =   3  'Both
         TabIndex        =   12
         Top             =   240
         Width           =   4575
      End
   End
   Begin VB.CommandButton cmdRelay 
      Caption         =   "读中间结果"
      Enabled         =   0   'False
      Height          =   495
      Left            =   5520
      TabIndex        =   1
      Top             =   1800
      Width           =   1095
   End
   Begin VB.CommandButton cmdInput 
      Caption         =   "读输入文件"
      Height          =   495
      Left            =   5520
      TabIndex        =   0
      Top             =   240
      Width           =   1095
   End
   Begin VB.Frame Frame1 
      Caption         =   "输入数据"
      Height          =   3255
      Left            =   120
      TabIndex        =   3
      Top             =   120
      Width           =   4935
      Begin VB.TextBox txtData 
         Height          =   2895
         Left            =   120
         MultiLine       =   -1  'True
         ScrollBars      =   3  'Both
         TabIndex        =   4
         Top             =   240
         Width           =   4695
      End
   End
End
Attribute VB_Name = "frmTabuJSP"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim Process(100, 100) As Integer
Dim ProcessTime(100, 100) As Integer

Private Sub cmdInput_Click()
Dim I As Integer

Call GenerateInputMatrix
cmdStart.Enabled = True
'Call GenerateGraph
''Call ReadSolution
''Exit Sub
'Call DrawGantt
''Call GetCriticalPath(CriticalPath)
''Call PutTaskAhead(1, 0, 5)
''Call AlterGraph(1, 0)
''Call DrawGantt
''use for debug
'Call GetAllTaskInDevice
End Sub

Private Sub cmdRelay_Click()
'读入中间结果文件
Dim fs, txtfile, StrLine, str0
Dim fname As String
Dim I As Integer, j As Integer, ForWriting As Integer, ForReading As Integer
Dim row As Integer
ForWriting = 2
ForReading = 1
'CommonDialog1.DialogTitle = "查找输入文件"
'CommonDialog1.Filter = "Text Files" & "(*.txt)|*.txt|All Files (*.*)|*.*"
'CommonDialog1.ShowOpen
Set fs = CreateObject("scripting.filesystemobject")
'Set wfile = fs.OpenTextFile(CommonDialog1.FileName, ForWriting, False)
fname = App.Path & "\\mediate.txt"
Set txtfile = fs.OpenTextFile(fname, ForReading, False)
Me.MousePointer = vbHourglass 'ccDefault
row = 0
Do While Not txtfile.AtEndOfStream
   StrLine = txtfile.readline
   txtResult.Text = txtResult.Text & StrLine
   row = row + 1
Loop
txtfile.Close
Me.MousePointer = vbDefault

End Sub

Private Sub cmdStart_Click()
Dim I As Integer, tt(100) As Integer, TQueue(100) As Integer, tblist(100) As Integer, Stra As Integer
'Call GenerateInputMatrix
Call GenerateGraph
Call Tabu(I, tt, TQueue, tblist, Stra)
Call ReportResult
'Call ReadSolution
'Initialize
'Application
'ReportFinal
'Call GenerateInputMatrix_TEMP

End Sub

Private Function Initialize()
Dim I As Integer
'置顶点
For I = 0 To CityCount - 1
    Vertex(I).id = I
    Vertex(I).Name = "No." & I
Next I
'禁忌表置空
For I = 0 To TblLength
    TabuList(I).tblist(0) = -1
    TabuList(I).tblist(1) = -1
    TabuList(I).tbcnt = 0
Next
'参数初始化
MAXLOOP = 50
TblLength = 5
BestSoFar.exchg(0) = -1
BestSoFar.exchg(1) = -1
BestSoFar.Val = 30000
For I = 0 To CityCount - 1
    BestSoFar.neighbour(I) = 0
    Result(I) = -1
Next I
BestLoop = 0
'构造初始解
FirstResult0 (0)

End Function
Function InResult(rst() As Integer, k As Integer)
Dim I As Integer, j As Integer
'j = UBound(rst)
For I = 0 To CityCount - 1
    If (rst(I) = k) Then
        InResult = 1
        Exit Function
    End If
Next I
InResult = 0
End Function
'构造初始解
Private Sub FirstResult0(start As Integer)  '参数为顶点编号
Dim cnt As Integer, dest As Integer
Dim flag As Boolean
flag = True
cnt = 1
Result(0) = Vertex(start).id
dest = start + 1
While (cnt < CityCount And flag)
    If a(start, dest) <> 0 Then
        If InResult(Result, Vertex(dest).id) = 0 Then
            Result(cnt) = Vertex(dest).id
            start = dest
            cnt = cnt + 1
        Else
            '空语句
        End If
    Else
            '空语句
    End If
    dest = dest + 1
    If (dest = start) Then
        '节点dest出度为0,未找到一条能通往所有节点的路径
         MsgBox "节点dest出度为0,未找到一条能通往所有节点的路径", vbOKOnly
         flag = False
    End If
    If dest > cnt Then
        dest = 0
    End If
Wend
'ReportResult
End Sub
'计算适配值（目标函数值）
Function ObjFunc(rst() As Integer) As Double
Dim j As Integer
Dim k As Double

j = 0
k = 0
While (j < CityCount - 1)
   k = k + a(rst(j), rst(j + 1))
   j = j + 1
Wend
ObjFunc = k
End Function
'输出结果
Private Sub ReportResult()
Dim I As Integer, pno As Integer, ptime As Double
Call ReadSolution
Call DrawGanttNT
'txtResult.Text = "解：" & vbCrLf
'txtResult.Text = ""
'For I = 0 To DeviceCount - 1
'    DisplayTaskInDevice (I)
'Next I
'Call GetLongest(pno, ptime)
'txtResult.Text = txtResult.Text & vbCrLf & "最大值 零件：" & pno & "时间：" & ptime
End Sub


Private Sub Command1_Click()
Dim I As Integer, j As Integer
Call GenerateInputMatrix
Call GenerateProcess
Call ReadSolution

''PicGantt.Line (10, 100)-(1000, 100)
Call DrawGantt
''Call ExchangeTask(2, 3, 5)
''DisplayTaskInDevice (2)
''
''Call CalNewTime(2, 3)
'DisplayTaskInDevice (2)

End Sub

Private Sub Form_Load()
'cmdStart.Enabled = False
'cmdInput.Enabled = True
End Sub
Function GetAllNeighbour(rst() As Integer) As Integer
Dim I As Integer, j As Integer, cnt As Integer

cnt = 0
For I = 1 To CityCount - 1
    For j = I + 1 To CityCount - 1
   
        exchange rst, I, j, valobj(cnt).exchg, valobj(cnt).neighbour
        'If valobj(cnt).neighbour <> "" Then
        '    valobj(cnt).exchg = kk
        cnt = cnt + 1
        'End If
    Next j
'    Debug.Print cnt
Next I
GetAllNeighbour = cnt
'查看所有的邻域解(调试用)
'txtresult = ""
'For i = 0 To cnt - 1
'    For j = 0 To CityCount - 1
'        txtresult.Text = txtresult.Text & valobj(i).neighbour(j)
        'If j + 1 Mod 10 = 0 Then
        '    txtresult.Text = txtresult.Text & vbCrLf
        'End If
'    Next j
'Next i
End Function

Function exchange(rst() As Integer, I As Integer, j As Integer, ByRef exch() As Integer, _
                    ByRef newr() As Integer)
Dim k As Integer, m As Integer
m = 0

'If a(order(i - 1) - 1, order(j) - 1) = 0 Or a(order(i) - 1, order(j + 1) - 1) = 0 Then
'    '无通路，不能对换
'    Exit Function
'End If

For k = 0 To CityCount - 1
    If k <> I And k <> j Then
        newr(k) = rst(k)
    End If
    If k = j Then
        newr(k) = rst(I)
    End If
    If k = I Then
        newr(k) = rst(j)
    End If
Next k
exch(0) = rst(I)
exch(1) = rst(j)

End Function
Sub GetAllNb_ObjFunc(cnt As Integer)
Dim I As Integer
For I = 0 To cnt - 1
    valobj(I).Val = ObjFunc(valobj(I).neighbour)
Next I
'show the result
'For i = 0 To cnt - 1
'    txtresult.Text = txtresult.Text & vbCrLf & valobj(i).val
'Next i

'sort the result
SortValObj (cnt)
'report reulst after sorted
'For i = 0 To cnt - 1
 '   txtresult.Text = txtresult.Text & vbCrLf & valobj(i).val
'Next i

End Sub
'改禁忌表
Function SetTabuList(tob() As Integer)
Dim I As Integer, flag As Boolean
flag = True