bp神经网络的拓扑优化算法.bas

如何在VB下实现BP神经网络的拓扑优化算法

Dim s1 As String
Dim i, j, t, k, g, h, z As Long             '神经网络变量
Dim a(), y1(), w(), v(), o(), r(), s(), b(), l(), c(), eee(), max() As Double
Dim rf, bt As Double '学习率1，学习率2
Dim ss(), aa(), bb(), ll(), cc() As Double '回想时使用的变量
'--------------------------------------------------------------------------------------
Dim fitness() As Double
Dim newfitness() As Double
Dim sumfitness As Double
Dim xdfitness() As Double
Dim pop() As Double
Dim newpop() As Double
Dim currrentpop() As Double           '遗传算法变量
Dim ljgl() As Double
Dim copyindex() As Long
Dim jhgl As Double '交换率
Dim bygl As Double '变异概率
Dim changeindex() As Long
Dim varyindex() As Long
Dim changepoint As Long
Dim changenumber As Long
Dim varynumber As Long
Dim max1 As Double
Dim max2 As Double
Dim min1 As Double
Dim min2 As Double
Dim eeemin As Double

'-------------------------------------------------------------------------------------

rf = 0.6
bt = 0.6
jhgl = 0.4
bygl = 0.01
g = 50
m=vsfgrid1.rows
n=vsfgrdi1.cols-1
p = 2 * n - 1
q = 1
              '变量赋初值
changenumber = (jhgl * g \ 2) * 2
varynumber = g * (n * p + p * q + p + q) * bygl
eeemin = 20
max1 = 20
min1 = -20
max2 = 0.1
min2 = -0.1
'-------------------------------------------------------------------------------


ReDim w(n, p), v(p, q), y1(m, q)
ReDim o(p), r(q), a(m, n), ss(p)
ReDim s(m, p), b(m, p), l(m, q)
ReDim c(m, q), d(m, q), cc(q)
ReDim e(m, p), bb(p), aa(n), ll(q)
ReDim eee(g)
ReDim fitness(g)                   '重新声明数组维数
ReDim newfitness(g)
ReDim xdfitness(g)
ReDim ljgl(g)
ReDim pop(g, n * p + p * q + p + q)
ReDim newpop(g, n * p + p * q + p + q)
ReDim copyindex(g)
ReDim changeindex(changenumber)
ReDim varyindex(varynumber)

'--------------------------------------------------------------------------------
For i = 1 To g
Randomize
For j = 1 To n * p + p * q
  pop(i, j) = (max1 - min1) * Rnd() + min1
Next j
Next i
                            '染色体随机赋值
For i = 1 To g
  Randomize
  For j = n * p + p * q + 1 To n * p + p * q + p + q
    pop(i, j) = (max2 - min2) * Rnd() + min2
  Next j
Next i
'---------------------------------------------------------------------------------
For k = 1 To m
  For i = 1 To n
    a(k, i) = VSFGrid1.TextMatrix(k, i)
  Next i
Next k
                          '从网格中读取训练样本
For t = 1 To m
  For k = 1 To q
    y1(t, k) = VSFGrid1.TextMatrix(t, k + n)
  Next k
Next t
  
'---------------------------------------------------------------------------------
ReDim max(n) As Double
For j = 1 To n
max(j) = a(1, j)
Next j

For i = 1 To n
  For j = 1 To m
  If a(j, i) >= max(i) Then
    max(i) = a(j, i)
  End If
  Next j
Next i

For i = 1 To n
  For j = 1 To m
    a(j, i) = a(j, i) / max(i)
    VSFGrid1.TextMatrix(j, i) = a(j, i)
  Next j
Next i

Erase max()
ReDim max(q) As Double
For j = 1 To q
max(j) = y1(1, j)               '数据归一化处理
Next j
For i = 1 To q
  For j = 1 To m
    If y1(j, i) >= max(i) Then
    max(i) = y1(j, i)
    End If
  Next j
Next i

For i = 1 To q
  For j = 1 To m
    y1(j, i) = y1(j, i) / max(i)
    VSFGrid1.TextMatrix(j, i + n) = y1(j, i)
  Next j
Next i

'-----------------------------------------------------------------------------
Dim cyclse As Long
cycles = 60
For li = 1 To cycles
sumfitness = 0
maxfitness = 0

'-----------------------------------------------------------------------------
For h = 1 To g
  eee(h) = 0
  For z = 1 To n * p + p * q + p + q
    If z <= n * p Then
      For i = 1 To n
        For j = 1 To p
          w(i, j) = pop(h, (i - 1) * p + j)
        Next j
      Next i
    End If
  
    If z > n * p And z <= n * p + p * q Then
      For i = 1 To p
        For j = 1 To q
          v(i, j) = pop(h, (i - 1) * q + j + n * p)
        Next j
      Next i                 '将染色体的值逐个读入对应权和阈数组
    End If
  
    If z > n * p + p * q And z <= n * p + p * q + p Then
      For i = 1 To p
        o(i) = pop(h, i + n * p + p * q)
      Next i
    End If
    
    If z >= n * p + p * q + p And z <= n * p + p * q + p + q Then
      For i = 1 To q
        r(i) = pop(h, i + n * p + p * q + p)
      Next i
    End If
  Next z
'-----------------------------------------------------------------------------
  
For k = 1 To m
  For j = 1 To p
    s(k, j) = 0
    For i = 1 To n
      s(k, j) = s(k, j) + w(i, j) * a(k, i)
    Next i
    s(k, j) = s(k, j) - o(j)
    b(k, j) = 1 / (1 + Exp(-s(k, j)))
  Next j
  
  For t = 1 To q
    l(k, t) = 0
    For j = 1 To p
        l(k, t) = l(k, t) + v(j, t) * b(k, j)
    Next j
    l(k, t) = l(k, t) - r(t)
    c(k, t) = 1 / (1 + Exp(-l(k, t)))
  Next t
Next k                       '用BP求误差进而求个体适应度
    
  For k = 1 To m
    For t = 1 To q
      eee(h) = eee(h) + (y1(k, t) - c(k, t)) * (y1(k, t) - c(k, t)) / 2
    Next t
  Next k


  fitness(h) = 1 / eee(h) '适应度
  sumfitness = sumfitness + fitness(h) '适应度总和
  If fitness(h) > maxfitness Then maxfitness = fitness(h) '每代中种群内适应度最大个体
  
  DoEvents
Next h

'-----------------------------------------------------------------------------
For h = 1 To g
xdfitness(h) = fitness(h) / sumfitness '相对适应度
Next h
ljgl(1) = xdfitness(1)
For h = 1 To g - 1
  ljgl(h + 1) = ljgl(h) + xdfitness(h + 1) '累积适应度
  'Debug.Print xdfitness(h); ljgl(h)
Next h
maxiabiao = 1
For h = 1 To g
suiji = Rnd()
  For i = 1 To g
    If ljgl(i) > suiji Then
    copyindex(h) = i
    If i > maxiabiao Then maxiabiao = i
    Exit For
    End If
  Next i
Next h

For i = 1 To g
For j = 1 To n * p + p * q + p + q
newpop(i, j) = pop(copyindex(i), j)
Next j
Next i

For i = 1 To g
For j = 1 To n * p + p * q + p + q
pop(i, j) = newpop(i, j)
Next j
Next i

For i = 1 To g
ljgl(i) = 0
Next i
'复制算法完成，接下来是交换和变异
sumfitness = 0
For h = 1 To g
newfitness(h) = fitness(copyindex(h))
sumfitness = sumfitness + newfitness(h)

Next h

For h = 1 To g
xdfitness(h) = newfitness(h) / sumfitness
Next h

ljgl(1) = xdfitness(1)

For h = 1 To g - 1

  ljgl(h + 1) = ljgl(h) + xdfitness(h + 1) '复制后的累积适应度
  'Debug.Print xdfitness(h); ljgl(h)
Next h

'接下来在新种群中随机选择将要交换的染色体

For h = 1 To changenumber
suiji = Rnd()
  For i = 1 To g
    If ljgl(i) > suiji Then
    changeindex(h) = i '要交换的染色体下标存入changeindex（）
    Exit For
    End If
  Next i
Next h

'下面接下来是交换操作

For i = 1 To changenumber - 1 Step 2
Randomize

suiji = Rnd()
'Debug.Print suiji
suiji1 = Rnd()
jhpoint = Int((n * p + p * q + p + q - 1) * suiji) + 1
newpop(changeindex(i), jhpoint) = newpop(changeindex(i), jhpoint) - suiji1 * (newpop(changeindex(i), jhpoint) - newpop(changeindex(i + 1), jhpoint))
newpop(changeindex(i + 1), jhpoint) = newpop(changeindex(i + 1), jhpoint) + suiji1 * (newpop(changeindex(i), jhpoint) - newpop(changeindex(i + 1), jhpoint))
For k = jhpoint + 1 To n * p + p * q + p + q
  temp = newpop(changeindex(i + 1), k)
  newpop(changeindex(i + 1), k) = newpop(changeindex(i), k)
  newpop(changeindex(i), k) = temp
Next k
Next i
DoEvents

'交换完成，下面是突变
For i = 1 To varynumber
  temp = Int(Rnd * g * ((n * p + p * q + p + q - 1)) + 1)
  varyindex(i) = temp
  If i > 1 Then
  For j = 1 To i - 1
    If temp = varyindex(j) Then       '突变点的选择避免重复
    i = i - 1
    End If
  Next j
  End If
Next i

For i = 1 To varynumber
  If varyindex(i) Mod (n * p + p * q + p + q) <> 0 Then
    hengbiao = Int(varyindex(i) \ (n * p + p * q + p + q)) + 1
    shubiao = varyindex(i) Mod (n * p + p * q + p + q)
  Else
    hengbiao = Int(varyindex(i) \ (n * p + p * q + p + q))
    shubiao = n * p + p * q + p + q
  End If

  If shubiao <= n * p + p * q Then
    newpop(hengbiao, shubiao) = newpop(hengbiao, shubiao) + sgnrnd(Rnd()) * (max1 - min1) * (1 - Exp(((1 - li / cycles) ^ 2) * Log(Rnd()))) '对权进行突变
'Debug.Print (max1 - min1) * (1 - Exp(((1 - li / cycles) ^ 2) * Log(Rnd())))
  Else
      
    newpop(hengbiao, shubiao) = newpop(hengbiao, shubiao) + sgnrnd(Rnd()) * (max2 - min2) * (1 - Exp(((1 - li / cycles) ^ 2) * Log(Rnd()))) '对阈进行突变
  End If
Next i

For i = 1 To g
For j = 1 To n * p + p * q + p + q
pop(i, j) = newpop(i, j)
Next j
Next i

Debug.Print maxfitness
Next li