'模块
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(), sgnrnd() 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
-----------------------------------------
'窗体代码
Private Sub Command1_Click()
rf = 0.6
bt = 0.6
jhgl = 0.4
bygl = 0.01
g = Val(Text2.Text) '设定学习深度
m = MSFlexGrid1.Rows - 1
n = MSFlexGrid1.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 = 25
min1 = 1
max2 = 0.998
min2 = 0.001
'-------------------------------------------------------------------------------
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) = MSFlexGrid1.TextMatrix(k, i)
Next i
Next k
'从网格中读取训练样本
For t = 1 To m
For k = 1 To q
y1(t, k) = MSFlexGrid1.TextMatrix(t, k)
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)
' MSFlexGrid2.TextMatr
ix(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)
' MSFlexGrid2.TextMatrix(j, q) = 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
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
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
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
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 - 1
xdfitness(h) = newfitness(h) / sumfitness
Next h
'ljgl(i) = xdfitness(i)
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
newpop(hengbiao, shubiao) = newpop(hengbiao, shubiao) + Sgn(Rnd()) * (max1 - min1) * (1 - Exp(((1 - li / cycles) ^ 2) * Log(Rnd()))) '对权进行突变
Debug.Print Sgn(Rnd()) * (max1 - min1) * (1 - Exp(((1 - li / cycles) ^ 2) * Log(Rnd())))
Else
newpop(hengbiao, shubiao) = newpop(hengbiao, shubiao) + Sgn(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
Text1.Text = maxfitness
' MSFlexGrid2.TextMatrix(j, q) = newpop(i, j)
Next li
End Sub
'模块
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(), sgnrnd() 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
-----------------------------------------
'窗体代码
Private Sub Command1_Click()
rf = 0.6
bt = 0.6
jhgl = 0.4
bygl = 0.01
g = Val(Text2.Text) '设定学习深度
m = MSFlexGrid1.Rows - 1
n = MSFlexGrid1.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 = 25
min1 = 1
max2 = 0.998
min2 = 0.001
'-------------------------------------------------------------------------------
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) = MSFlexGrid1.TextMatrix(k, i)
Next i
Next k
'从网格中读取训练样本
For t = 1 To m
For k = 1 To q
y1(t, k) = MSFlexGrid1.TextMatrix(t, k)
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)
' MSFlexGrid2.TextMatr
ix(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)
' MSFlexGrid2.TextMatrix(j, q) = 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
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
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
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
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 - 1
xdfitness(h) = newfitness(h) / sumfitness
Next h
'ljgl(i) = xdfitness(i)
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
newpop(hengbiao, shubiao) = newpop(hengbiao, shubiao) + Sgn(Rnd()) * (max1 - min1) * (1 - Exp(((1 - li / cycles) ^ 2) * Log(Rnd()))) '对权进行突变
Debug.Print Sgn(Rnd()) * (max1 - min1) * (1 - Exp(((1 - li / cycles) ^ 2) * Log(Rnd())))
Else
newpop(hengbiao, shubiao) = newpop(hengbiao, shubiao) + Sgn(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
Text1.Text = maxfitness
' MSFlexGrid2.TextMatrix(j, q) = newpop(i, j)
Next li
End Sub