frmsuanfa1.frm

采用面向负荷控制技术

   ReDim d(nn + 1)
   ReDim b(nn + 1, ll + 1)
   ReDim ran(nn + 1)
   ReDim f(ss + 1)
   ReDim mach(mm + 1, hh + 1)
   ReDim mach1(ss + 1, mm + 1, hh + 1)
   ReDim min(mm + 1)
   ReDim pf(ss + 1)
'   ReDim tt(1 To dd + 1)
   i = 1
   str = "ss"
   rs.MoveFirst
   Do Until rs.EOF
        a(1, i) = i
        a(2, i) = findmachine(Trim$(rs("machinenumber")))
        a(3, i) = CSng(rs("timeoccupy") * rs("planquantity"))
        If str = Trim$(rs("drawingno")) Then
         b(i, 1) = i - 1
        Else
          b(i, 1) = 0
        End If
        str = Trim$(rs("drawingno"))
        i = i + 1
        rs.MoveNext
   Loop
 
End Sub
'启发式遗传调度算法
Public Function genetic1() As Integer
  Dim k As Integer, i As Integer, j As Integer
  Dim imax As Single
  Dim sum As Single
  
  k = 1
  '初始化
'  Call Command2_Click
  Call initial4
  '生成初始种群
'  Call Command1_Click
  Call popsize(ss)
'  Call Command3_Click
  
  Do Until k > dd
       '计算种群的适值
       Call translate(1)
        sum = 0
'        tt(k, 1) = k
        For i = 2 To ss
           sum = sum + 1 / f(i)
        Next i
'        tt(k) = sum / ss
       '计算选择概率
       Call fitness
       '选择操作
       Call chose
       '交叉操作
       Call crossover
       '变异操作
       Call mutation
       '重新设置种群
       Call fset
       '解码并计算适值
       'Call translate(1)
       k = k + 1
   Loop
   For i = 1 To ss
     '对每个染色体解码，
     Call ft(i, 1)
      For j = 1 To mm
         For k = 1 To hh
            mach1(i, j, k).gx = mach(j, k).gx
            mach1(i, j, k).start = mach(j, k).start
            mach1(i, j, k).stop = mach(j, k).stop
         Next k
      Next j
      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
            f(i) = 1 / imax
    Next i
    k = 1
   ' 选出适值最大的染色体
   For i = 2 To ss
     If f(k) < f(i) Then
        k = i
     End If
   Next i
   genetic1 = k
  
End Function
'并行多机调度算法
Public Sub genetic2()
   Dim k As Integer, i As Integer, j As Integer
  Dim m1, m2
  Dim imax As Single
  Dim sum As Single
  k = 1
  '初始化
  m1 = Second(Time)
  Call initial2
  '生成初始种群
'  Call Command7_Click
  Call popsize1(ss)
  'dd为最大迭代数
  Do Until k > dd
       '计算种群的适值
       Call translate1(1)
        sum = 0
'        tt(k, 1) = k
        For i = 1 To ss
           sum = sum + 1 / f(i)
        Next i
        tt(k) = sum / ss
       '计算选择概率
       Call fitness
       '选择操作
       Call chose
       '交叉操作
       Call crossover1
       '变异操作
       Call mutation1
       '重新设置种群
       Call fset
       '解码并计算适值
       'Call translate(1)
       k = k + 1
   Loop
   For i = 1 To ss
     '对每个染色体解码，
     Call ft1(i, 1)
    Next i
    k = 1
   For i = 2 To ss
     If f(k) < f(i) Then
        k = i
     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