frmsuanfa1.frm

采用面向负荷控制技术

             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
         For j = 1 To nn
           pg(h1, j) = pg(ss + 2, j)
         Next j
      End If
   End If

          i = i + 2
  Loop
  End Sub



'交叉操作 采用lox法线性顺序交叉
Public Sub crossover()
   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 fn As Single '后代染色体的适值
   Dim h1 As Integer '交叉染色体的号码
   Dim h2 As Integer '交叉染色体的号码
   Dim g1 As Integer '断点一
   Dim g2 As Integer '断点二
   Dim t As Integer
   Dim www As Integer
   Dim f3 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
'      flag1 = False
      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
      '顺序交叉
      Dim w1 As Integer
      Dim w2 As Integer
      For j = g1 To g2
          pg(ss + 1, j) = pg(h1, j)
      Next j
      w1 = g1
      w2 = g2
      www = 0
    For t = 1 To nn
       '看基因pg(h2, t)是否在染色体中
       If Not find(ss + 1, w1, w2, pg(h2, t)) Then
          If findqq(ss + 1, w1, w2, pg(h2, t)) Then
                w2 = w2 + 1
                If w2 > nn Then
                  For j = w1 To w2 - 1
                     pg(ss + 1, j - 1) = pg(ss + 1, j)
                  Next j
                  w1 = w1 - 1
                  w2 = w2 - 1
                  pg(ss + 1, w2) = pg(h2, t)
                Else
                 pg(ss + 1, w2) = pg(h2, t)
                End If
          Else
             www = www + 1
                If www >= w1 Then
                    If findhj(ss + 1, w1, w2, pg(h2, t)) Then
                         For j = w2 To w1 Step -1
                          pg(ss + 1, j + 1) = pg(ss + 1, j)
                         Next j
                         w2 = w2 + 1
                         w1 = w1 + 1
                         pg(ss + 1, www) = pg(h2, t)
                    Else
                     w2 = w2 + 1
                     pg(ss + 1, w2) = pg(h2, t)
                     www = www - 1
                    End If

                Else
                 pg(ss + 1, www) = pg(h2, t)
                End If
          End If
       End If
    Next t
        f1 = fit(h1, 2)
        f2 = fit(h2, 2)
        f3 = fit(ss + 1, 2)
        fn = ddd(f1, f2, f3)
        If fn = f1 And fn <> f3 Then
            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
           For t = 1 To nn
              pg(ss + 1, t) = 0
           Next t
       i = i + 2
  Loop
End Sub
'此函数为解码函数
'根据染色体解码,参数n为第几条染色体，str代表初始种群还是新生种群
Public Sub ft(n As Integer, str As Integer)
    Dim i As Integer, j As Integer, k As Integer, h As Integer
    Dim m As Integer '代表工序所对应的机器号
'   Dim m1 As Integer'代表第一台机器的第几到工序
'   Dim m2 As Integer'代表第二台机器的第几到工序
'   Dim m3 As Integer '代表第三台机器的第几到工序
    Dim pre1 As Single
    Dim flag As Boolean
    Dim lg As Single
    '初始化任务量为0
    
        For j = 1 To mm
            min(j) = 0
        Next j
   
        For j = 1 To mm
         For k = 1 To hh
          mach(j, k).gx = 0
           mach(j, k).start = 0
           mach(j, k).stop = 0
         Next k
      Next j
    Select Case str
    Case 1
        For j = 1 To nn
                  '求出机器号
                    m = a(2, p(n, j))
                    min(m) = min(m) + 1
                    mach(m, min(m)).gx = p(n, j)
                    pre1 = precede(p(n, j))
                    If mach(m, min(m) - 1).stop < pre1 Then
                        mach(m, min(m)).start = pre1
                        mach(m, min(m)).stop = mach(m, min(m)).start + a(3, p(n, j))
                    Else
                    '查找本道工序应插入的最好地方
                       flag = False
                       k = 1
                      Do Until flag Or k > min(m)
                         If mach(m, k).start > pre1 And mach(m, k).start - mach(m, k - 1).stop > a(3, p(n, j)) Then
                             If pre1 < mach(m, k - 1).stop Then
                                flag = True
                             ElseIf mach(m, k).start - pre1 > a(3, p(n, j)) Then
                                flag = True
                             Else
                                k = k + 1
                             End If
                         Else
                            k = k + 1
                         End If
                      Loop
                      '如果找到插入点则作如下操作
                      If Not flag Then
                         mach(m, min(m)).start = mach(m, min(m) - 1).stop
                         mach(m, min(m)).stop = mach(m, min(m)).start + a(3, p(n, j))
                      Else
                         For h = min(m) To k Step -1
                             mach(m, h).gx = mach(m, h - 1).gx
                             mach(m, h).start = mach(m, h - 1).start
                             mach(m, h).stop = mach(m, h - 1).stop
                         Next h
                              mach(m, k).gx = p(n, j)
                             If pre1 > mach(m, k - 1).stop Then
                                mach(m, k).start = per1
                             Else
                                 mach(m, k).start = mach(m, k - 1).stop
                             End If
                             mach(m, k).stop = mach(m, k).start + a(3, p(n, j))
                      End If
                   End If
                    
            Next j
     Case 2
             For j = 1 To nn
                  '求出机器号
                    m = a(2, pg(n, j))
                    min(m) = min(m) + 1
                    mach(m, min(m)).gx = pg(n, j)
                    pre1 = precede(pg(n, j))
                    If mach(m, min(m) - 1).stop < pre1 Then
                        mach(m, min(m)).start = pre1
                        mach(m, min(m)).stop = mach(m, min(m)).start + a(3, pg(n, j))
                    Else
                    '查找本道工序应插入的最好地方
                       flag = False
                       k = 1
                      Do Until flag Or k > min(m)
                         If mach(m, k).start > pre1 And mach(m, k).start - mach(m, k - 1).stop > a(3, pg(n, j)) Then
                             If pre1 < mach(m, k - 1).stop Then
                                flag = True
                             ElseIf mach(m, k).start - pre1 > a(3, pg(n, j)) Then
                                flag = True
                             Else
                                k = k + 1
                             End If
                         Else
                            k = k + 1
                         End If
                      Loop
                      '如果找到插入点则作如下操作
                      If Not flag Then
                         mach(m, min(m)).start = mach(m, min(m) - 1).stop
                         mach(m, min(m)).stop = mach(m, min(m)).start + a(3, pg(n, j))
                      Else
                         For h = min(m) To k Step -1
                             mach(m, h).gx = mach(m, h - 1).gx
                             mach(m, h).start = mach(m, h - 1).start
                             mach(m, h).stop = mach(m, h - 1).stop
                         Next h
                             If pre1 > mach(m, k - 1).stop Then
                                mach(m, k).start = per1
                             Else
                                 mach(m, k).start = mach(m, k - 1).stop
                             End If
                             mach(m, k).stop = mach(m, k).start + a(3, pg(n, j))
                      End If
                   End If
                    
            Next j

     End Select

End Sub
'此函数为解码函数
'根据染色体解码,参数n为第几条染色体，str代表初始种群还是新生种群
Public Sub ft1(n As Integer, str As Integer)
    Dim j As Integer
    Dim m As Integer '代表工序所对应的机器号
     '初始化设备加工时间
        For j = 1 To mm
            min(j) = 0
        Next j
    Select Case str
    Case 1
        For j = 1 To nn
            '求出机器号
            m = p(n, j)
            min(m) = min(m) + a(j, m)
        Next j
     Case 2
             For j = 1 To nn
                    '求出机器号
                    m = pg(n, j)
                    min(m) = min(m) + a(j, m)
            Next j
     Case 3
          For j = 1 To nn
                    '求出机器号
                    m = pnew(n, j)
                    
                    min(m) = min(m) + a(j, m)
                    If min(m) = 0 Then Stop
          Next j
     End Select

End Sub
'求最大的机器加工时间
Public Function fmax() As Single
     Dim i As Integer
     fmax = min(1)
     For i = 2 To mm
        If fmax < min(i) Then
           fmax = min(i)
        End If
     Next i
     
End Function
'求最大的机器加工时间
Public Function fmax1(j As Integer) As Single
     Dim i As Integer