frmsuanfa1.frm

基于vb6.0和sql数据库的车间调度管理系统

            For t = 1 To nn
               If pg(ss + 1, t) = 0 Then Stop
               pg(h1, t) = pg(ss + 1, t)
            Next t
        ElseIf fn = f2 And fn <> f3 Then
           For t = 1 To nn
               If pg(ss + 1, t) = 0 Then Stop
               pg(h2, t) = pg(ss + 1, t)
            Next t
       End If
End If
For t = 1 To nn
     pg(ss + 1, t) = 0
Next t
End Sub


'禁忌表的移动
Public Sub tabu_change()
Dim Tabu(100, 100) As Single '禁忌表
Dim i As Integer
For i = 1 To ss
 If Tabu(i, 1) = f3 And Tabu(i, 2) <= 3 Then
    Tabu(i, 2) = Tabu(i, 2) - 1
 Else
   If Tabu(i, 0) = 0 Then
      Tabu(i, 1) = f3
      Tabu(i, 2) = 3
    End If
  End If
Next i
End Sub
Public Sub fset()
  Dim i As Integer, j As Integer
  For i = 1 To ss
    For j = 1 To nn
    p(i, j) = pg(i, j)
    Next j
  Next i
  
End Sub
'本函数用来计算各个染色体的选择概率
Public Sub fitness()
    Dim i As Integer, sum As Single
    Dim ppp() As Single
    ReDim ppp(ss)
    sum = 0
    '计算染色体的适值和
    For i = 1 To ss
      sum = sum + f(i)
    Next i
    '计算染色体的选择概率
    For i = 1 To ss
       ppp(i) = f(i) / sum
    Next i
    '计算割染色体的累积概率pf
      pf(0) = 0
    For i = 1 To ss
       pf(i) = pf(i - 1) + ppp(i)
    Next i
End Sub
Public Function ddd(A As Single, B As Single, C As Single) As Single
    Dim k As Single
    k = A
    If k > B Then
      k = B
    End If
    If k > C Then
       k = C
    End If
    ddd = k
    
End Function
'该函数返回机器生产时间
Public Function fit(g As Integer, str As Integer) As Single
     Dim k As Integer, j As Integer
       Call ft(g, str)
              imax = mach(1, min(1)).stop
              For j = 2 To mm
                If imax < mach(j, min(j)).stop Then imax = mach(j, min(j)).stop
              Next j
            fit = 1# / imax
End Function
'该函数返回本条染色体的适值
Public Function fit1(g As Integer, str As Integer) As Single
     Call ft1(g, str)
     fit1 = 1 / fmax()
End Function
'编写选择函数
Public Sub chose()
    Dim i As Integer, j As Integer, k As Single
    Dim flag As Boolean
    Dim C As Integer
     Randomize
    For i = 1 To ss
        k = Rnd()
        j = 1
        flag = False
        Do Until flag Or j > ss
           If k > pf(j - 1) And k < pf(j) Then
              flag = True
           Else
             j = j + 1
           End If
        Loop
        
          For C = 1 To nn
            If p(j, C) = 0 Then Stop
             pg(i, C) = p(j, C)
          Next C
       
      Next i
End Sub
'在某串基因串中查找某基因的后继,参数g表明第g条染色体，n和m表明从n到m的基因串，l为要查找的基因
Public Function findhj(g As Integer, n As Integer, m As Integer, l As Integer) As Boolean
     Dim i As Integer, k As Integer, j As Integer
       findhj = False
     For i = n To m
       k = pg(g, i)
       j = 1
       Do Until B(k, j) = 0 Or findhj
           If B(k, j) = l Then
              findhj = True
           End If
           j = j + 1
       Loop
     Next i
End Function

'在某串基因串中查找某基因的后继,参数g表明第g条染色体，n和m表明从n到m的基因串，l为要查找的基因
Public Function findqq(g As Integer, n As Integer, m As Integer, l As Integer) As Boolean
     Dim i As Integer, k As Integer
      If B(l, 1) = 0 Then
         findqq = False
      Else
         findqq = False
         k = 1
         Do Until B(l, k) = 0 Or findqq
            findqq = find(g, n, m, B(l, k))
            k = k + 1
         Loop
     End If
End Function

'在某段基因串中查找某个基因是否存在
'染色体中从n到m的基因串，查找基因l,g代表地g条染色体
Public Function find(g As Integer, n As Integer, m As Integer, l As Integer) As Boolean
     Dim i As Integer
     find = False
     i = n
     Do Until i > m Or find
     If l = pg(g, i) Then
        find = True
     End If
        i = i + 1
     Loop
End Function
'在某段基因串中查找某个基因是否存在
'染色体中从n到m的基因串，查找基因l
Public Function finddd(n As Integer, m As Integer, l As Integer) As Boolean
     Dim i As Integer
     find = False
     i = n
     Do Until i > m Or find
     If l = pgg(i) Then
        find = True
     End If
        i = i + 1
     Loop
End Function
'变异操作
Public Sub mutation()
 Dim fran() As Single
 Dim i As Integer, j As Integer, k As Integer, r As Integer
 Dim yy As Integer, ww As Integer, l As Integer
 Dim cro() As Single
 Dim flag As Boolean
 Dim jj As Integer
 Dim f1 As Single, f2 As Single
 Randomize
 'k为应发生变异的基因的个数
 k = pm * ss * nn
 ReDim cro(k + 1)
 ReDim fran(ss * nn + 1)
 '生成ss*nn个随机数
 For i = 1 To ss * nn
    fran(i) = Rnd
 Next i
 j = 0
 i = 1
 flag = True
 Do Until j >= k Or i > ss * nn
   If fran(i) < pm Then
      j = j + 1
      cro(j) = i
   End If
   i = i + 1
 Loop
 '发生移位变异
 For r = 1 To j
   'yy表示变异的染色体ww表示变异的基因
        yy = cro(r) \ nn + 1
        ww = cro(r) Mod (nn)
        If ww = 0 Then
           yy = yy - 1
           ww = nn
        End If
        'l为基因移位的位置
        l = Int((nn * Rnd) + 1)
        For i = 1 To nn
        pg(ss + 1, i) = pg(yy, i)
        Next i
        jj = pg(ss + 1, ww)
        If l < ww Then
             '在基因串pg(yy,l)到pg(yy,ww-1)中查找基因 pg(yy, ww)的前驱
             If findqq(ss + 1, l, ww - 1, jj) Then
                 
             Else
                
                For i = ww - 1 To l Step -1
                    pg(ss + 1, i + 1) = pg(ss + 1, i)
                Next i
                 pg(ss + 1, l) = jj
             End If
        ElseIf l > ww Then
             '在基因串pg(yy,l)到pg(yy,ww-1)中查找基因 pg(yy, ww)的后记
             If findhj(yy, ww + 1, l, jj) Then
                 
             Else
                For i = ww + 1 To l
                    pg(ss + 1, i - 1) = pg(ss + 1, i)
                Next i
                 pg(ss + 1, l) = jj
             End If
        End If
        f1 = fit(yy, 2)
        f2 = fit(ss + 1, 2)
        If f2 > f1 Then
           For i = 1 To nn
           pg(yy, i) = pg(ss + 1, i)
           Next i
        End If
 Next r
 
End Sub
Public Sub translate1(str As Integer)
   Dim i As Integer, j As Integer
   
     '初始化适值
      For j = 1 To ss
         f(j) = 0
      Next j
   '解码
       For i = 1 To ss
              'ft1为解码函数，fmax 为求最大机器加工时间函数
              Call ft1(i, str)
              f(i) = 1 / fmax()
       Next i
End Sub

Public Sub mutation1()
 Dim fran() As Single
 Dim i As Integer, j As Integer, k As Integer, r As Integer, h As Integer
 Dim yy As Integer, ww As Integer, l As Single
 Dim cro() As Single
 Dim jj As Integer
 ReDim pnew(mm + 1, nn + 1)
 ReDim fnew(mm + 1)
 Randomize
 'k为应发生变异的基因的个数
 k = pm * ss * nn
 ReDim cro(k + 1)
 ReDim fran(ss * nn + 1)
 '生成ss*nn个随机数
 For i = 1 To ss * nn
    fran(i) = Rnd
 Next i
 j = 0
 i = 1
 '查找要发生变异的染色体号
 Do Until j >= k Or i > ss * nn
   If fran(i) < pm Then
      j = j + 1
      cro(j) = i
   End If
   i = i + 1
 Loop
 '发生插入变异
 
 For i = 1 To j
     yy = cro(i) \ nn + 1
     ww = cro(i) Mod nn
     If ww = 0 Then
       yy = yy - 1
       ww = nn
     End If
     For h = 1 To pg(yy, ww) - 1
            For r = 1 To ww - 1
              
              pnew(h, r) = pg(yy, r)
              If pnew(h, r) = 0 Then Stop
            Next r
        
             pnew(h, ww) = h
            For r = ww + 1 To nn
              pnew(h, r) = pg(yy, r)
              If pnew(h, r) = 0 Then Stop
            Next r
           fnew(h) = fit1(h, 3)
      Next h
      For h = pg(yy, ww) + 1 To mm
            For r = 1 To ww - 1
             
              pnew(h, r) = pg(yy, r)
              If pnew(h, r) = 0 Then Stop
            Next r
            pnew(h, ww) = h
            For r = ww + 1 To nn
            
              pnew(h, r) = pg(yy, r)
              If pnew(h, r) = 0 Then Stop
            Next r
            fnew(h) = fit1(h, 3)
      Next h
            fnew(pg(yy, ww)) = fit1(yy, 2)
     '进行局部搜索
       l = fmax1(mm)
       If l = pg(yy, ww) Then
       Else
         For r = 1 To nn
           pg(yy, r) = pnew(l, r)
         Next r
       End If
 Next i

End Sub
'交叉操作 采用lox法线性顺序交叉
Public Sub crossover1()
   Dim cro() As Integer
   Dim i As Integer, j As Integer, k As Integer
   Dim flag As Boolean, flag1 As Boolean
'   Dim f1 As Single '父染色体一的适值
'   Dim f2 As Single '父染色体二的适值
'   Dim fh1 As Single, fh2 As Single '后代染色体的适值
   Dim h1 As Integer '交叉染色体的号码
   Dim h2 As Integer '交叉染色体的号码
   Dim g1 As Integer '断点一
   Dim g2 As Integer '断点二
   Dim t As Integer
  Dim w1 As Single, w2 As Single, w3 As Single, w4 As Single
   k = ss * pc '它记录了发生交叉的染色体的个数
   ReDim pran(ss) '它记录了每条染色体的交叉随机数
   ReDim cro(k + 1) As Integer
   Randomize
   '生成每条染色体地交叉随机数
   For i = 1 To ss
      pran(i) = Rnd
   Next i
      j = 0
      i = 1
    '查找要发生交叉地染色体地号码
   Do Until i > ss Or j >= k
       If pran(i) < pc Then
          j = j + 1
           cro(j) = i
       End If
       i = i + 1
   Loop
   
   i = 2
   '染色体交叉
   k = j
  Do Until i > k
     h1 = cro(i - 1)
     h2 = cro(i)
     g1 = Int((nn * Rnd) + 1) '产生一个1到nn的随机数
     g2 = Int((nn * Rnd) + 1)
      If g1 > g2 Then
         t = g1
         g1 = g2
         g2 = t
      End If
      '顺序交叉
      
      For j = 1 To g1 - 1
          pg(ss + 1, j) = pg(h1, j)
          pg(ss + 2, j) = pg(h2, j)
      Next j
      For j = g1 To g2
          pg(ss + 1, j) = pg(h2, j)
          pg(ss + 2, j) = pg(h1, j)
      Next j
       For j = g2 + 1 To nn
          pg(ss + 1, j) = pg(h1, j)
          pg(ss + 2, j) = pg(h2, j)
      Next j
      '计算双亲和后代染色体的适值
    
  w1 = fit1(h1, 2)
  w2 = fit1(h2, 2)
  w3 = fit1(ss + 1, 2)
  w4 = fit1(ss + 2, 2)
   If w3 > w1 Or w3 > w2 Then
      If w1 > w2 Then
         For j = 1 To nn
            pg(h2, j) = pg(ss + 1, j)
         Next j
      Else
         For j = 1 To nn
           pg(h1, j) = pg(ss + 1, j)
         Next j
      End If
   End If
   If w4 > w1 Or w3 > w2 Then
      If w1 > w2 Then
         For j = 1 To nn
           pg(h2, j) = pg(ss + 2, j)
         Next j
      Else