📄 遗传算法.frm
字号:
VERSION 5.00
Object = "{0BA686C6-F7D3-101A-993E-0000C0EF6F5E}#1.0#0"; "Threed32.ocx"
Begin VB.Form Form1
Caption = "Form1"
ClientHeight = 6450
ClientLeft = 60
ClientTop = 345
ClientWidth = 7980
LinkTopic = "Form1"
ScaleHeight = 6450
ScaleWidth = 7980
StartUpPosition = 3 '窗口缺省
Begin Threed.SSPanel SSPanel2
Height = 495
Left = 6600
TabIndex = 2
Top = 3360
Width = 1215
_Version = 65536
_ExtentX = 2143
_ExtentY = 873
_StockProps = 15
Caption = "SSPanel2"
BackColor = 12632256
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
End
Begin Threed.SSPanel SSPanel1
Height = 495
Left = 6600
TabIndex = 1
Top = 2760
Width = 1215
_Version = 65536
_ExtentX = 2143
_ExtentY = 873
_StockProps = 15
Caption = "SSPanel1"
BackColor = 12632256
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
End
Begin VB.PictureBox Picture1
Height = 4935
Left = 600
ScaleHeight = 4875
ScaleWidth = 5715
TabIndex = 0
Top = 600
Width = 5775
End
Begin Threed.SSPanel SSPanel3
Height = 495
Left = 6600
TabIndex = 3
Top = 3960
Width = 1215
_Version = 65536
_ExtentX = 2143
_ExtentY = 873
_StockProps = 15
Caption = "SSPanel2"
BackColor = 12632256
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
End
Begin Threed.SSPanel SSPanel4
Height = 495
Left = 6600
TabIndex = 4
Top = 4560
Width = 1215
_Version = 65536
_ExtentX = 2143
_ExtentY = 873
_StockProps = 15
Caption = "SSPanel2"
BackColor = 12632256
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
End
Begin Threed.SSPanel SSPanel5
Height = 495
Left = 6600
TabIndex = 5
Top = 5160
Width = 1215
_Version = 65536
_ExtentX = 2143
_ExtentY = 873
_StockProps = 15
Caption = "SSPanel2"
BackColor = 12632256
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub Form_Click()
sel_bz = 1 '1:递减曲线,2:Weng旋回
formbl_x = 1: formbl_y = 1
Dim qi(), n(), di(), funsy(), qi_mid(), n_mid(), di_mid(), BZ()
Dim choose1()
popnum = 1000: pc = 0.95: arel = 0.1: pm = 0.008: pfnum = 10
ReDim qi(popnum), n(popnum), di(popnum), funsy(popnum)
ReDim qi_mid(popnum), n_mid(popnum), di_mid(popnum)
ReDim choose1(popnum), BZ(popnum)
Dim mid_dim()
ReDim mid_dim(popnum, 2)
Dim quan(2, 3)
Dim q(100), T(100)
If sel_bz = 1 Then
Open App.Path + "\qo.txt" For Input As #1
Open App.Path + "\qo.out" For Output As #2
Else
Open "E:\赵辉\遗传\qo2.dat" For Input As #1
Open "E:\赵辉\遗传\qo2.out" For Output As #2
End If
i = 0
While Not EOF(1)
i = i + 1
Input #1, T(i), abc, q(i)
Wend
Close #1
qnum = i
'初始群体的生成
If sel_bz = 1 Then
'qi0 = q(1): n0 = 0.5: di0 = 0.5
qi0 = 50: n0 = 0.5: di0 = 50.5
Else
qi0 = 300: n0 = 55.66: di0 = 85.76
End If
sum_sum_jsq = 0
10 quan(1, 1) = -qi0: quan(2, 1) = qi0 'qi
quan(1, 2) = -n0: quan(2, 2) = n0 'n
quan(1, 3) = -di0: quan(2, 3) = di0 'di
qi(1) = qi0: n(1) = n0: di(1) = di0
qi(2) = 25.246: n(2) = 2.827: di(2) = 7.382
qi(3) = 26.38: n(3) = 2.802: di(3) = 1 / 0.1339
qi(4) = 18.65582: n(4) = 3: di(4) = 1 / 0.14581
qi(5) = 36.73: n(5) = 2.6132: di(5) = 1 / 0.8845
qi(6) = 27.881: n(6) = 2.785: di(6) = 7.46
Randomize
For i = 2 To Int(popnum / 2)
qi(i) = qi0 + Rnd * quan(1, 1) '
2 n(i) = n0 + (Rnd + 0.0001) * quan(1, 2) '
If sel_bz = 1 And (n(i) < 0 Or n(i) > 1) Then GoTo 2
di(i) = di0 + Rnd * quan(1, 3) '
Next i
For i = Int(popnum / 2) + 1 To popnum
qi(i) = qi0 + Rnd * quan(2, 1) '
3 n(i) = n0 + (Rnd + 0.0001) * quan(2, 2) '
If sel_bz = 1 And (n(i) < 0 Or n(i) > 1) Then GoTo 3
di(i) = di0 + Rnd * quan(2, 3) '
Next i
'适应度评估检测
sumjsq = 0
1 max_funsy = -9999999
min_funsy = 9999999
For i = 1 To popnum
funsy(i) = 0
For j = 1 To qnum
'If j > qnum / 2 Then quanxs = 1 Else quanxs = 1
If sel_bz = 1 Then quanxs = 1 Else quanxs = j
If sel_bz = 1 Then
funsy(i) = funsy(i) + quanxs * Abs((q(j) - qi(i) * (1 + n(i) * di(i) * T(j)) ^ (-1 / n(i))) / q(j))
Else
funsy(i) = funsy(i) + quanxs * Abs((q(j) - qi(i) * T(j) ^ n(i) * Exp(-T(j) / di(i))) / q(j))
End If
Next j
funsy(i) = 1 / funsy(i)
If funsy(i) > max_funsy Then max_funsy = funsy(i): max_i = i
If funsy(i) < min_funsy Then min_funsy = funsy(i): min_i = i
Next i
Print #2, max_funsy, min_funsy, qi(max_i), n(max_i), di(max_i)
If sumjsq < 5 Or Int(sumjsq / 5) * 5 = sumjsq Then
yaxis_num = 1
ReDim yaxis_grnum(yaxis_num), yaxis_type(yaxis_num)
ReDim yaxis_min(yaxis_num), yaxis_max(yaxis_num), yaxis_interval(yaxis_num)
ReDim yaxis_name$(yaxis_num, 3), yaxis_format$(yaxis_num)
Call init_data
title_name$ = ""
xaxis_name$ = "年月"
xaxis_min = 0: xaxis_max = qnum: xaxis_interval = xaxis_max / 2
xaxis_type = 2: ReDim grdatx_str$(xaxis_max)
For i = 1 To xaxis_max
grdatx_str$(i) = Trim$(Str$(T(i)))
Next i
yaxis_grnum(1) = 2
yaxis_name$(1, 1) = "日产油"
yaxis_format$(1) = "###0.0"
grpoint(1) = qnum: grnote_visible(1) = 0
gr_type(1) = 1
grpoint(2) = qnum: grnote_visible(2) = 0
gr_type(2) = 1
For i = 1 To qnum
grdaty(1, i) = q(i)
If sel_bz = 1 Then
grdaty(2, i) = qi(max_i) * (1 + n(max_i) * di(max_i) * T(i)) ^ (-1 / n(max_i))
Else
grdaty(2, i) = qi(max_i) * T(i) ^ n(max_i) * Exp(-T(i) / di(max_i))
End If
Next i
Picture1.Refresh
Call plotg_main(Me.Picture1)
End If
SSPanel1.Caption = Trim$(Str$(sumjsq))
SSPanel2.Caption = Format$(max_funsy, "###0.00000")
SSPanel3.Caption = Format$(qi(max_i), "###0.000")
SSPanel4.Caption = Format$(n(max_i), "###0.000")
SSPanel5.Caption = Format$(di(max_i), "###0.000")
If sum_sum_jsq > 1 And sumjsq > 15 Then GoTo 100 '1>50
If sum_sum_jsq <= 1 And sumjsq > 5 Then
For i = 1 To popnum
Print #2, qi(i), n(i), di(i)
Next i
qi0 = qi(max_i): n0 = n(max_i): di0 = di(max_i)
sum_sum_jsq = sum_sum_jsq + 1
GoTo 10
End If
'选择
Sum_funsy = 0
For i = 1 To popnum
'funsy(i) = (funsy(i) - min_funsy) / (max_funsy - min_funsy) * 0.01 + min_funsy
Sum_funsy = Sum_funsy + funsy(i)
Next i
jsq = 0
For i = 1 To popnum
funsy(i) = Int(funsy(i) / Sum_funsy * popnum + 0.5)
jsq = jsq + funsy(i)
Next i
If jsq <> popnum Then
If jsq > popnum Then
For i = 1 To Abs(jsq - popnum)
mid_dim(i, 1) = 999
Next i
For i = 1 To popnum
For j = 1 To Abs(jsq - popnum)
If funsy(i) < mid_dim(j, 1) And funsy(i) <> 0 Then mid_dim(j, 1) = funsy(i): mid_dim(j, 2) = i: GoTo 5
Next j
5 Next i
For i = 1 To Abs(jsq - popnum)
funsy(mid_dim(i, 2)) = funsy(mid_dim(i, 2)) - 1
Next i
Else
For i = 1 To Abs(jsq - popnum)
mid_dim(i, 1) = -999
Next i
For i = 1 To popnum
For j = 1 To Abs(jsq - popnum)
If funsy(i) > mid_dim(j, 1) And funsy(i) <> 0 Then mid_dim(j, 1) = funsy(i): mid_dim(j, 2) = i: GoTo 6
Next j
6 Next i
For i = 1 To Abs(jsq - popnum)
funsy(mid_dim(i, 2)) = funsy(mid_dim(i, 2)) + 1
Next i
End If
End If
jsq = 0
For i = 1 To popnum
BZ(i) = 0
Next i
For i = 1 To popnum
If funsy(i) > 0 Then
For j = 1 To funsy(i)
jsq = jsq + 1
qi_mid(jsq) = qi(i)
n_mid(jsq) = n(i)
di_mid(jsq) = di(i)
If i = max_i And j = 1 Then BZ(jsq) = 1
Next j
End If
Next i
For i = 1 To popnum
qi(i) = qi_mid(i)
n(i) = n_mid(i)
di(i) = di_mid(i)
Next i
'配对
pcnum = Int(pc * popnum / 2)
Randomize
For i = 1 To popnum
choose1(i) = -1
Next i
For i = 1 To pcnum * 2
If i > 1 Then
8 midval = Int((popnum * Rnd) + 1)
If BZ(midval) = 1 Then GoTo 8
For j = 1 To i - 1
If choose1(j) = midval Then GoTo 8
Next j
choose1(i) = midval
Else
60 choose1(i) = Int((popnum * Rnd) + 1)
If BZ(choose1(i)) = 1 Then GoTo 60
End If
Next i
For i = 1 To pcnum
Randomize
choosexh = Int((0 * Rnd) + 1)
For j = 1 To 3
'If j <> choosexh Then
Select Case j
Case 1:
mid1 = arel * qi(choose1(i)) + (1 - arel) * qi(choose1(2 * pcnum - i + 1))
mid2 = (1 - arel) * qi(choose1(i)) + arel * qi(choose1(2 * pcnum - i + 1))
qi(choose1(i)) = mid1
qi(choose1(2 * pcnum - i + 1)) = mid2
Case 2:
mid1 = arel * n(choose1(i)) + (1 - arel) * n(choose1(2 * pcnum - i + 1))
mid2 = (1 - arel) * n(choose1(i)) + arel * n(choose1(2 * pcnum - i + 1))
If Abs(mid1) < 0.0001 Then mid1 = 0.5
If Abs(mid2) < 0.0001 Then mid2 = 0.5
If sel_bz = 1 Then
If mid1 < 0 Or mid1 > 1 Then mid1 = 0.5
If mid2 < 0 Or mid2 > 1 Then mid2 = 0.5
End If
n(choose1(i)) = mid1
n(choose1(2 * pcnum - i + 1)) = mid2
Case 3:
mid1 = arel * di(choose1(i)) + (1 - arel) * di(choose1(2 * pcnum - i + 1))
mid2 = (1 - arel) * di(choose1(i)) + arel * di(choose1(2 * pcnum - i + 1))
di(choose1(i)) = mid1
di(choose1(2 * pcnum - i + 1)) = mid2
End Select
'End If
Next j
Next i
'变异
Randomize
pmnum = Int(pm * popnum)
For i = 1 To pmnum
If i > 1 Then
18 midval = Int((popnum * Rnd) + 1)
If BZ(midval) = 1 Then GoTo 18
For j = 1 To i - 1
If choose1(j) = midval Then GoTo 18
Next j
choose1(i) = midval
Else
70 choose1(i) = Int((popnum * Rnd) + 1)
If BZ(choose1(i)) = 1 Then GoTo 70
End If
Randomize
choosexh = Int((0 * Rnd) + 1)
Select Case choosexh
Case 1:
qi(choose1(i)) = qi(choose1(i)) + Int(((quan(2, 1) - quan(1, 1)) * Rnd) - quan(1, 1))
Case 2:
4 midval = n(choose1(i)) + Int(((quan(2, 2) - quan(1, 2)) * Rnd) - quan(1, 2))
If Abs(midval) < 0.00001 Then GoTo 4
If sel_bz = 1 And (midval < 0 Or midval > 1) Then GoTo 4
n(choose1(i)) = midval
Case 3:
di(choose1(i)) = di(choose1(i)) + Int(((quan(2, 3) - quan(1, 3)) * Rnd) - quan(1, 3))
End Select
Next i
sumjsq = sumjsq + 1
GoTo 1
100 Close #2
End Sub
Private Sub Form_Load()
ReDim grpoint(grnum_max), gr_type(grnum_max), grnote_visible(grnum_max), grnote_LR(grnum_max)
ReDim grnote_name$(grnum_max)
ReDim Lstyle(grnum_max), Lwidth(grnum_max), Lcolor(grnum_max)
ReDim Pstyle(grnum_max), Pwidth(grnum_max), Pcolor(grnum_max)
ReDim grdatx(grnum_max, grpoint_max), grdaty(grnum_max, grpoint_max)
'Me.Left = 3600: Me.Top = 2000
'Me.Width = 5240: Me.Height = 5352
End Sub
Private Sub Label1_Click()
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -